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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 /* Get a new expr node. */
35 e
= gfc_getmem (sizeof (gfc_expr
));
36 gfc_clear_ts (&e
->ts
);
40 e
->con_by_offset
= NULL
;
45 /* Free an argument list and everything below it. */
48 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
50 gfc_actual_arglist
*a2
;
55 gfc_free_expr (a1
->expr
);
62 /* Copy an arglist structure and all of the arguments. */
65 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
67 gfc_actual_arglist
*head
, *tail
, *new;
71 for (; p
; p
= p
->next
)
73 new = gfc_get_actual_arglist ();
76 new->expr
= gfc_copy_expr (p
->expr
);
91 /* Free a list of reference structures. */
94 gfc_free_ref_list (gfc_ref
*p
)
106 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
108 gfc_free_expr (p
->u
.ar
.start
[i
]);
109 gfc_free_expr (p
->u
.ar
.end
[i
]);
110 gfc_free_expr (p
->u
.ar
.stride
[i
]);
116 gfc_free_expr (p
->u
.ss
.start
);
117 gfc_free_expr (p
->u
.ss
.end
);
129 /* Workhorse function for gfc_free_expr() that frees everything
130 beneath an expression node, but not the node itself. This is
131 useful when we want to simplify a node and replace it with
132 something else or the expression node belongs to another structure. */
135 free_expr0 (gfc_expr
*e
)
139 switch (e
->expr_type
)
142 /* Free any parts of the value that need freeing. */
146 mpz_clear (e
->value
.integer
);
150 mpfr_clear (e
->value
.real
);
154 gfc_free (e
->value
.character
.string
);
158 mpfr_clear (e
->value
.complex.r
);
159 mpfr_clear (e
->value
.complex.i
);
166 /* Free the representation, except in character constants where it
167 is the same as value.character.string and thus already freed. */
168 if (e
->representation
.string
&& e
->ts
.type
!= BT_CHARACTER
)
169 gfc_free (e
->representation
.string
);
174 if (e
->value
.op
.op1
!= NULL
)
175 gfc_free_expr (e
->value
.op
.op1
);
176 if (e
->value
.op
.op2
!= NULL
)
177 gfc_free_expr (e
->value
.op
.op2
);
181 gfc_free_actual_arglist (e
->value
.function
.actual
);
189 gfc_free_constructor (e
->value
.constructor
);
193 gfc_free (e
->value
.character
.string
);
200 gfc_internal_error ("free_expr0(): Bad expr type");
203 /* Free a shape array. */
204 if (e
->shape
!= NULL
)
206 for (n
= 0; n
< e
->rank
; n
++)
207 mpz_clear (e
->shape
[n
]);
212 gfc_free_ref_list (e
->ref
);
214 memset (e
, '\0', sizeof (gfc_expr
));
218 /* Free an expression node and everything beneath it. */
221 gfc_free_expr (gfc_expr
*e
)
225 if (e
->con_by_offset
)
226 splay_tree_delete (e
->con_by_offset
);
232 /* Graft the *src expression onto the *dest subexpression. */
235 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
243 /* Try to extract an integer constant from the passed expression node.
244 Returns an error message or NULL if the result is set. It is
245 tempting to generate an error and return SUCCESS or FAILURE, but
246 failure is OK for some callers. */
249 gfc_extract_int (gfc_expr
*expr
, int *result
)
251 if (expr
->expr_type
!= EXPR_CONSTANT
)
252 return _("Constant expression required at %C");
254 if (expr
->ts
.type
!= BT_INTEGER
)
255 return _("Integer expression required at %C");
257 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
258 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
260 return _("Integer value too large in expression at %C");
263 *result
= (int) mpz_get_si (expr
->value
.integer
);
269 /* Recursively copy a list of reference structures. */
272 copy_ref (gfc_ref
*src
)
280 dest
= gfc_get_ref ();
281 dest
->type
= src
->type
;
286 ar
= gfc_copy_array_ref (&src
->u
.ar
);
292 dest
->u
.c
= src
->u
.c
;
296 dest
->u
.ss
= src
->u
.ss
;
297 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
298 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
302 dest
->next
= copy_ref (src
->next
);
308 /* Detect whether an expression has any vector index array references. */
311 gfc_has_vector_index (gfc_expr
*e
)
315 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
316 if (ref
->type
== REF_ARRAY
)
317 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
318 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
324 /* Copy a shape array. */
327 gfc_copy_shape (mpz_t
*shape
, int rank
)
335 new_shape
= gfc_get_shape (rank
);
337 for (n
= 0; n
< rank
; n
++)
338 mpz_init_set (new_shape
[n
], shape
[n
]);
344 /* Copy a shape array excluding dimension N, where N is an integer
345 constant expression. Dimensions are numbered in fortran style --
348 So, if the original shape array contains R elements
349 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
350 the result contains R-1 elements:
351 { s1 ... sN-1 sN+1 ... sR-1}
353 If anything goes wrong -- N is not a constant, its value is out
354 of range -- or anything else, just returns NULL. */
357 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
359 mpz_t
*new_shape
, *s
;
365 || dim
->expr_type
!= EXPR_CONSTANT
366 || dim
->ts
.type
!= BT_INTEGER
)
369 n
= mpz_get_si (dim
->value
.integer
);
370 n
--; /* Convert to zero based index. */
371 if (n
< 0 || n
>= rank
)
374 s
= new_shape
= gfc_get_shape (rank
- 1);
376 for (i
= 0; i
< rank
; i
++)
380 mpz_init_set (*s
, shape
[i
]);
388 /* Given an expression pointer, return a copy of the expression. This
389 subroutine is recursive. */
392 gfc_copy_expr (gfc_expr
*p
)
403 switch (q
->expr_type
)
406 s
= gfc_getmem (p
->value
.character
.length
+ 1);
407 q
->value
.character
.string
= s
;
409 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
413 /* Copy target representation, if it exists. */
414 if (p
->representation
.string
)
416 s
= gfc_getmem (p
->representation
.length
+ 1);
417 q
->representation
.string
= s
;
419 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
422 /* Copy the values of any pointer components of p->value. */
426 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
430 gfc_set_model_kind (q
->ts
.kind
);
431 mpfr_init (q
->value
.real
);
432 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
436 gfc_set_model_kind (q
->ts
.kind
);
437 mpfr_init (q
->value
.complex.r
);
438 mpfr_init (q
->value
.complex.i
);
439 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
440 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
444 if (p
->representation
.string
)
445 q
->value
.character
.string
= q
->representation
.string
;
448 s
= gfc_getmem (p
->value
.character
.length
+ 1);
449 q
->value
.character
.string
= s
;
451 /* This is the case for the C_NULL_CHAR named constant. */
452 if (p
->value
.character
.length
== 0
453 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
456 /* Need to set the length to 1 to make sure the NUL
457 terminator is copied. */
458 q
->value
.character
.length
= 1;
461 memcpy (s
, p
->value
.character
.string
,
462 p
->value
.character
.length
+ 1);
469 break; /* Already done. */
473 /* Should never be reached. */
475 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
482 switch (q
->value
.op
.operator)
485 case INTRINSIC_PARENTHESES
:
486 case INTRINSIC_UPLUS
:
487 case INTRINSIC_UMINUS
:
488 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
491 default: /* Binary operators. */
492 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
493 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
500 q
->value
.function
.actual
=
501 gfc_copy_actual_arglist (p
->value
.function
.actual
);
506 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
514 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
516 q
->ref
= copy_ref (p
->ref
);
522 /* Return the maximum kind of two expressions. In general, higher
523 kind numbers mean more precision for numeric types. */
526 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
528 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
532 /* Returns nonzero if the type is numeric, zero otherwise. */
535 numeric_type (bt type
)
537 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
541 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
544 gfc_numeric_ts (gfc_typespec
*ts
)
546 return numeric_type (ts
->type
);
550 /* Returns an expression node that is an integer constant. */
559 p
->expr_type
= EXPR_CONSTANT
;
560 p
->ts
.type
= BT_INTEGER
;
561 p
->ts
.kind
= gfc_default_integer_kind
;
563 p
->where
= gfc_current_locus
;
564 mpz_init_set_si (p
->value
.integer
, i
);
570 /* Returns an expression node that is a logical constant. */
573 gfc_logical_expr (int i
, locus
*where
)
579 p
->expr_type
= EXPR_CONSTANT
;
580 p
->ts
.type
= BT_LOGICAL
;
581 p
->ts
.kind
= gfc_default_logical_kind
;
584 where
= &gfc_current_locus
;
586 p
->value
.logical
= i
;
592 /* Return an expression node with an optional argument list attached.
593 A variable number of gfc_expr pointers are strung together in an
594 argument list with a NULL pointer terminating the list. */
597 gfc_build_conversion (gfc_expr
*e
)
602 p
->expr_type
= EXPR_FUNCTION
;
604 p
->value
.function
.actual
= NULL
;
606 p
->value
.function
.actual
= gfc_get_actual_arglist ();
607 p
->value
.function
.actual
->expr
= e
;
613 /* Given an expression node with some sort of numeric binary
614 expression, insert type conversions required to make the operands
617 The exception is that the operands of an exponential don't have to
618 have the same type. If possible, the base is promoted to the type
619 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
620 1.0**2 stays as it is. */
623 gfc_type_convert_binary (gfc_expr
*e
)
627 op1
= e
->value
.op
.op1
;
628 op2
= e
->value
.op
.op2
;
630 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
632 gfc_clear_ts (&e
->ts
);
636 /* Kind conversions of same type. */
637 if (op1
->ts
.type
== op2
->ts
.type
)
639 if (op1
->ts
.kind
== op2
->ts
.kind
)
641 /* No type conversions. */
646 if (op1
->ts
.kind
> op2
->ts
.kind
)
647 gfc_convert_type (op2
, &op1
->ts
, 2);
649 gfc_convert_type (op1
, &op2
->ts
, 2);
655 /* Integer combined with real or complex. */
656 if (op2
->ts
.type
== BT_INTEGER
)
660 /* Special case for ** operator. */
661 if (e
->value
.op
.operator == INTRINSIC_POWER
)
664 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
668 if (op1
->ts
.type
== BT_INTEGER
)
671 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
675 /* Real combined with complex. */
676 e
->ts
.type
= BT_COMPLEX
;
677 if (op1
->ts
.kind
> op2
->ts
.kind
)
678 e
->ts
.kind
= op1
->ts
.kind
;
680 e
->ts
.kind
= op2
->ts
.kind
;
681 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
682 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
683 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
684 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
692 check_specification_function (gfc_expr
*e
)
699 sym
= e
->symtree
->n
.sym
;
701 /* F95, 7.1.6.2; F2003, 7.1.7 */
703 && sym
->attr
.function
705 && !sym
->attr
.intrinsic
706 && !sym
->attr
.recursive
707 && sym
->attr
.proc
!= PROC_INTERNAL
708 && sym
->attr
.proc
!= PROC_ST_FUNCTION
709 && sym
->attr
.proc
!= PROC_UNKNOWN
710 && sym
->formal
== NULL
)
716 /* Function to determine if an expression is constant or not. This
717 function expects that the expression has already been simplified. */
720 gfc_is_constant_expr (gfc_expr
*e
)
723 gfc_actual_arglist
*arg
;
729 switch (e
->expr_type
)
732 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
733 && (e
->value
.op
.op2
== NULL
734 || gfc_is_constant_expr (e
->value
.op
.op2
)));
742 /* Specification functions are constant. */
743 if (check_specification_function (e
) == MATCH_YES
)
749 /* Call to intrinsic with at least one argument. */
751 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
753 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
755 if (!gfc_is_constant_expr (arg
->expr
))
769 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
770 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
775 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
776 if (!gfc_is_constant_expr (c
->expr
))
784 rv
= gfc_constant_ac (e
);
788 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
795 /* Is true if an array reference is followed by a component or substring
798 is_subref_array (gfc_expr
* e
)
803 if (e
->expr_type
!= EXPR_VARIABLE
)
806 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
810 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
812 if (ref
->type
== REF_ARRAY
813 && ref
->u
.ar
.type
!= AR_ELEMENT
)
817 && ref
->type
!= REF_ARRAY
)
824 /* Try to collapse intrinsic expressions. */
827 simplify_intrinsic_op (gfc_expr
*p
, int type
)
830 gfc_expr
*op1
, *op2
, *result
;
832 if (p
->value
.op
.operator == INTRINSIC_USER
)
835 op1
= p
->value
.op
.op1
;
836 op2
= p
->value
.op
.op2
;
837 op
= p
->value
.op
.operator;
839 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
841 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
844 if (!gfc_is_constant_expr (op1
)
845 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
849 p
->value
.op
.op1
= NULL
;
850 p
->value
.op
.op2
= NULL
;
854 case INTRINSIC_PARENTHESES
:
855 result
= gfc_parentheses (op1
);
858 case INTRINSIC_UPLUS
:
859 result
= gfc_uplus (op1
);
862 case INTRINSIC_UMINUS
:
863 result
= gfc_uminus (op1
);
867 result
= gfc_add (op1
, op2
);
870 case INTRINSIC_MINUS
:
871 result
= gfc_subtract (op1
, op2
);
874 case INTRINSIC_TIMES
:
875 result
= gfc_multiply (op1
, op2
);
878 case INTRINSIC_DIVIDE
:
879 result
= gfc_divide (op1
, op2
);
882 case INTRINSIC_POWER
:
883 result
= gfc_power (op1
, op2
);
886 case INTRINSIC_CONCAT
:
887 result
= gfc_concat (op1
, op2
);
891 case INTRINSIC_EQ_OS
:
892 result
= gfc_eq (op1
, op2
, op
);
896 case INTRINSIC_NE_OS
:
897 result
= gfc_ne (op1
, op2
, op
);
901 case INTRINSIC_GT_OS
:
902 result
= gfc_gt (op1
, op2
, op
);
906 case INTRINSIC_GE_OS
:
907 result
= gfc_ge (op1
, op2
, op
);
911 case INTRINSIC_LT_OS
:
912 result
= gfc_lt (op1
, op2
, op
);
916 case INTRINSIC_LE_OS
:
917 result
= gfc_le (op1
, op2
, op
);
921 result
= gfc_not (op1
);
925 result
= gfc_and (op1
, op2
);
929 result
= gfc_or (op1
, op2
);
933 result
= gfc_eqv (op1
, op2
);
937 result
= gfc_neqv (op1
, op2
);
941 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
951 result
->rank
= p
->rank
;
952 result
->where
= p
->where
;
953 gfc_replace_expr (p
, result
);
959 /* Subroutine to simplify constructor expressions. Mutually recursive
960 with gfc_simplify_expr(). */
963 simplify_constructor (gfc_constructor
*c
, int type
)
965 for (; c
; c
= c
->next
)
968 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
969 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
970 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
973 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
981 /* Pull a single array element out of an array constructor. */
984 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
985 gfc_constructor
**rval
)
987 unsigned long nelemen
;
999 mpz_init_set_ui (offset
, 0);
1002 mpz_init_set_ui (span
, 1);
1003 for (i
= 0; i
< ar
->dimen
; i
++)
1005 e
= gfc_copy_expr (ar
->start
[i
]);
1006 if (e
->expr_type
!= EXPR_CONSTANT
)
1012 /* Check the bounds. */
1013 if (ar
->as
->upper
[i
]
1014 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
1015 || mpz_cmp (e
->value
.integer
,
1016 ar
->as
->lower
[i
]->value
.integer
) < 0))
1018 gfc_error ("index in dimension %d is out of bounds "
1019 "at %L", i
+ 1, &ar
->c_where
[i
]);
1025 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1026 mpz_mul (delta
, delta
, span
);
1027 mpz_add (offset
, offset
, delta
);
1029 mpz_set_ui (tmp
, 1);
1030 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1031 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1032 mpz_mul (span
, span
, tmp
);
1037 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1060 /* Find a component of a structure constructor. */
1062 static gfc_constructor
*
1063 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1065 gfc_component
*comp
;
1066 gfc_component
*pick
;
1068 comp
= ref
->u
.c
.sym
->components
;
1069 pick
= ref
->u
.c
.component
;
1070 while (comp
!= pick
)
1080 /* Replace an expression with the contents of a constructor, removing
1081 the subobject reference in the process. */
1084 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1090 e
->ref
= p
->ref
->next
;
1091 p
->ref
->next
= NULL
;
1092 gfc_replace_expr (p
, e
);
1096 /* Pull an array section out of an array constructor. */
1099 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1105 long unsigned one
= 1;
1107 mpz_t start
[GFC_MAX_DIMENSIONS
];
1108 mpz_t end
[GFC_MAX_DIMENSIONS
];
1109 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1110 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1111 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1117 gfc_constructor
*cons
;
1118 gfc_constructor
*base
;
1124 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1129 base
= expr
->value
.constructor
;
1130 expr
->value
.constructor
= NULL
;
1132 rank
= ref
->u
.ar
.as
->rank
;
1134 if (expr
->shape
== NULL
)
1135 expr
->shape
= gfc_get_shape (rank
);
1137 mpz_init_set_ui (delta_mpz
, one
);
1138 mpz_init_set_ui (nelts
, one
);
1141 /* Do the initialization now, so that we can cleanup without
1142 keeping track of where we were. */
1143 for (d
= 0; d
< rank
; d
++)
1145 mpz_init (delta
[d
]);
1146 mpz_init (start
[d
]);
1149 mpz_init (stride
[d
]);
1153 /* Build the counters to clock through the array reference. */
1155 for (d
= 0; d
< rank
; d
++)
1157 /* Make this stretch of code easier on the eye! */
1158 begin
= ref
->u
.ar
.start
[d
];
1159 finish
= ref
->u
.ar
.end
[d
];
1160 step
= ref
->u
.ar
.stride
[d
];
1161 lower
= ref
->u
.ar
.as
->lower
[d
];
1162 upper
= ref
->u
.ar
.as
->upper
[d
];
1164 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1168 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1174 gcc_assert (begin
->rank
== 1);
1175 gcc_assert (begin
->shape
);
1177 vecsub
[d
] = begin
->value
.constructor
;
1178 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1179 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1180 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1183 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1185 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1186 || mpz_cmp (c
->expr
->value
.integer
,
1187 lower
->value
.integer
) < 0)
1189 gfc_error ("index in dimension %d is out of bounds "
1190 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1198 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1199 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1200 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1206 /* Obtain the stride. */
1208 mpz_set (stride
[d
], step
->value
.integer
);
1210 mpz_set_ui (stride
[d
], one
);
1212 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1213 mpz_set_ui (stride
[d
], one
);
1215 /* Obtain the start value for the index. */
1217 mpz_set (start
[d
], begin
->value
.integer
);
1219 mpz_set (start
[d
], lower
->value
.integer
);
1221 mpz_set (ctr
[d
], start
[d
]);
1223 /* Obtain the end value for the index. */
1225 mpz_set (end
[d
], finish
->value
.integer
);
1227 mpz_set (end
[d
], upper
->value
.integer
);
1229 /* Separate 'if' because elements sometimes arrive with
1231 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1232 mpz_set (end
[d
], begin
->value
.integer
);
1234 /* Check the bounds. */
1235 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1236 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1237 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1238 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1240 gfc_error ("index in dimension %d is out of bounds "
1241 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1246 /* Calculate the number of elements and the shape. */
1247 mpz_set (tmp_mpz
, stride
[d
]);
1248 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1249 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1250 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1251 mpz_mul (nelts
, nelts
, tmp_mpz
);
1253 /* An element reference reduces the rank of the expression; don't
1254 add anything to the shape array. */
1255 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1256 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1259 /* Calculate the 'stride' (=delta) for conversion of the
1260 counter values into the index along the constructor. */
1261 mpz_set (delta
[d
], delta_mpz
);
1262 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1263 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1264 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1271 /* Now clock through the array reference, calculating the index in
1272 the source constructor and transferring the elements to the new
1274 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1276 if (ref
->u
.ar
.offset
)
1277 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1279 mpz_init_set_ui (ptr
, 0);
1282 for (d
= 0; d
< rank
; d
++)
1284 mpz_set (tmp_mpz
, ctr
[d
]);
1285 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1286 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1287 mpz_add (ptr
, ptr
, tmp_mpz
);
1289 if (!incr_ctr
) continue;
1291 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1293 gcc_assert(vecsub
[d
]);
1295 if (!vecsub
[d
]->next
)
1296 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1299 vecsub
[d
] = vecsub
[d
]->next
;
1302 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1306 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1308 if (mpz_cmp_ui (stride
[d
], 0) > 0
1309 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1310 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1311 mpz_set (ctr
[d
], start
[d
]);
1317 /* There must be a better way of dealing with negative strides
1318 than resetting the index and the constructor pointer! */
1319 if (mpz_cmp (ptr
, index
) < 0)
1321 mpz_set_ui (index
, 0);
1325 while (mpz_cmp (ptr
, index
) > 0)
1327 mpz_add_ui (index
, index
, one
);
1331 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1339 mpz_clear (delta_mpz
);
1340 mpz_clear (tmp_mpz
);
1342 for (d
= 0; d
< rank
; d
++)
1344 mpz_clear (delta
[d
]);
1345 mpz_clear (start
[d
]);
1348 mpz_clear (stride
[d
]);
1350 gfc_free_constructor (base
);
1354 /* Pull a substring out of an expression. */
1357 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1364 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1365 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1368 *newp
= gfc_copy_expr (p
);
1369 gfc_free ((*newp
)->value
.character
.string
);
1371 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1372 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1373 length
= end
- start
+ 1;
1375 chr
= (*newp
)->value
.character
.string
= gfc_getmem (length
+ 1);
1376 (*newp
)->value
.character
.length
= length
;
1377 memcpy (chr
, &p
->value
.character
.string
[start
- 1], length
);
1384 /* Simplify a subobject reference of a constructor. This occurs when
1385 parameter variable values are substituted. */
1388 simplify_const_ref (gfc_expr
*p
)
1390 gfc_constructor
*cons
;
1395 switch (p
->ref
->type
)
1398 switch (p
->ref
->u
.ar
.type
)
1401 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1408 remove_subobject_ref (p
, cons
);
1412 if (find_array_section (p
, p
->ref
) == FAILURE
)
1414 p
->ref
->u
.ar
.type
= AR_FULL
;
1419 if (p
->ref
->next
!= NULL
1420 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1422 cons
= p
->value
.constructor
;
1423 for (; cons
; cons
= cons
->next
)
1425 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1426 simplify_const_ref (cons
->expr
);
1429 gfc_free_ref_list (p
->ref
);
1440 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1441 remove_subobject_ref (p
, cons
);
1445 if (find_substring_ref (p
, &newp
) == FAILURE
)
1448 gfc_replace_expr (p
, newp
);
1449 gfc_free_ref_list (p
->ref
);
1459 /* Simplify a chain of references. */
1462 simplify_ref_chain (gfc_ref
*ref
, int type
)
1466 for (; ref
; ref
= ref
->next
)
1471 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1473 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1475 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1477 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1483 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1485 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1497 /* Try to substitute the value of a parameter variable. */
1500 simplify_parameter_variable (gfc_expr
*p
, int type
)
1505 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1511 /* Do not copy subobject refs for constant. */
1512 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1513 e
->ref
= copy_ref (p
->ref
);
1514 t
= gfc_simplify_expr (e
, type
);
1516 /* Only use the simplification if it eliminated all subobject references. */
1517 if (t
== SUCCESS
&& !e
->ref
)
1518 gfc_replace_expr (p
, e
);
1525 /* Given an expression, simplify it by collapsing constant
1526 expressions. Most simplification takes place when the expression
1527 tree is being constructed. If an intrinsic function is simplified
1528 at some point, we get called again to collapse the result against
1531 We work by recursively simplifying expression nodes, simplifying
1532 intrinsic functions where possible, which can lead to further
1533 constant collapsing. If an operator has constant operand(s), we
1534 rip the expression apart, and rebuild it, hoping that it becomes
1537 The expression type is defined for:
1538 0 Basic expression parsing
1539 1 Simplifying array constructors -- will substitute
1541 Returns FAILURE on error, SUCCESS otherwise.
1542 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1545 gfc_simplify_expr (gfc_expr
*p
, int type
)
1547 gfc_actual_arglist
*ap
;
1552 switch (p
->expr_type
)
1559 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1560 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1563 if (p
->value
.function
.isym
!= NULL
1564 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1569 case EXPR_SUBSTRING
:
1570 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1573 if (gfc_is_constant_expr (p
))
1578 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1580 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1581 start
--; /* Convert from one-based to zero-based. */
1586 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1587 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1589 end
= p
->value
.character
.length
;
1591 s
= gfc_getmem (end
- start
+ 2);
1592 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1593 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1594 gfc_free (p
->value
.character
.string
);
1595 p
->value
.character
.string
= s
;
1596 p
->value
.character
.length
= end
- start
;
1597 p
->ts
.cl
= gfc_get_charlen ();
1598 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1599 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1600 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1601 gfc_free_ref_list (p
->ref
);
1603 p
->expr_type
= EXPR_CONSTANT
;
1608 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1613 /* Only substitute array parameter variables if we are in an
1614 initialization expression, or we want a subsection. */
1615 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1616 && (gfc_init_expr
|| p
->ref
1617 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1619 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1626 gfc_simplify_iterator_var (p
);
1629 /* Simplify subcomponent references. */
1630 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1635 case EXPR_STRUCTURE
:
1637 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1640 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1643 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1644 && p
->ref
->u
.ar
.type
== AR_FULL
)
1645 gfc_expand_constructor (p
);
1647 if (simplify_const_ref (p
) == FAILURE
)
1657 /* Returns the type of an expression with the exception that iterator
1658 variables are automatically integers no matter what else they may
1664 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1671 /* Check an intrinsic arithmetic operation to see if it is consistent
1672 with some type of expression. */
1674 static try check_init_expr (gfc_expr
*);
1677 /* Scalarize an expression for an elemental intrinsic call. */
1680 scalarize_intrinsic_call (gfc_expr
*e
)
1682 gfc_actual_arglist
*a
, *b
;
1683 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1684 gfc_expr
*expr
, *old
;
1687 old
= gfc_copy_expr (e
);
1689 /* Assume that the old expression carries the type information and
1690 that the first arg carries all the shape information. */
1691 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1692 gfc_free_constructor (expr
->value
.constructor
);
1693 expr
->value
.constructor
= NULL
;
1696 expr
->expr_type
= EXPR_ARRAY
;
1698 /* Copy the array argument constructors into an array, with nulls
1701 a
= old
->value
.function
.actual
;
1702 for (; a
; a
= a
->next
)
1704 /* Check that this is OK for an initialization expression. */
1705 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1709 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1711 rank
[n
] = a
->expr
->rank
;
1712 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1713 args
[n
] = gfc_copy_constructor (ctor
);
1715 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1718 rank
[n
] = a
->expr
->rank
;
1721 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1728 for (i
= 1; i
< n
; i
++)
1729 if (rank
[i
] && rank
[i
] != rank
[0])
1732 /* Using the first argument as the master, step through the array
1733 calling the function for each element and advancing the array
1734 constructors together. */
1737 for (; ctor
; ctor
= ctor
->next
)
1739 if (expr
->value
.constructor
== NULL
)
1740 expr
->value
.constructor
1741 = new_ctor
= gfc_get_constructor ();
1744 new_ctor
->next
= gfc_get_constructor ();
1745 new_ctor
= new_ctor
->next
;
1747 new_ctor
->expr
= gfc_copy_expr (old
);
1748 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1750 b
= old
->value
.function
.actual
;
1751 for (i
= 0; i
< n
; i
++)
1754 new_ctor
->expr
->value
.function
.actual
1755 = a
= gfc_get_actual_arglist ();
1758 a
->next
= gfc_get_actual_arglist ();
1762 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1764 a
->expr
= gfc_copy_expr (b
->expr
);
1769 /* Simplify the function calls. */
1770 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1773 for (i
= 0; i
< n
; i
++)
1775 args
[i
] = args
[i
]->next
;
1777 for (i
= 1; i
< n
; i
++)
1778 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1779 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1785 gfc_free_expr (old
);
1789 gfc_error_now ("elemental function arguments at %C are not compliant");
1792 gfc_free_expr (expr
);
1793 gfc_free_expr (old
);
1799 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1801 gfc_expr
*op1
= e
->value
.op
.op1
;
1802 gfc_expr
*op2
= e
->value
.op
.op2
;
1804 if ((*check_function
) (op1
) == FAILURE
)
1807 switch (e
->value
.op
.operator)
1809 case INTRINSIC_UPLUS
:
1810 case INTRINSIC_UMINUS
:
1811 if (!numeric_type (et0 (op1
)))
1816 case INTRINSIC_EQ_OS
:
1818 case INTRINSIC_NE_OS
:
1820 case INTRINSIC_GT_OS
:
1822 case INTRINSIC_GE_OS
:
1824 case INTRINSIC_LT_OS
:
1826 case INTRINSIC_LE_OS
:
1827 if ((*check_function
) (op2
) == FAILURE
)
1830 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1831 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1833 gfc_error ("Numeric or CHARACTER operands are required in "
1834 "expression at %L", &e
->where
);
1839 case INTRINSIC_PLUS
:
1840 case INTRINSIC_MINUS
:
1841 case INTRINSIC_TIMES
:
1842 case INTRINSIC_DIVIDE
:
1843 case INTRINSIC_POWER
:
1844 if ((*check_function
) (op2
) == FAILURE
)
1847 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1850 if (e
->value
.op
.operator == INTRINSIC_POWER
1851 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1853 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1854 "exponent in an initialization "
1855 "expression at %L", &op2
->where
)
1862 case INTRINSIC_CONCAT
:
1863 if ((*check_function
) (op2
) == FAILURE
)
1866 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1868 gfc_error ("Concatenation operator in expression at %L "
1869 "must have two CHARACTER operands", &op1
->where
);
1873 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1875 gfc_error ("Concat operator at %L must concatenate strings of the "
1876 "same kind", &e
->where
);
1883 if (et0 (op1
) != BT_LOGICAL
)
1885 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1886 "operand", &op1
->where
);
1895 case INTRINSIC_NEQV
:
1896 if ((*check_function
) (op2
) == FAILURE
)
1899 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1901 gfc_error ("LOGICAL operands are required in expression at %L",
1908 case INTRINSIC_PARENTHESES
:
1912 gfc_error ("Only intrinsic operators can be used in expression at %L",
1920 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1927 check_init_expr_arguments (gfc_expr
*e
)
1929 gfc_actual_arglist
*ap
;
1931 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1932 if (check_init_expr (ap
->expr
) == FAILURE
)
1938 /* F95, 7.1.6.1, Initialization expressions, (7)
1939 F2003, 7.1.7 Initialization expression, (8) */
1942 check_inquiry (gfc_expr
*e
, int not_restricted
)
1945 const char *const *functions
;
1947 static const char *const inquiry_func_f95
[] = {
1948 "lbound", "shape", "size", "ubound",
1949 "bit_size", "len", "kind",
1950 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1951 "precision", "radix", "range", "tiny",
1955 static const char *const inquiry_func_f2003
[] = {
1956 "lbound", "shape", "size", "ubound",
1957 "bit_size", "len", "kind",
1958 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1959 "precision", "radix", "range", "tiny",
1964 gfc_actual_arglist
*ap
;
1966 if (!e
->value
.function
.isym
1967 || !e
->value
.function
.isym
->inquiry
)
1970 /* An undeclared parameter will get us here (PR25018). */
1971 if (e
->symtree
== NULL
)
1974 name
= e
->symtree
->n
.sym
->name
;
1976 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1977 ? inquiry_func_f2003
: inquiry_func_f95
;
1979 for (i
= 0; functions
[i
]; i
++)
1980 if (strcmp (functions
[i
], name
) == 0)
1983 if (functions
[i
] == NULL
)
1986 /* At this point we have an inquiry function with a variable argument. The
1987 type of the variable might be undefined, but we need it now, because the
1988 arguments of these functions are not allowed to be undefined. */
1990 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1995 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
1997 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1998 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2002 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2005 /* Assumed character length will not reduce to a constant expression
2006 with LEN, as required by the standard. */
2007 if (i
== 5 && not_restricted
2008 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2009 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2011 gfc_error ("Assumed character length variable '%s' in constant "
2012 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2015 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2023 /* F95, 7.1.6.1, Initialization expressions, (5)
2024 F2003, 7.1.7 Initialization expression, (5) */
2027 check_transformational (gfc_expr
*e
)
2029 static const char * const trans_func_f95
[] = {
2030 "repeat", "reshape", "selected_int_kind",
2031 "selected_real_kind", "transfer", "trim", NULL
2037 if (!e
->value
.function
.isym
2038 || !e
->value
.function
.isym
->transformational
)
2041 name
= e
->symtree
->n
.sym
->name
;
2043 /* NULL() is dealt with below. */
2044 if (strcmp ("null", name
) == 0)
2047 for (i
= 0; trans_func_f95
[i
]; i
++)
2048 if (strcmp (trans_func_f95
[i
], name
) == 0)
2051 /* FIXME, F2003: implement translation of initialization
2052 expressions before enabling this check. For F95, error
2053 out if the transformational function is not in the list. */
2055 if (trans_func_f95
[i
] == NULL
2056 && gfc_notify_std (GFC_STD_F2003
,
2057 "transformational intrinsic '%s' at %L is not permitted "
2058 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2061 if (trans_func_f95
[i
] == NULL
)
2063 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2064 "in an initialization expression", name
, &e
->where
);
2069 return check_init_expr_arguments (e
);
2073 /* F95, 7.1.6.1, Initialization expressions, (6)
2074 F2003, 7.1.7 Initialization expression, (6) */
2077 check_null (gfc_expr
*e
)
2079 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2082 return check_init_expr_arguments (e
);
2087 check_elemental (gfc_expr
*e
)
2089 if (!e
->value
.function
.isym
2090 || !e
->value
.function
.isym
->elemental
)
2093 if ((e
->ts
.type
!= BT_INTEGER
|| e
->ts
.type
!= BT_CHARACTER
)
2094 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2095 "nonstandard initialization expression at %L",
2096 &e
->where
) == FAILURE
)
2099 return check_init_expr_arguments (e
);
2104 check_conversion (gfc_expr
*e
)
2106 if (!e
->value
.function
.isym
2107 || !e
->value
.function
.isym
->conversion
)
2110 return check_init_expr_arguments (e
);
2114 /* Verify that an expression is an initialization expression. A side
2115 effect is that the expression tree is reduced to a single constant
2116 node if all goes well. This would normally happen when the
2117 expression is constructed but function references are assumed to be
2118 intrinsics in the context of initialization expressions. If
2119 FAILURE is returned an error message has been generated. */
2122 check_init_expr (gfc_expr
*e
)
2126 gfc_intrinsic_sym
*isym
;
2131 switch (e
->expr_type
)
2134 t
= check_intrinsic_op (e
, check_init_expr
);
2136 t
= gfc_simplify_expr (e
, 0);
2143 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2145 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2147 gfc_error ("Function '%s' in initialization expression at %L "
2148 "must be an intrinsic or a specification function",
2149 e
->symtree
->n
.sym
->name
, &e
->where
);
2153 if ((m
= check_conversion (e
)) == MATCH_NO
2154 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2155 && (m
= check_null (e
)) == MATCH_NO
2156 && (m
= check_transformational (e
)) == MATCH_NO
2157 && (m
= check_elemental (e
)) == MATCH_NO
)
2159 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2160 "in an initialization expression",
2161 e
->symtree
->n
.sym
->name
, &e
->where
);
2165 /* Try to scalarize an elemental intrinsic function that has an
2167 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2168 if (isym
&& isym
->elemental
2169 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2171 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2177 t
= gfc_simplify_expr (e
, 0);
2184 if (gfc_check_iter_variable (e
) == SUCCESS
)
2187 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2189 t
= simplify_parameter_variable (e
, 0);
2193 if (gfc_in_match_data ())
2198 if (e
->symtree
->n
.sym
->as
)
2200 switch (e
->symtree
->n
.sym
->as
->type
)
2202 case AS_ASSUMED_SIZE
:
2203 gfc_error ("Assumed size array '%s' at %L is not permitted "
2204 "in an initialization expression",
2205 e
->symtree
->n
.sym
->name
, &e
->where
);
2208 case AS_ASSUMED_SHAPE
:
2209 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2210 "in an initialization expression",
2211 e
->symtree
->n
.sym
->name
, &e
->where
);
2215 gfc_error ("Deferred array '%s' at %L is not permitted "
2216 "in an initialization expression",
2217 e
->symtree
->n
.sym
->name
, &e
->where
);
2225 gfc_error ("Parameter '%s' at %L has not been declared or is "
2226 "a variable, which does not reduce to a constant "
2227 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2236 case EXPR_SUBSTRING
:
2237 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2241 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2243 t
= gfc_simplify_expr (e
, 0);
2247 case EXPR_STRUCTURE
:
2251 t
= gfc_check_constructor (e
, check_init_expr
);
2255 t
= gfc_check_constructor (e
, check_init_expr
);
2259 t
= gfc_expand_constructor (e
);
2263 t
= gfc_check_constructor_type (e
);
2267 gfc_internal_error ("check_init_expr(): Unknown expression type");
2274 /* Match an initialization expression. We work by first matching an
2275 expression, then reducing it to a constant. */
2278 gfc_match_init_expr (gfc_expr
**result
)
2284 m
= gfc_match_expr (&expr
);
2289 t
= gfc_resolve_expr (expr
);
2291 t
= check_init_expr (expr
);
2296 gfc_free_expr (expr
);
2300 if (expr
->expr_type
== EXPR_ARRAY
2301 && (gfc_check_constructor_type (expr
) == FAILURE
2302 || gfc_expand_constructor (expr
) == FAILURE
))
2304 gfc_free_expr (expr
);
2308 /* Not all inquiry functions are simplified to constant expressions
2309 so it is necessary to call check_inquiry again. */
2310 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2311 && !gfc_in_match_data ())
2313 gfc_error ("Initialization expression didn't reduce %C");
2323 static try check_restricted (gfc_expr
*);
2325 /* Given an actual argument list, test to see that each argument is a
2326 restricted expression and optionally if the expression type is
2327 integer or character. */
2330 restricted_args (gfc_actual_arglist
*a
)
2332 for (; a
; a
= a
->next
)
2334 if (check_restricted (a
->expr
) == FAILURE
)
2342 /************* Restricted/specification expressions *************/
2345 /* Make sure a non-intrinsic function is a specification function. */
2348 external_spec_function (gfc_expr
*e
)
2352 f
= e
->value
.function
.esym
;
2354 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2356 gfc_error ("Specification function '%s' at %L cannot be a statement "
2357 "function", f
->name
, &e
->where
);
2361 if (f
->attr
.proc
== PROC_INTERNAL
)
2363 gfc_error ("Specification function '%s' at %L cannot be an internal "
2364 "function", f
->name
, &e
->where
);
2368 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2370 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2375 if (f
->attr
.recursive
)
2377 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2378 f
->name
, &e
->where
);
2382 return restricted_args (e
->value
.function
.actual
);
2386 /* Check to see that a function reference to an intrinsic is a
2387 restricted expression. */
2390 restricted_intrinsic (gfc_expr
*e
)
2392 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2393 if (check_inquiry (e
, 0) == MATCH_YES
)
2396 return restricted_args (e
->value
.function
.actual
);
2400 /* Verify that an expression is a restricted expression. Like its
2401 cousin check_init_expr(), an error message is generated if we
2405 check_restricted (gfc_expr
*e
)
2413 switch (e
->expr_type
)
2416 t
= check_intrinsic_op (e
, check_restricted
);
2418 t
= gfc_simplify_expr (e
, 0);
2423 t
= e
->value
.function
.esym
? external_spec_function (e
)
2424 : restricted_intrinsic (e
);
2428 sym
= e
->symtree
->n
.sym
;
2431 /* If a dummy argument appears in a context that is valid for a
2432 restricted expression in an elemental procedure, it will have
2433 already been simplified away once we get here. Therefore we
2434 don't need to jump through hoops to distinguish valid from
2436 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2437 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2439 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2440 sym
->name
, &e
->where
);
2444 if (sym
->attr
.optional
)
2446 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2447 sym
->name
, &e
->where
);
2451 if (sym
->attr
.intent
== INTENT_OUT
)
2453 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2454 sym
->name
, &e
->where
);
2458 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2459 processed in resolve.c(resolve_formal_arglist). This is done so
2460 that host associated dummy array indices are accepted (PR23446).
2461 This mechanism also does the same for the specification expressions
2462 of array-valued functions. */
2463 if (sym
->attr
.in_common
2464 || sym
->attr
.use_assoc
2466 || sym
->ns
!= gfc_current_ns
2467 || (sym
->ns
->proc_name
!= NULL
2468 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2469 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2475 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2476 sym
->name
, &e
->where
);
2485 case EXPR_SUBSTRING
:
2486 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2490 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2492 t
= gfc_simplify_expr (e
, 0);
2496 case EXPR_STRUCTURE
:
2497 t
= gfc_check_constructor (e
, check_restricted
);
2501 t
= gfc_check_constructor (e
, check_restricted
);
2505 gfc_internal_error ("check_restricted(): Unknown expression type");
2512 /* Check to see that an expression is a specification expression. If
2513 we return FAILURE, an error has been generated. */
2516 gfc_specification_expr (gfc_expr
*e
)
2522 if (e
->ts
.type
!= BT_INTEGER
)
2524 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2528 if (e
->expr_type
== EXPR_FUNCTION
2529 && !e
->value
.function
.isym
2530 && !e
->value
.function
.esym
2531 && !gfc_pure (e
->symtree
->n
.sym
))
2533 gfc_error ("Function '%s' at %L must be PURE",
2534 e
->symtree
->n
.sym
->name
, &e
->where
);
2535 /* Prevent repeat error messages. */
2536 e
->symtree
->n
.sym
->attr
.pure
= 1;
2542 gfc_error ("Expression at %L must be scalar", &e
->where
);
2546 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2549 return check_restricted (e
);
2553 /************** Expression conformance checks. *************/
2555 /* Given two expressions, make sure that the arrays are conformable. */
2558 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2560 int op1_flag
, op2_flag
, d
;
2561 mpz_t op1_size
, op2_size
;
2564 if (op1
->rank
== 0 || op2
->rank
== 0)
2567 if (op1
->rank
!= op2
->rank
)
2569 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2570 op1
->rank
, op2
->rank
, &op1
->where
);
2576 for (d
= 0; d
< op1
->rank
; d
++)
2578 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2579 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2581 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2583 gfc_error ("Different shape for %s at %L on dimension %d "
2584 "(%d and %d)", _(optype_msgid
), &op1
->where
, d
+ 1,
2585 (int) mpz_get_si (op1_size
),
2586 (int) mpz_get_si (op2_size
));
2592 mpz_clear (op1_size
);
2594 mpz_clear (op2_size
);
2604 /* Given an assignable expression and an arbitrary expression, make
2605 sure that the assignment can take place. */
2608 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2614 sym
= lvalue
->symtree
->n
.sym
;
2616 /* Check INTENT(IN), unless the object itself is the component or
2617 sub-component of a pointer. */
2618 has_pointer
= sym
->attr
.pointer
;
2620 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2621 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2627 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2629 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2630 sym
->name
, &lvalue
->where
);
2634 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2635 variable local to a function subprogram. Its existence begins when
2636 execution of the function is initiated and ends when execution of the
2637 function is terminated...
2638 Therefore, the left hand side is no longer a variable, when it is: */
2639 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2640 && !sym
->attr
.external
)
2645 /* (i) Use associated; */
2646 if (sym
->attr
.use_assoc
)
2649 /* (ii) The assignment is in the main program; or */
2650 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2653 /* (iii) A module or internal procedure... */
2654 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2655 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2656 && gfc_current_ns
->parent
2657 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2658 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2659 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2661 /* ... that is not a function... */
2662 if (!gfc_current_ns
->proc_name
->attr
.function
)
2665 /* ... or is not an entry and has a different name. */
2666 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2672 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2677 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2679 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2680 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2684 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2686 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2691 if (rvalue
->expr_type
== EXPR_NULL
)
2693 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2694 && lvalue
->symtree
->n
.sym
->attr
.data
)
2698 gfc_error ("NULL appears on right-hand side in assignment at %L",
2704 if (sym
->attr
.cray_pointee
2705 && lvalue
->ref
!= NULL
2706 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2707 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2709 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2710 "is illegal", &lvalue
->where
);
2714 /* This is possibly a typo: x = f() instead of x => f(). */
2715 if (gfc_option
.warn_surprising
2716 && rvalue
->expr_type
== EXPR_FUNCTION
2717 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2718 gfc_warning ("POINTER valued function appears on right-hand side of "
2719 "assignment at %L", &rvalue
->where
);
2721 /* Check size of array assignments. */
2722 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2723 && gfc_check_conformance ("array assignment", lvalue
, rvalue
) != SUCCESS
)
2726 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2731 /* Numeric can be converted to any other numeric. And Hollerith can be
2732 converted to any other type. */
2733 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2734 || rvalue
->ts
.type
== BT_HOLLERITH
)
2737 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2740 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2741 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2742 gfc_typename (&lvalue
->ts
));
2747 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2751 /* Check that a pointer assignment is OK. We first check lvalue, and
2752 we only check rvalue if it's not an assignment to NULL() or a
2753 NULLIFY statement. */
2756 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2758 symbol_attribute attr
;
2761 int pointer
, check_intent_in
;
2763 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2765 gfc_error ("Pointer assignment target is not a POINTER at %L",
2770 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2771 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2773 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2774 "l-value since it is a procedure",
2775 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2780 /* Check INTENT(IN), unless the object itself is the component or
2781 sub-component of a pointer. */
2782 check_intent_in
= 1;
2783 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2785 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2788 check_intent_in
= 0;
2790 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2794 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2796 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2797 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2803 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2807 is_pure
= gfc_pure (NULL
);
2809 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
2810 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
2812 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2816 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2817 kind, etc for lvalue and rvalue must match, and rvalue must be a
2818 pure variable if we're in a pure function. */
2819 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2822 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2824 gfc_error ("Different types in pointer assignment at %L",
2829 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2831 gfc_error ("Different kind type parameters in pointer "
2832 "assignment at %L", &lvalue
->where
);
2836 if (lvalue
->rank
!= rvalue
->rank
)
2838 gfc_error ("Different ranks in pointer assignment at %L",
2843 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2844 if (rvalue
->expr_type
== EXPR_NULL
)
2847 if (lvalue
->ts
.type
== BT_CHARACTER
2848 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2849 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2850 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2851 rvalue
->ts
.cl
->length
)) == 1)
2853 gfc_error ("Different character lengths in pointer "
2854 "assignment at %L", &lvalue
->where
);
2858 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
2859 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
2861 attr
= gfc_expr_attr (rvalue
);
2862 if (!attr
.target
&& !attr
.pointer
)
2864 gfc_error ("Pointer assignment target is neither TARGET "
2865 "nor POINTER at %L", &rvalue
->where
);
2869 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2871 gfc_error ("Bad target in pointer assignment in PURE "
2872 "procedure at %L", &rvalue
->where
);
2875 if (gfc_has_vector_index (rvalue
))
2877 gfc_error ("Pointer assignment with vector subscript "
2878 "on rhs at %L", &rvalue
->where
);
2882 if (attr
.protected && attr
.use_assoc
)
2884 gfc_error ("Pointer assigment target has PROTECTED "
2885 "attribute at %L", &rvalue
->where
);
2893 /* Relative of gfc_check_assign() except that the lvalue is a single
2894 symbol. Used for initialization assignments. */
2897 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2902 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2904 lvalue
.expr_type
= EXPR_VARIABLE
;
2905 lvalue
.ts
= sym
->ts
;
2907 lvalue
.rank
= sym
->as
->rank
;
2908 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2909 lvalue
.symtree
->n
.sym
= sym
;
2910 lvalue
.where
= sym
->declared_at
;
2912 if (sym
->attr
.pointer
)
2913 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2915 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2917 gfc_free (lvalue
.symtree
);
2923 /* Get an expression for a default initializer. */
2926 gfc_default_initializer (gfc_typespec
*ts
)
2928 gfc_constructor
*tail
;
2932 /* See if we have a default initializer. */
2933 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2934 if (c
->initializer
|| c
->allocatable
)
2940 /* Build the constructor. */
2941 init
= gfc_get_expr ();
2942 init
->expr_type
= EXPR_STRUCTURE
;
2944 init
->where
= ts
->derived
->declared_at
;
2947 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2950 init
->value
.constructor
= tail
= gfc_get_constructor ();
2953 tail
->next
= gfc_get_constructor ();
2958 tail
->expr
= gfc_copy_expr (c
->initializer
);
2962 tail
->expr
= gfc_get_expr ();
2963 tail
->expr
->expr_type
= EXPR_NULL
;
2964 tail
->expr
->ts
= c
->ts
;
2971 /* Given a symbol, create an expression node with that symbol as a
2972 variable. If the symbol is array valued, setup a reference of the
2976 gfc_get_variable_expr (gfc_symtree
*var
)
2980 e
= gfc_get_expr ();
2981 e
->expr_type
= EXPR_VARIABLE
;
2983 e
->ts
= var
->n
.sym
->ts
;
2985 if (var
->n
.sym
->as
!= NULL
)
2987 e
->rank
= var
->n
.sym
->as
->rank
;
2988 e
->ref
= gfc_get_ref ();
2989 e
->ref
->type
= REF_ARRAY
;
2990 e
->ref
->u
.ar
.type
= AR_FULL
;
2997 /* General expression traversal function. */
3000 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3001 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3006 gfc_actual_arglist
*args
;
3013 if ((*func
) (expr
, sym
, &f
))
3016 if (expr
->ts
.type
== BT_CHARACTER
3018 && expr
->ts
.cl
->length
3019 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3020 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3023 switch (expr
->expr_type
)
3026 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3028 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3036 case EXPR_SUBSTRING
:
3039 case EXPR_STRUCTURE
:
3041 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3043 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3047 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3049 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3051 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3053 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3060 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3062 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3078 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3080 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3082 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3084 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3090 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3092 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3097 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3098 && ref
->u
.c
.component
->ts
.cl
3099 && ref
->u
.c
.component
->ts
.cl
->length
3100 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3102 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3106 if (ref
->u
.c
.component
->as
)
3107 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3109 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3112 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3126 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3129 expr_set_symbols_referenced (gfc_expr
*expr
,
3130 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3131 int *f ATTRIBUTE_UNUSED
)
3133 if (expr
->expr_type
!= EXPR_VARIABLE
)
3135 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3140 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3142 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);