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
6 This file is part of GCC.
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
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
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
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new;
72 for (; p
; p
= p
->next
)
74 new = gfc_get_actual_arglist ();
77 new->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
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
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
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. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
159 mpfr_clear (e
->value
.complex.r
);
160 mpfr_clear (e
->value
.complex.i
);
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
);
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
);
182 gfc_free_actual_arglist (e
->value
.function
.actual
);
190 gfc_free_constructor (e
->value
.constructor
);
194 gfc_free (e
->value
.character
.string
);
201 gfc_internal_error ("free_expr0(): Bad expr type");
204 /* Free a shape array. */
205 if (e
->shape
!= NULL
)
207 for (n
= 0; n
< e
->rank
; n
++)
208 mpz_clear (e
->shape
[n
]);
213 gfc_free_ref_list (e
->ref
);
215 memset (e
, '\0', sizeof (gfc_expr
));
219 /* Free an expression node and everything beneath it. */
222 gfc_free_expr (gfc_expr
*e
)
226 if (e
->con_by_offset
)
227 splay_tree_delete (e
->con_by_offset
);
233 /* Graft the *src expression onto the *dest subexpression. */
236 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
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. */
250 gfc_extract_int (gfc_expr
*expr
, int *result
)
252 if (expr
->expr_type
!= EXPR_CONSTANT
)
253 return _("Constant expression required at %C");
255 if (expr
->ts
.type
!= BT_INTEGER
)
256 return _("Integer expression required at %C");
258 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
259 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
261 return _("Integer value too large in expression at %C");
264 *result
= (int) mpz_get_si (expr
->value
.integer
);
270 /* Recursively copy a list of reference structures. */
273 copy_ref (gfc_ref
*src
)
281 dest
= gfc_get_ref ();
282 dest
->type
= src
->type
;
287 ar
= gfc_copy_array_ref (&src
->u
.ar
);
293 dest
->u
.c
= src
->u
.c
;
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
);
303 dest
->next
= copy_ref (src
->next
);
309 /* Detect whether an expression has any vector index array references. */
312 gfc_has_vector_index (gfc_expr
*e
)
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
)
325 /* Copy a shape array. */
328 gfc_copy_shape (mpz_t
*shape
, int rank
)
336 new_shape
= gfc_get_shape (rank
);
338 for (n
= 0; n
< rank
; n
++)
339 mpz_init_set (new_shape
[n
], shape
[n
]);
345 /* Copy a shape array excluding dimension N, where N is an integer
346 constant expression. Dimensions are numbered in fortran style --
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}
354 If anything goes wrong -- N is not a constant, its value is out
355 of range -- or anything else, just returns NULL. */
358 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
360 mpz_t
*new_shape
, *s
;
366 || dim
->expr_type
!= EXPR_CONSTANT
367 || dim
->ts
.type
!= BT_INTEGER
)
370 n
= mpz_get_si (dim
->value
.integer
);
371 n
--; /* Convert to zero based index. */
372 if (n
< 0 || n
>= rank
)
375 s
= new_shape
= gfc_get_shape (rank
- 1);
377 for (i
= 0; i
< rank
; i
++)
381 mpz_init_set (*s
, shape
[i
]);
389 /* Given an expression pointer, return a copy of the expression. This
390 subroutine is recursive. */
393 gfc_copy_expr (gfc_expr
*p
)
404 switch (q
->expr_type
)
407 s
= gfc_getmem (p
->value
.character
.length
+ 1);
408 q
->value
.character
.string
= s
;
410 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
414 /* Copy target representation, if it exists. */
415 if (p
->representation
.string
)
417 s
= gfc_getmem (p
->representation
.length
+ 1);
418 q
->representation
.string
= s
;
420 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
423 /* Copy the values of any pointer components of p->value. */
427 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
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
);
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
);
445 if (p
->representation
.string
)
446 q
->value
.character
.string
= q
->representation
.string
;
449 s
= gfc_getmem (p
->value
.character
.length
+ 1);
450 q
->value
.character
.string
= s
;
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
))
457 /* Need to set the length to 1 to make sure the NUL
458 terminator is copied. */
459 q
->value
.character
.length
= 1;
462 memcpy (s
, p
->value
.character
.string
,
463 p
->value
.character
.length
+ 1);
470 break; /* Already done. */
474 /* Should never be reached. */
476 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
483 switch (q
->value
.op
.operator)
486 case INTRINSIC_PARENTHESES
:
487 case INTRINSIC_UPLUS
:
488 case INTRINSIC_UMINUS
:
489 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
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
);
501 q
->value
.function
.actual
=
502 gfc_copy_actual_arglist (p
->value
.function
.actual
);
507 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
515 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
517 q
->ref
= copy_ref (p
->ref
);
523 /* Return the maximum kind of two expressions. In general, higher
524 kind numbers mean more precision for numeric types. */
527 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
529 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
533 /* Returns nonzero if the type is numeric, zero otherwise. */
536 numeric_type (bt type
)
538 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
542 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
545 gfc_numeric_ts (gfc_typespec
*ts
)
547 return numeric_type (ts
->type
);
551 /* Returns an expression node that is an integer constant. */
560 p
->expr_type
= EXPR_CONSTANT
;
561 p
->ts
.type
= BT_INTEGER
;
562 p
->ts
.kind
= gfc_default_integer_kind
;
564 p
->where
= gfc_current_locus
;
565 mpz_init_set_si (p
->value
.integer
, i
);
571 /* Returns an expression node that is a logical constant. */
574 gfc_logical_expr (int i
, locus
*where
)
580 p
->expr_type
= EXPR_CONSTANT
;
581 p
->ts
.type
= BT_LOGICAL
;
582 p
->ts
.kind
= gfc_default_logical_kind
;
585 where
= &gfc_current_locus
;
587 p
->value
.logical
= i
;
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. */
598 gfc_build_conversion (gfc_expr
*e
)
603 p
->expr_type
= EXPR_FUNCTION
;
605 p
->value
.function
.actual
= NULL
;
607 p
->value
.function
.actual
= gfc_get_actual_arglist ();
608 p
->value
.function
.actual
->expr
= e
;
614 /* Given an expression node with some sort of numeric binary
615 expression, insert type conversions required to make the operands
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. */
624 gfc_type_convert_binary (gfc_expr
*e
)
628 op1
= e
->value
.op
.op1
;
629 op2
= e
->value
.op
.op2
;
631 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
633 gfc_clear_ts (&e
->ts
);
637 /* Kind conversions of same type. */
638 if (op1
->ts
.type
== op2
->ts
.type
)
640 if (op1
->ts
.kind
== op2
->ts
.kind
)
642 /* No type conversions. */
647 if (op1
->ts
.kind
> op2
->ts
.kind
)
648 gfc_convert_type (op2
, &op1
->ts
, 2);
650 gfc_convert_type (op1
, &op2
->ts
, 2);
656 /* Integer combined with real or complex. */
657 if (op2
->ts
.type
== BT_INTEGER
)
661 /* Special case for ** operator. */
662 if (e
->value
.op
.operator == INTRINSIC_POWER
)
665 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
669 if (op1
->ts
.type
== BT_INTEGER
)
672 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
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
;
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);
693 check_specification_function (gfc_expr
*e
)
696 sym
= e
->symtree
->n
.sym
;
698 /* F95, 7.1.6.2; F2003, 7.1.7 */
700 && sym
->attr
.function
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
)
713 /* Function to determine if an expression is constant or not. This
714 function expects that the expression has already been simplified. */
717 gfc_is_constant_expr (gfc_expr
*e
)
720 gfc_actual_arglist
*arg
;
726 switch (e
->expr_type
)
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
)));
739 /* Specification functions are constant. */
740 if (check_specification_function (e
) == MATCH_YES
)
746 /* Call to intrinsic with at least one argument. */
748 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
750 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
752 if (!gfc_is_constant_expr (arg
->expr
))
766 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
767 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
772 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
773 if (!gfc_is_constant_expr (c
->expr
))
781 rv
= gfc_constant_ac (e
);
785 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
792 /* Try to collapse intrinsic expressions. */
795 simplify_intrinsic_op (gfc_expr
*p
, int type
)
798 gfc_expr
*op1
, *op2
, *result
;
800 if (p
->value
.op
.operator == INTRINSIC_USER
)
803 op1
= p
->value
.op
.op1
;
804 op2
= p
->value
.op
.op2
;
805 op
= p
->value
.op
.operator;
807 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
809 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
812 if (!gfc_is_constant_expr (op1
)
813 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
817 p
->value
.op
.op1
= NULL
;
818 p
->value
.op
.op2
= NULL
;
822 case INTRINSIC_PARENTHESES
:
823 result
= gfc_parentheses (op1
);
826 case INTRINSIC_UPLUS
:
827 result
= gfc_uplus (op1
);
830 case INTRINSIC_UMINUS
:
831 result
= gfc_uminus (op1
);
835 result
= gfc_add (op1
, op2
);
838 case INTRINSIC_MINUS
:
839 result
= gfc_subtract (op1
, op2
);
842 case INTRINSIC_TIMES
:
843 result
= gfc_multiply (op1
, op2
);
846 case INTRINSIC_DIVIDE
:
847 result
= gfc_divide (op1
, op2
);
850 case INTRINSIC_POWER
:
851 result
= gfc_power (op1
, op2
);
854 case INTRINSIC_CONCAT
:
855 result
= gfc_concat (op1
, op2
);
859 case INTRINSIC_EQ_OS
:
860 result
= gfc_eq (op1
, op2
, op
);
864 case INTRINSIC_NE_OS
:
865 result
= gfc_ne (op1
, op2
, op
);
869 case INTRINSIC_GT_OS
:
870 result
= gfc_gt (op1
, op2
, op
);
874 case INTRINSIC_GE_OS
:
875 result
= gfc_ge (op1
, op2
, op
);
879 case INTRINSIC_LT_OS
:
880 result
= gfc_lt (op1
, op2
, op
);
884 case INTRINSIC_LE_OS
:
885 result
= gfc_le (op1
, op2
, op
);
889 result
= gfc_not (op1
);
893 result
= gfc_and (op1
, op2
);
897 result
= gfc_or (op1
, op2
);
901 result
= gfc_eqv (op1
, op2
);
905 result
= gfc_neqv (op1
, op2
);
909 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
919 result
->rank
= p
->rank
;
920 result
->where
= p
->where
;
921 gfc_replace_expr (p
, result
);
927 /* Subroutine to simplify constructor expressions. Mutually recursive
928 with gfc_simplify_expr(). */
931 simplify_constructor (gfc_constructor
*c
, int type
)
933 for (; c
; c
= c
->next
)
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
))
941 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
949 /* Pull a single array element out of an array constructor. */
952 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
953 gfc_constructor
**rval
)
955 unsigned long nelemen
;
967 mpz_init_set_ui (offset
, 0);
970 mpz_init_set_ui (span
, 1);
971 for (i
= 0; i
< ar
->dimen
; i
++)
973 e
= gfc_copy_expr (ar
->start
[i
]);
974 if (e
->expr_type
!= EXPR_CONSTANT
)
980 /* Check the bounds. */
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))
986 gfc_error ("index in dimension %d is out of bounds "
987 "at %L", i
+ 1, &ar
->c_where
[i
]);
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
);
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
);
1005 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1028 /* Find a component of a structure constructor. */
1030 static gfc_constructor
*
1031 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1033 gfc_component
*comp
;
1034 gfc_component
*pick
;
1036 comp
= ref
->u
.c
.sym
->components
;
1037 pick
= ref
->u
.c
.component
;
1038 while (comp
!= pick
)
1048 /* Replace an expression with the contents of a constructor, removing
1049 the subobject reference in the process. */
1052 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1058 e
->ref
= p
->ref
->next
;
1059 p
->ref
->next
= NULL
;
1060 gfc_replace_expr (p
, e
);
1064 /* Pull an array section out of an array constructor. */
1067 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1073 long unsigned one
= 1;
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
];
1085 gfc_constructor
*cons
;
1086 gfc_constructor
*base
;
1092 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1097 base
= expr
->value
.constructor
;
1098 expr
->value
.constructor
= NULL
;
1100 rank
= ref
->u
.ar
.as
->rank
;
1102 if (expr
->shape
== NULL
)
1103 expr
->shape
= gfc_get_shape (rank
);
1105 mpz_init_set_ui (delta_mpz
, one
);
1106 mpz_init_set_ui (nelts
, one
);
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
++)
1113 mpz_init (delta
[d
]);
1114 mpz_init (start
[d
]);
1117 mpz_init (stride
[d
]);
1121 /* Build the counters to clock through the array reference. */
1123 for (d
= 0; d
< rank
; d
++)
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
];
1132 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1136 if (begin
->expr_type
!= EXPR_ARRAY
)
1142 gcc_assert (begin
->rank
== 1);
1143 gcc_assert (begin
->shape
);
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]);
1151 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1153 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1154 || mpz_cmp (c
->expr
->value
.integer
,
1155 lower
->value
.integer
) < 0)
1157 gfc_error ("index in dimension %d is out of bounds "
1158 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1166 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1167 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1168 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1174 /* Obtain the stride. */
1176 mpz_set (stride
[d
], step
->value
.integer
);
1178 mpz_set_ui (stride
[d
], one
);
1180 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1181 mpz_set_ui (stride
[d
], one
);
1183 /* Obtain the start value for the index. */
1185 mpz_set (start
[d
], begin
->value
.integer
);
1187 mpz_set (start
[d
], lower
->value
.integer
);
1189 mpz_set (ctr
[d
], start
[d
]);
1191 /* Obtain the end value for the index. */
1193 mpz_set (end
[d
], finish
->value
.integer
);
1195 mpz_set (end
[d
], upper
->value
.integer
);
1197 /* Separate 'if' because elements sometimes arrive with
1199 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1200 mpz_set (end
[d
], begin
->value
.integer
);
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)
1208 gfc_error ("index in dimension %d is out of bounds "
1209 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
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
);
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
);
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
);
1239 /* Now clock through the array reference, calculating the index in
1240 the source constructor and transferring the elements to the new
1242 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1244 if (ref
->u
.ar
.offset
)
1245 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1247 mpz_init_set_ui (ptr
, 0);
1250 for (d
= 0; d
< rank
; d
++)
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
);
1257 if (!incr_ctr
) continue;
1259 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1261 gcc_assert(vecsub
[d
]);
1263 if (!vecsub
[d
]->next
)
1264 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1267 vecsub
[d
] = vecsub
[d
]->next
;
1270 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1274 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
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
]);
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)
1289 mpz_set_ui (index
, 0);
1293 while (mpz_cmp (ptr
, index
) > 0)
1295 mpz_add_ui (index
, index
, one
);
1299 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1307 mpz_clear (delta_mpz
);
1308 mpz_clear (tmp_mpz
);
1310 for (d
= 0; d
< rank
; d
++)
1312 mpz_clear (delta
[d
]);
1313 mpz_clear (start
[d
]);
1316 mpz_clear (stride
[d
]);
1318 gfc_free_constructor (base
);
1322 /* Pull a substring out of an expression. */
1325 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1331 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1332 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
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
);
1340 (*newp
)->value
.character
.length
= end
- start
+ 1;
1341 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1342 (*newp
)->value
.character
.length
);
1348 /* Simplify a subobject reference of a constructor. This occurs when
1349 parameter variable values are substituted. */
1352 simplify_const_ref (gfc_expr
*p
)
1354 gfc_constructor
*cons
;
1359 switch (p
->ref
->type
)
1362 switch (p
->ref
->u
.ar
.type
)
1365 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1372 remove_subobject_ref (p
, cons
);
1376 if (find_array_section (p
, p
->ref
) == FAILURE
)
1378 p
->ref
->u
.ar
.type
= AR_FULL
;
1383 if (p
->ref
->next
!= NULL
1384 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1386 cons
= p
->value
.constructor
;
1387 for (; cons
; cons
= cons
->next
)
1389 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1390 simplify_const_ref (cons
->expr
);
1393 gfc_free_ref_list (p
->ref
);
1404 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1405 remove_subobject_ref (p
, cons
);
1409 if (find_substring_ref (p
, &newp
) == FAILURE
)
1412 gfc_replace_expr (p
, newp
);
1413 gfc_free_ref_list (p
->ref
);
1423 /* Simplify a chain of references. */
1426 simplify_ref_chain (gfc_ref
*ref
, int type
)
1430 for (; ref
; ref
= ref
->next
)
1435 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1437 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1439 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1441 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1447 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1449 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1461 /* Try to substitute the value of a parameter variable. */
1464 simplify_parameter_variable (gfc_expr
*p
, int type
)
1469 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
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
);
1480 /* Only use the simplification if it eliminated all subobject references. */
1481 if (t
== SUCCESS
&& !e
->ref
)
1482 gfc_replace_expr (p
, e
);
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
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
1501 The expression type is defined for:
1502 0 Basic expression parsing
1503 1 Simplifying array constructors -- will substitute
1505 Returns FAILURE on error, SUCCESS otherwise.
1506 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1509 gfc_simplify_expr (gfc_expr
*p
, int type
)
1511 gfc_actual_arglist
*ap
;
1516 switch (p
->expr_type
)
1523 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1524 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1527 if (p
->value
.function
.isym
!= NULL
1528 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1533 case EXPR_SUBSTRING
:
1534 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1537 if (gfc_is_constant_expr (p
))
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
);
1557 p
->expr_type
= EXPR_CONSTANT
;
1562 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
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
))
1573 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1580 gfc_simplify_iterator_var (p
);
1583 /* Simplify subcomponent references. */
1584 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1589 case EXPR_STRUCTURE
:
1591 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1594 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
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
);
1601 if (simplify_const_ref (p
) == FAILURE
)
1611 /* Returns the type of an expression with the exception that iterator
1612 variables are automatically integers no matter what else they may
1618 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1625 /* Check an intrinsic arithmetic operation to see if it is consistent
1626 with some type of expression. */
1628 static try check_init_expr (gfc_expr
*);
1631 /* Scalarize an expression for an elemental intrinsic call. */
1634 scalarize_intrinsic_call (gfc_expr
*e
)
1636 gfc_actual_arglist
*a
, *b
;
1637 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1638 gfc_expr
*expr
, *old
;
1641 old
= gfc_copy_expr (e
);
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
;
1650 expr
->expr_type
= EXPR_ARRAY
;
1652 /* Copy the array argument constructors into an array, with nulls
1655 a
= old
->value
.function
.actual
;
1656 for (; a
; a
= a
->next
)
1658 /* Check that this is OK for an initialization expression. */
1659 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1663 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1665 rank
[n
] = a
->expr
->rank
;
1666 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1667 args
[n
] = gfc_copy_constructor (ctor
);
1669 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1672 rank
[n
] = a
->expr
->rank
;
1675 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1682 for (i
= 1; i
< n
; i
++)
1683 if (rank
[i
] && rank
[i
] != rank
[0])
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. */
1691 for (; ctor
; ctor
= ctor
->next
)
1693 if (expr
->value
.constructor
== NULL
)
1694 expr
->value
.constructor
1695 = new_ctor
= gfc_get_constructor ();
1698 new_ctor
->next
= gfc_get_constructor ();
1699 new_ctor
= new_ctor
->next
;
1701 new_ctor
->expr
= gfc_copy_expr (old
);
1702 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1704 b
= old
->value
.function
.actual
;
1705 for (i
= 0; i
< n
; i
++)
1708 new_ctor
->expr
->value
.function
.actual
1709 = a
= gfc_get_actual_arglist ();
1712 a
->next
= gfc_get_actual_arglist ();
1716 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1718 a
->expr
= gfc_copy_expr (b
->expr
);
1723 /* Simplify the function calls. */
1724 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1727 for (i
= 0; i
< n
; i
++)
1729 args
[i
] = args
[i
]->next
;
1731 for (i
= 1; i
< n
; i
++)
1732 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1733 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1739 gfc_free_expr (old
);
1743 gfc_error_now ("elemental function arguments at %C are not compliant");
1746 gfc_free_expr (expr
);
1747 gfc_free_expr (old
);
1753 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1755 gfc_expr
*op1
= e
->value
.op
.op1
;
1756 gfc_expr
*op2
= e
->value
.op
.op2
;
1758 if ((*check_function
) (op1
) == FAILURE
)
1761 switch (e
->value
.op
.operator)
1763 case INTRINSIC_UPLUS
:
1764 case INTRINSIC_UMINUS
:
1765 if (!numeric_type (et0 (op1
)))
1770 case INTRINSIC_EQ_OS
:
1772 case INTRINSIC_NE_OS
:
1774 case INTRINSIC_GT_OS
:
1776 case INTRINSIC_GE_OS
:
1778 case INTRINSIC_LT_OS
:
1780 case INTRINSIC_LE_OS
:
1781 if ((*check_function
) (op2
) == FAILURE
)
1784 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1785 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1787 gfc_error ("Numeric or CHARACTER operands are required in "
1788 "expression at %L", &e
->where
);
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
)
1801 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1804 if (e
->value
.op
.operator == INTRINSIC_POWER
1805 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1807 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1808 "exponent in an initialization "
1809 "expression at %L", &op2
->where
)
1816 case INTRINSIC_CONCAT
:
1817 if ((*check_function
) (op2
) == FAILURE
)
1820 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1822 gfc_error ("Concatenation operator in expression at %L "
1823 "must have two CHARACTER operands", &op1
->where
);
1827 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1829 gfc_error ("Concat operator at %L must concatenate strings of the "
1830 "same kind", &e
->where
);
1837 if (et0 (op1
) != BT_LOGICAL
)
1839 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1840 "operand", &op1
->where
);
1849 case INTRINSIC_NEQV
:
1850 if ((*check_function
) (op2
) == FAILURE
)
1853 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1855 gfc_error ("LOGICAL operands are required in expression at %L",
1862 case INTRINSIC_PARENTHESES
:
1866 gfc_error ("Only intrinsic operators can be used in expression at %L",
1874 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1881 check_init_expr_arguments (gfc_expr
*e
)
1883 gfc_actual_arglist
*ap
;
1885 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1886 if (check_init_expr (ap
->expr
) == FAILURE
)
1892 /* F95, 7.1.6.1, Initialization expressions, (7)
1893 F2003, 7.1.7 Initialization expression, (8) */
1896 check_inquiry (gfc_expr
*e
, int not_restricted
)
1899 const char *const *functions
;
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",
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",
1918 gfc_actual_arglist
*ap
;
1920 if (!e
->value
.function
.isym
1921 || !e
->value
.function
.isym
->inquiry
)
1924 /* An undeclared parameter will get us here (PR25018). */
1925 if (e
->symtree
== NULL
)
1928 name
= e
->symtree
->n
.sym
->name
;
1930 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1931 ? inquiry_func_f2003
: inquiry_func_f95
;
1933 for (i
= 0; functions
[i
]; i
++)
1934 if (strcmp (functions
[i
], name
) == 0)
1937 if (functions
[i
] == NULL
)
1939 gfc_error ("Inquiry function '%s' at %L is not permitted "
1940 "in an initialization expression", name
, &e
->where
);
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. */
1948 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1953 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
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
)
1960 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
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
)
1969 gfc_error ("assumed character length variable '%s' in constant "
1970 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
1973 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
1981 /* F95, 7.1.6.1, Initialization expressions, (5)
1982 F2003, 7.1.7 Initialization expression, (5) */
1985 check_transformational (gfc_expr
*e
)
1987 static const char * const trans_func_f95
[] = {
1988 "repeat", "reshape", "selected_int_kind",
1989 "selected_real_kind", "transfer", "trim", NULL
1995 if (!e
->value
.function
.isym
1996 || !e
->value
.function
.isym
->transformational
)
1999 name
= e
->symtree
->n
.sym
->name
;
2001 /* NULL() is dealt with below. */
2002 if (strcmp ("null", name
) == 0)
2005 for (i
= 0; trans_func_f95
[i
]; i
++)
2006 if (strcmp (trans_func_f95
[i
], name
) == 0)
2009 /* FIXME, F2003: implement translation of initialization
2010 expressions before enabling this check. For F95, error
2011 out if the transformational function is not in the list. */
2013 if (trans_func_f95
[i
] == NULL
2014 && gfc_notify_std (GFC_STD_F2003
,
2015 "transformational intrinsic '%s' at %L is not permitted "
2016 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2019 if (trans_func_f95
[i
] == NULL
)
2021 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2022 "in an initialization expression", name
, &e
->where
);
2027 return check_init_expr_arguments (e
);
2031 /* F95, 7.1.6.1, Initialization expressions, (6)
2032 F2003, 7.1.7 Initialization expression, (6) */
2035 check_null (gfc_expr
*e
)
2037 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2040 return check_init_expr_arguments (e
);
2045 check_elemental (gfc_expr
*e
)
2047 if (!e
->value
.function
.isym
2048 || !e
->value
.function
.isym
->elemental
)
2051 if ((e
->ts
.type
!= BT_INTEGER
|| e
->ts
.type
!= BT_CHARACTER
)
2052 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2053 "nonstandard initialization expression at %L",
2054 &e
->where
) == FAILURE
)
2057 return check_init_expr_arguments (e
);
2062 check_conversion (gfc_expr
*e
)
2064 if (!e
->value
.function
.isym
2065 || !e
->value
.function
.isym
->conversion
)
2068 return check_init_expr_arguments (e
);
2072 /* Verify that an expression is an initialization expression. A side
2073 effect is that the expression tree is reduced to a single constant
2074 node if all goes well. This would normally happen when the
2075 expression is constructed but function references are assumed to be
2076 intrinsics in the context of initialization expressions. If
2077 FAILURE is returned an error message has been generated. */
2080 check_init_expr (gfc_expr
*e
)
2084 gfc_intrinsic_sym
*isym
;
2089 switch (e
->expr_type
)
2092 t
= check_intrinsic_op (e
, check_init_expr
);
2094 t
= gfc_simplify_expr (e
, 0);
2101 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2103 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2105 gfc_error ("Function '%s' in initialization expression at %L "
2106 "must be an intrinsic or a specification function",
2107 e
->symtree
->n
.sym
->name
, &e
->where
);
2111 if ((m
= check_conversion (e
)) == MATCH_NO
2112 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2113 && (m
= check_null (e
)) == MATCH_NO
2114 && (m
= check_transformational (e
)) == MATCH_NO
2115 && (m
= check_elemental (e
)) == MATCH_NO
)
2117 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2118 "in an initialization expression",
2119 e
->symtree
->n
.sym
->name
, &e
->where
);
2123 /* Try to scalarize an elemental intrinsic function that has an
2125 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2126 if (isym
&& isym
->elemental
2127 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2129 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2142 if (gfc_check_iter_variable (e
) == SUCCESS
)
2145 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2147 t
= simplify_parameter_variable (e
, 0);
2151 if (gfc_in_match_data ())
2156 if (e
->symtree
->n
.sym
->as
)
2158 switch (e
->symtree
->n
.sym
->as
->type
)
2160 case AS_ASSUMED_SIZE
:
2161 gfc_error ("assumed size array '%s' at %L is not permitted "
2162 "in an initialization expression",
2163 e
->symtree
->n
.sym
->name
, &e
->where
);
2166 case AS_ASSUMED_SHAPE
:
2167 gfc_error ("assumed shape array '%s' at %L is not permitted "
2168 "in an initialization expression",
2169 e
->symtree
->n
.sym
->name
, &e
->where
);
2173 gfc_error ("deferred array '%s' at %L is not permitted "
2174 "in an initialization expression",
2175 e
->symtree
->n
.sym
->name
, &e
->where
);
2183 gfc_error ("Parameter '%s' at %L has not been declared or is "
2184 "a variable, which does not reduce to a constant "
2185 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2194 case EXPR_SUBSTRING
:
2195 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2199 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2201 t
= gfc_simplify_expr (e
, 0);
2205 case EXPR_STRUCTURE
:
2206 t
= gfc_check_constructor (e
, check_init_expr
);
2210 t
= gfc_check_constructor (e
, check_init_expr
);
2214 t
= gfc_expand_constructor (e
);
2218 t
= gfc_check_constructor_type (e
);
2222 gfc_internal_error ("check_init_expr(): Unknown expression type");
2229 /* Match an initialization expression. We work by first matching an
2230 expression, then reducing it to a constant. */
2233 gfc_match_init_expr (gfc_expr
**result
)
2239 m
= gfc_match_expr (&expr
);
2244 t
= gfc_resolve_expr (expr
);
2246 t
= check_init_expr (expr
);
2251 gfc_free_expr (expr
);
2255 if (expr
->expr_type
== EXPR_ARRAY
2256 && (gfc_check_constructor_type (expr
) == FAILURE
2257 || gfc_expand_constructor (expr
) == FAILURE
))
2259 gfc_free_expr (expr
);
2263 /* Not all inquiry functions are simplified to constant expressions
2264 so it is necessary to call check_inquiry again. */
2265 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2266 && !gfc_in_match_data ())
2268 gfc_error ("Initialization expression didn't reduce %C");
2278 static try check_restricted (gfc_expr
*);
2280 /* Given an actual argument list, test to see that each argument is a
2281 restricted expression and optionally if the expression type is
2282 integer or character. */
2285 restricted_args (gfc_actual_arglist
*a
)
2287 for (; a
; a
= a
->next
)
2289 if (check_restricted (a
->expr
) == FAILURE
)
2297 /************* Restricted/specification expressions *************/
2300 /* Make sure a non-intrinsic function is a specification function. */
2303 external_spec_function (gfc_expr
*e
)
2307 f
= e
->value
.function
.esym
;
2309 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2311 gfc_error ("Specification function '%s' at %L cannot be a statement "
2312 "function", f
->name
, &e
->where
);
2316 if (f
->attr
.proc
== PROC_INTERNAL
)
2318 gfc_error ("Specification function '%s' at %L cannot be an internal "
2319 "function", f
->name
, &e
->where
);
2323 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2325 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2330 if (f
->attr
.recursive
)
2332 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2333 f
->name
, &e
->where
);
2337 return restricted_args (e
->value
.function
.actual
);
2341 /* Check to see that a function reference to an intrinsic is a
2342 restricted expression. */
2345 restricted_intrinsic (gfc_expr
*e
)
2347 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2348 if (check_inquiry (e
, 0) == MATCH_YES
)
2351 return restricted_args (e
->value
.function
.actual
);
2355 /* Verify that an expression is a restricted expression. Like its
2356 cousin check_init_expr(), an error message is generated if we
2360 check_restricted (gfc_expr
*e
)
2368 switch (e
->expr_type
)
2371 t
= check_intrinsic_op (e
, check_restricted
);
2373 t
= gfc_simplify_expr (e
, 0);
2378 t
= e
->value
.function
.esym
? external_spec_function (e
)
2379 : restricted_intrinsic (e
);
2383 sym
= e
->symtree
->n
.sym
;
2386 if (sym
->attr
.optional
)
2388 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2389 sym
->name
, &e
->where
);
2393 if (sym
->attr
.intent
== INTENT_OUT
)
2395 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2396 sym
->name
, &e
->where
);
2400 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2401 processed in resolve.c(resolve_formal_arglist). This is done so
2402 that host associated dummy array indices are accepted (PR23446).
2403 This mechanism also does the same for the specification expressions
2404 of array-valued functions. */
2405 if (sym
->attr
.in_common
2406 || sym
->attr
.use_assoc
2408 || sym
->ns
!= gfc_current_ns
2409 || (sym
->ns
->proc_name
!= NULL
2410 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2411 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2417 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2418 sym
->name
, &e
->where
);
2427 case EXPR_SUBSTRING
:
2428 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2432 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2434 t
= gfc_simplify_expr (e
, 0);
2438 case EXPR_STRUCTURE
:
2439 t
= gfc_check_constructor (e
, check_restricted
);
2443 t
= gfc_check_constructor (e
, check_restricted
);
2447 gfc_internal_error ("check_restricted(): Unknown expression type");
2454 /* Check to see that an expression is a specification expression. If
2455 we return FAILURE, an error has been generated. */
2458 gfc_specification_expr (gfc_expr
*e
)
2464 if (e
->ts
.type
!= BT_INTEGER
)
2466 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2472 gfc_error ("Expression at %L must be scalar", &e
->where
);
2476 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2479 return check_restricted (e
);
2483 /************** Expression conformance checks. *************/
2485 /* Given two expressions, make sure that the arrays are conformable. */
2488 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2490 int op1_flag
, op2_flag
, d
;
2491 mpz_t op1_size
, op2_size
;
2494 if (op1
->rank
== 0 || op2
->rank
== 0)
2497 if (op1
->rank
!= op2
->rank
)
2499 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2506 for (d
= 0; d
< op1
->rank
; d
++)
2508 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2509 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2511 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2513 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2514 _(optype_msgid
), &op1
->where
, d
+ 1,
2515 (int) mpz_get_si (op1_size
),
2516 (int) mpz_get_si (op2_size
));
2522 mpz_clear (op1_size
);
2524 mpz_clear (op2_size
);
2534 /* Given an assignable expression and an arbitrary expression, make
2535 sure that the assignment can take place. */
2538 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2544 sym
= lvalue
->symtree
->n
.sym
;
2546 /* Check INTENT(IN), unless the object itself is the component or
2547 sub-component of a pointer. */
2548 has_pointer
= sym
->attr
.pointer
;
2550 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2551 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2557 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2559 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2560 sym
->name
, &lvalue
->where
);
2564 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2565 variable local to a function subprogram. Its existence begins when
2566 execution of the function is initiated and ends when execution of the
2567 function is terminated...
2568 Therefore, the left hand side is no longer a variable, when it is: */
2569 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2570 && !sym
->attr
.external
)
2575 /* (i) Use associated; */
2576 if (sym
->attr
.use_assoc
)
2579 /* (ii) The assignment is in the main program; or */
2580 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2583 /* (iii) A module or internal procedure... */
2584 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2585 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2586 && gfc_current_ns
->parent
2587 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2588 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2589 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2591 /* ... that is not a function... */
2592 if (!gfc_current_ns
->proc_name
->attr
.function
)
2595 /* ... or is not an entry and has a different name. */
2596 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2602 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2607 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2609 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2610 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2614 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2616 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2621 if (rvalue
->expr_type
== EXPR_NULL
)
2623 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2624 && lvalue
->symtree
->n
.sym
->attr
.data
)
2628 gfc_error ("NULL appears on right-hand side in assignment at %L",
2634 if (sym
->attr
.cray_pointee
2635 && lvalue
->ref
!= NULL
2636 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2637 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2639 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2640 "is illegal", &lvalue
->where
);
2644 /* This is possibly a typo: x = f() instead of x => f(). */
2645 if (gfc_option
.warn_surprising
2646 && rvalue
->expr_type
== EXPR_FUNCTION
2647 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2648 gfc_warning ("POINTER valued function appears on right-hand side of "
2649 "assignment at %L", &rvalue
->where
);
2651 /* Check size of array assignments. */
2652 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2653 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2656 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2661 /* Numeric can be converted to any other numeric. And Hollerith can be
2662 converted to any other type. */
2663 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2664 || rvalue
->ts
.type
== BT_HOLLERITH
)
2667 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2670 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2671 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2672 gfc_typename (&lvalue
->ts
));
2677 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2681 /* Check that a pointer assignment is OK. We first check lvalue, and
2682 we only check rvalue if it's not an assignment to NULL() or a
2683 NULLIFY statement. */
2686 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2688 symbol_attribute attr
;
2691 int pointer
, check_intent_in
;
2693 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2695 gfc_error ("Pointer assignment target is not a POINTER at %L",
2700 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2701 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2703 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2704 "l-value since it is a procedure",
2705 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2710 /* Check INTENT(IN), unless the object itself is the component or
2711 sub-component of a pointer. */
2712 check_intent_in
= 1;
2713 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2715 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2718 check_intent_in
= 0;
2720 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2724 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2726 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2727 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2733 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2737 is_pure
= gfc_pure (NULL
);
2739 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2741 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2745 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2746 kind, etc for lvalue and rvalue must match, and rvalue must be a
2747 pure variable if we're in a pure function. */
2748 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2751 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2753 gfc_error ("Different types in pointer assignment at %L",
2758 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2760 gfc_error ("Different kind type parameters in pointer "
2761 "assignment at %L", &lvalue
->where
);
2765 if (lvalue
->rank
!= rvalue
->rank
)
2767 gfc_error ("Different ranks in pointer assignment at %L",
2772 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2773 if (rvalue
->expr_type
== EXPR_NULL
)
2776 if (lvalue
->ts
.type
== BT_CHARACTER
2777 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2778 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2779 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2780 rvalue
->ts
.cl
->length
)) == 1)
2782 gfc_error ("Different character lengths in pointer "
2783 "assignment at %L", &lvalue
->where
);
2787 attr
= gfc_expr_attr (rvalue
);
2788 if (!attr
.target
&& !attr
.pointer
)
2790 gfc_error ("Pointer assignment target is neither TARGET "
2791 "nor POINTER at %L", &rvalue
->where
);
2795 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2797 gfc_error ("Bad target in pointer assignment in PURE "
2798 "procedure at %L", &rvalue
->where
);
2801 if (gfc_has_vector_index (rvalue
))
2803 gfc_error ("Pointer assignment with vector subscript "
2804 "on rhs at %L", &rvalue
->where
);
2808 if (attr
.protected && attr
.use_assoc
)
2810 gfc_error ("Pointer assigment target has PROTECTED "
2811 "attribute at %L", &rvalue
->where
);
2819 /* Relative of gfc_check_assign() except that the lvalue is a single
2820 symbol. Used for initialization assignments. */
2823 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2828 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2830 lvalue
.expr_type
= EXPR_VARIABLE
;
2831 lvalue
.ts
= sym
->ts
;
2833 lvalue
.rank
= sym
->as
->rank
;
2834 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2835 lvalue
.symtree
->n
.sym
= sym
;
2836 lvalue
.where
= sym
->declared_at
;
2838 if (sym
->attr
.pointer
)
2839 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2841 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2843 gfc_free (lvalue
.symtree
);
2849 /* Get an expression for a default initializer. */
2852 gfc_default_initializer (gfc_typespec
*ts
)
2854 gfc_constructor
*tail
;
2860 /* See if we have a default initializer. */
2861 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2863 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2864 init
= gfc_get_expr ();
2870 /* Build the constructor. */
2871 init
->expr_type
= EXPR_STRUCTURE
;
2873 init
->where
= ts
->derived
->declared_at
;
2875 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2878 init
->value
.constructor
= tail
= gfc_get_constructor ();
2881 tail
->next
= gfc_get_constructor ();
2886 tail
->expr
= gfc_copy_expr (c
->initializer
);
2890 tail
->expr
= gfc_get_expr ();
2891 tail
->expr
->expr_type
= EXPR_NULL
;
2892 tail
->expr
->ts
= c
->ts
;
2899 /* Given a symbol, create an expression node with that symbol as a
2900 variable. If the symbol is array valued, setup a reference of the
2904 gfc_get_variable_expr (gfc_symtree
*var
)
2908 e
= gfc_get_expr ();
2909 e
->expr_type
= EXPR_VARIABLE
;
2911 e
->ts
= var
->n
.sym
->ts
;
2913 if (var
->n
.sym
->as
!= NULL
)
2915 e
->rank
= var
->n
.sym
->as
->rank
;
2916 e
->ref
= gfc_get_ref ();
2917 e
->ref
->type
= REF_ARRAY
;
2918 e
->ref
->u
.ar
.type
= AR_FULL
;
2925 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2928 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2930 gfc_actual_arglist
*arg
;
2937 switch (expr
->expr_type
)
2940 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2941 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2945 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2946 gfc_expr_set_symbols_referenced (arg
->expr
);
2950 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2955 case EXPR_SUBSTRING
:
2958 case EXPR_STRUCTURE
:
2960 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2961 gfc_expr_set_symbols_referenced (c
->expr
);
2969 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2973 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2975 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2976 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2977 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2985 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2986 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);