1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
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
));
38 gfc_clear_ts (&e
->ts
);
47 /* Free an argument list and everything below it. */
50 gfc_free_actual_arglist (gfc_actual_arglist
* a1
)
52 gfc_actual_arglist
*a2
;
57 gfc_free_expr (a1
->expr
);
64 /* Copy an arglist structure and all of the arguments. */
67 gfc_copy_actual_arglist (gfc_actual_arglist
* p
)
69 gfc_actual_arglist
*head
, *tail
, *new;
73 for (; p
; p
= p
->next
)
75 new = gfc_get_actual_arglist ();
78 new->expr
= gfc_copy_expr (p
->expr
);
93 /* Free a list of reference structures. */
96 gfc_free_ref_list (gfc_ref
* p
)
108 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
110 gfc_free_expr (p
->u
.ar
.start
[i
]);
111 gfc_free_expr (p
->u
.ar
.end
[i
]);
112 gfc_free_expr (p
->u
.ar
.stride
[i
]);
118 gfc_free_expr (p
->u
.ss
.start
);
119 gfc_free_expr (p
->u
.ss
.end
);
131 /* Workhorse function for gfc_free_expr() that frees everything
132 beneath an expression node, but not the node itself. This is
133 useful when we want to simplify a node and replace it with
134 something else or the expression node belongs to another structure. */
137 free_expr0 (gfc_expr
* e
)
141 switch (e
->expr_type
)
146 gfc_free (e
->value
.character
.string
);
153 mpz_clear (e
->value
.integer
);
157 mpfr_clear (e
->value
.real
);
162 gfc_free (e
->value
.character
.string
);
166 mpfr_clear (e
->value
.complex.r
);
167 mpfr_clear (e
->value
.complex.i
);
177 if (e
->value
.op
.op1
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op1
);
179 if (e
->value
.op
.op2
!= NULL
)
180 gfc_free_expr (e
->value
.op
.op2
);
184 gfc_free_actual_arglist (e
->value
.function
.actual
);
192 gfc_free_constructor (e
->value
.constructor
);
196 gfc_free (e
->value
.character
.string
);
203 gfc_internal_error ("free_expr0(): Bad expr type");
206 /* Free a shape array. */
207 if (e
->shape
!= NULL
)
209 for (n
= 0; n
< e
->rank
; n
++)
210 mpz_clear (e
->shape
[n
]);
215 gfc_free_ref_list (e
->ref
);
217 memset (e
, '\0', sizeof (gfc_expr
));
221 /* Free an expression node and everything beneath it. */
224 gfc_free_expr (gfc_expr
* e
)
235 /* Graft the *src expression onto the *dest subexpression. */
238 gfc_replace_expr (gfc_expr
* dest
, gfc_expr
* src
)
248 /* Try to extract an integer constant from the passed expression node.
249 Returns an error message or NULL if the result is set. It is
250 tempting to generate an error and return SUCCESS or FAILURE, but
251 failure is OK for some callers. */
254 gfc_extract_int (gfc_expr
* expr
, int *result
)
257 if (expr
->expr_type
!= EXPR_CONSTANT
)
258 return _("Constant expression required at %C");
260 if (expr
->ts
.type
!= BT_INTEGER
)
261 return _("Integer expression required at %C");
263 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
264 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
266 return _("Integer value too large in expression at %C");
269 *result
= (int) mpz_get_si (expr
->value
.integer
);
275 /* Recursively copy a list of reference structures. */
278 copy_ref (gfc_ref
* src
)
286 dest
= gfc_get_ref ();
287 dest
->type
= src
->type
;
292 ar
= gfc_copy_array_ref (&src
->u
.ar
);
298 dest
->u
.c
= src
->u
.c
;
302 dest
->u
.ss
= src
->u
.ss
;
303 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
304 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
308 dest
->next
= copy_ref (src
->next
);
314 /* Detect whether an expression has any vector index array
318 gfc_has_vector_index (gfc_expr
*e
)
322 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
323 if (ref
->type
== REF_ARRAY
)
324 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
325 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
331 /* Copy a shape array. */
334 gfc_copy_shape (mpz_t
* shape
, int rank
)
342 new_shape
= gfc_get_shape (rank
);
344 for (n
= 0; n
< rank
; n
++)
345 mpz_init_set (new_shape
[n
], shape
[n
]);
351 /* Copy a shape array excluding dimension N, where N is an integer
352 constant expression. Dimensions are numbered in fortran style --
355 So, if the original shape array contains R elements
356 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
357 the result contains R-1 elements:
358 { s1 ... sN-1 sN+1 ... sR-1}
360 If anything goes wrong -- N is not a constant, its value is out
361 of range -- or anything else, just returns NULL.
365 gfc_copy_shape_excluding (mpz_t
* shape
, int rank
, gfc_expr
* dim
)
367 mpz_t
*new_shape
, *s
;
373 || dim
->expr_type
!= EXPR_CONSTANT
374 || dim
->ts
.type
!= BT_INTEGER
)
377 n
= mpz_get_si (dim
->value
.integer
);
378 n
--; /* Convert to zero based index */
379 if (n
< 0 || n
>= rank
)
382 s
= new_shape
= gfc_get_shape (rank
-1);
384 for (i
= 0; i
< rank
; i
++)
388 mpz_init_set (*s
, shape
[i
]);
395 /* Given an expression pointer, return a copy of the expression. This
396 subroutine is recursive. */
399 gfc_copy_expr (gfc_expr
* p
)
410 switch (q
->expr_type
)
413 s
= gfc_getmem (p
->value
.character
.length
+ 1);
414 q
->value
.character
.string
= s
;
416 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
422 s
= gfc_getmem (p
->value
.character
.length
+ 1);
423 q
->value
.character
.string
= s
;
425 memcpy (s
, p
->value
.character
.string
,
426 p
->value
.character
.length
+ 1);
432 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
436 gfc_set_model_kind (q
->ts
.kind
);
437 mpfr_init (q
->value
.real
);
438 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
442 gfc_set_model_kind (q
->ts
.kind
);
443 mpfr_init (q
->value
.complex.r
);
444 mpfr_init (q
->value
.complex.i
);
445 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
446 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
451 s
= gfc_getmem (p
->value
.character
.length
+ 1);
452 q
->value
.character
.string
= s
;
454 memcpy (s
, p
->value
.character
.string
,
455 p
->value
.character
.length
+ 1);
460 break; /* Already done */
464 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
471 switch (q
->value
.op
.operator)
474 case INTRINSIC_UPLUS
:
475 case INTRINSIC_UMINUS
:
476 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
479 default: /* Binary operators */
480 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
481 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
488 q
->value
.function
.actual
=
489 gfc_copy_actual_arglist (p
->value
.function
.actual
);
494 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
502 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
504 q
->ref
= copy_ref (p
->ref
);
510 /* Return the maximum kind of two expressions. In general, higher
511 kind numbers mean more precision for numeric types. */
514 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
517 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
521 /* Returns nonzero if the type is numeric, zero otherwise. */
524 numeric_type (bt type
)
527 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
531 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
534 gfc_numeric_ts (gfc_typespec
* ts
)
537 return numeric_type (ts
->type
);
541 /* Returns an expression node that is an integer constant. */
550 p
->expr_type
= EXPR_CONSTANT
;
551 p
->ts
.type
= BT_INTEGER
;
552 p
->ts
.kind
= gfc_default_integer_kind
;
554 p
->where
= gfc_current_locus
;
555 mpz_init_set_si (p
->value
.integer
, i
);
561 /* Returns an expression node that is a logical constant. */
564 gfc_logical_expr (int i
, locus
* where
)
570 p
->expr_type
= EXPR_CONSTANT
;
571 p
->ts
.type
= BT_LOGICAL
;
572 p
->ts
.kind
= gfc_default_logical_kind
;
575 where
= &gfc_current_locus
;
577 p
->value
.logical
= i
;
583 /* Return an expression node with an optional argument list attached.
584 A variable number of gfc_expr pointers are strung together in an
585 argument list with a NULL pointer terminating the list. */
588 gfc_build_conversion (gfc_expr
* e
)
593 p
->expr_type
= EXPR_FUNCTION
;
595 p
->value
.function
.actual
= NULL
;
597 p
->value
.function
.actual
= gfc_get_actual_arglist ();
598 p
->value
.function
.actual
->expr
= e
;
604 /* Given an expression node with some sort of numeric binary
605 expression, insert type conversions required to make the operands
608 The exception is that the operands of an exponential don't have to
609 have the same type. If possible, the base is promoted to the type
610 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
611 1.0**2 stays as it is. */
614 gfc_type_convert_binary (gfc_expr
* e
)
618 op1
= e
->value
.op
.op1
;
619 op2
= e
->value
.op
.op2
;
621 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
623 gfc_clear_ts (&e
->ts
);
627 /* Kind conversions of same type. */
628 if (op1
->ts
.type
== op2
->ts
.type
)
631 if (op1
->ts
.kind
== op2
->ts
.kind
)
633 /* No type conversions. */
638 if (op1
->ts
.kind
> op2
->ts
.kind
)
639 gfc_convert_type (op2
, &op1
->ts
, 2);
641 gfc_convert_type (op1
, &op2
->ts
, 2);
647 /* Integer combined with real or complex. */
648 if (op2
->ts
.type
== BT_INTEGER
)
652 /* Special case for ** operator. */
653 if (e
->value
.op
.operator == INTRINSIC_POWER
)
656 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
660 if (op1
->ts
.type
== BT_INTEGER
)
663 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
667 /* Real combined with complex. */
668 e
->ts
.type
= BT_COMPLEX
;
669 if (op1
->ts
.kind
> op2
->ts
.kind
)
670 e
->ts
.kind
= op1
->ts
.kind
;
672 e
->ts
.kind
= op2
->ts
.kind
;
673 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
674 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
675 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
676 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
683 /* Function to determine if an expression is constant or not. This
684 function expects that the expression has already been simplified. */
687 gfc_is_constant_expr (gfc_expr
* e
)
690 gfc_actual_arglist
*arg
;
696 switch (e
->expr_type
)
699 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
700 && (e
->value
.op
.op2
== NULL
701 || gfc_is_constant_expr (e
->value
.op
.op2
)));
710 /* Call to intrinsic with at least one argument. */
712 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
714 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
716 if (!gfc_is_constant_expr (arg
->expr
))
730 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
731 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
736 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
737 if (!gfc_is_constant_expr (c
->expr
))
745 rv
= gfc_constant_ac (e
);
749 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
756 /* Try to collapse intrinsic expressions. */
759 simplify_intrinsic_op (gfc_expr
* p
, int type
)
761 gfc_expr
*op1
, *op2
, *result
;
763 if (p
->value
.op
.operator == INTRINSIC_USER
)
766 op1
= p
->value
.op
.op1
;
767 op2
= p
->value
.op
.op2
;
769 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
771 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
774 if (!gfc_is_constant_expr (op1
)
775 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
779 p
->value
.op
.op1
= NULL
;
780 p
->value
.op
.op2
= NULL
;
782 switch (p
->value
.op
.operator)
784 case INTRINSIC_UPLUS
:
785 case INTRINSIC_PARENTHESES
:
786 result
= gfc_uplus (op1
);
789 case INTRINSIC_UMINUS
:
790 result
= gfc_uminus (op1
);
794 result
= gfc_add (op1
, op2
);
797 case INTRINSIC_MINUS
:
798 result
= gfc_subtract (op1
, op2
);
801 case INTRINSIC_TIMES
:
802 result
= gfc_multiply (op1
, op2
);
805 case INTRINSIC_DIVIDE
:
806 result
= gfc_divide (op1
, op2
);
809 case INTRINSIC_POWER
:
810 result
= gfc_power (op1
, op2
);
813 case INTRINSIC_CONCAT
:
814 result
= gfc_concat (op1
, op2
);
818 result
= gfc_eq (op1
, op2
);
822 result
= gfc_ne (op1
, op2
);
826 result
= gfc_gt (op1
, op2
);
830 result
= gfc_ge (op1
, op2
);
834 result
= gfc_lt (op1
, op2
);
838 result
= gfc_le (op1
, op2
);
842 result
= gfc_not (op1
);
846 result
= gfc_and (op1
, op2
);
850 result
= gfc_or (op1
, op2
);
854 result
= gfc_eqv (op1
, op2
);
858 result
= gfc_neqv (op1
, op2
);
862 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
872 result
->rank
= p
->rank
;
873 result
->where
= p
->where
;
874 gfc_replace_expr (p
, result
);
880 /* Subroutine to simplify constructor expressions. Mutually recursive
881 with gfc_simplify_expr(). */
884 simplify_constructor (gfc_constructor
* c
, int type
)
887 for (; c
; c
= c
->next
)
890 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
891 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
892 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
895 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
903 /* Pull a single array element out of an array constructor. */
905 static gfc_constructor
*
906 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
)
908 unsigned long nelemen
;
913 mpz_init_set_ui (offset
, 0);
915 for (i
= 0; i
< ar
->dimen
; i
++)
917 if (ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
)
922 mpz_sub (delta
, ar
->start
[i
]->value
.integer
,
923 ar
->as
->lower
[i
]->value
.integer
);
924 mpz_add (offset
, offset
, delta
);
929 if (mpz_fits_ulong_p (offset
))
931 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
952 /* Find a component of a structure constructor. */
954 static gfc_constructor
*
955 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
960 comp
= ref
->u
.c
.sym
->components
;
961 pick
= ref
->u
.c
.component
;
972 /* Replace an expression with the contents of a constructor, removing
973 the subobject reference in the process. */
976 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
982 e
->ref
= p
->ref
->next
;
984 gfc_replace_expr (p
, e
);
988 /* Simplify a subobject reference of a constructor. This occurs when
989 parameter variable values are substituted. */
992 simplify_const_ref (gfc_expr
* p
)
994 gfc_constructor
*cons
;
998 switch (p
->ref
->type
)
1001 switch (p
->ref
->u
.ar
.type
)
1004 cons
= find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
);
1007 remove_subobject_ref (p
, cons
);
1011 if (p
->ref
->next
!= NULL
)
1013 /* TODO: Simplify array subobject references. */
1016 gfc_free_ref_list (p
->ref
);
1021 /* TODO: Simplify array subsections. */
1028 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1029 remove_subobject_ref (p
, cons
);
1033 /* TODO: Constant substrings. */
1042 /* Simplify a chain of references. */
1045 simplify_ref_chain (gfc_ref
* ref
, int type
)
1049 for (; ref
; ref
= ref
->next
)
1054 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1056 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1059 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1062 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1069 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1071 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1083 /* Try to substitute the value of a parameter variable. */
1085 simplify_parameter_variable (gfc_expr
* p
, int type
)
1090 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1091 /* Do not copy subobject refs for constant. */
1092 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1093 e
->ref
= copy_ref (p
->ref
);
1094 t
= gfc_simplify_expr (e
, type
);
1096 /* Only use the simplification if it eliminated all subobject
1098 if (t
== SUCCESS
&& ! e
->ref
)
1099 gfc_replace_expr (p
, e
);
1106 /* Given an expression, simplify it by collapsing constant
1107 expressions. Most simplification takes place when the expression
1108 tree is being constructed. If an intrinsic function is simplified
1109 at some point, we get called again to collapse the result against
1112 We work by recursively simplifying expression nodes, simplifying
1113 intrinsic functions where possible, which can lead to further
1114 constant collapsing. If an operator has constant operand(s), we
1115 rip the expression apart, and rebuild it, hoping that it becomes
1118 The expression type is defined for:
1119 0 Basic expression parsing
1120 1 Simplifying array constructors -- will substitute
1122 Returns FAILURE on error, SUCCESS otherwise.
1123 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1126 gfc_simplify_expr (gfc_expr
* p
, int type
)
1128 gfc_actual_arglist
*ap
;
1133 switch (p
->expr_type
)
1140 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1141 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1144 if (p
->value
.function
.isym
!= NULL
1145 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1150 case EXPR_SUBSTRING
:
1151 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1154 if (gfc_is_constant_expr (p
))
1159 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1160 start
--; /* Convert from one-based to zero-based. */
1161 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1162 s
= gfc_getmem (end
- start
+ 1);
1163 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1164 s
[end
] = '\0'; /* TODO: C-style string for debugging. */
1165 gfc_free (p
->value
.character
.string
);
1166 p
->value
.character
.string
= s
;
1167 p
->value
.character
.length
= end
- start
;
1168 p
->ts
.cl
= gfc_get_charlen ();
1169 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1170 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1171 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1172 gfc_free_ref_list (p
->ref
);
1174 p
->expr_type
= EXPR_CONSTANT
;
1179 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1184 /* Only substitute array parameter variables if we are in an
1185 initialization expression, or we want a subsection. */
1186 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1187 && (gfc_init_expr
|| p
->ref
1188 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1190 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1197 gfc_simplify_iterator_var (p
);
1200 /* Simplify subcomponent references. */
1201 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1206 case EXPR_STRUCTURE
:
1208 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1211 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1214 if (p
->expr_type
== EXPR_ARRAY
)
1215 gfc_expand_constructor (p
);
1217 if (simplify_const_ref (p
) == FAILURE
)
1227 /* Returns the type of an expression with the exception that iterator
1228 variables are automatically integers no matter what else they may
1235 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1242 /* Check an intrinsic arithmetic operation to see if it is consistent
1243 with some type of expression. */
1245 static try check_init_expr (gfc_expr
*);
1248 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1250 gfc_expr
*op1
= e
->value
.op
.op1
;
1251 gfc_expr
*op2
= e
->value
.op
.op2
;
1253 if ((*check_function
) (op1
) == FAILURE
)
1256 switch (e
->value
.op
.operator)
1258 case INTRINSIC_UPLUS
:
1259 case INTRINSIC_UMINUS
:
1260 if (!numeric_type (et0 (op1
)))
1270 if ((*check_function
) (op2
) == FAILURE
)
1273 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1274 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1276 gfc_error ("Numeric or CHARACTER operands are required in "
1277 "expression at %L", &e
->where
);
1282 case INTRINSIC_PLUS
:
1283 case INTRINSIC_MINUS
:
1284 case INTRINSIC_TIMES
:
1285 case INTRINSIC_DIVIDE
:
1286 case INTRINSIC_POWER
:
1287 if ((*check_function
) (op2
) == FAILURE
)
1290 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1293 if (e
->value
.op
.operator == INTRINSIC_POWER
1294 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1296 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1297 "expression", &op2
->where
);
1303 case INTRINSIC_CONCAT
:
1304 if ((*check_function
) (op2
) == FAILURE
)
1307 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1309 gfc_error ("Concatenation operator in expression at %L "
1310 "must have two CHARACTER operands", &op1
->where
);
1314 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1316 gfc_error ("Concat operator at %L must concatenate strings of the "
1317 "same kind", &e
->where
);
1324 if (et0 (op1
) != BT_LOGICAL
)
1326 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1327 "operand", &op1
->where
);
1336 case INTRINSIC_NEQV
:
1337 if ((*check_function
) (op2
) == FAILURE
)
1340 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1342 gfc_error ("LOGICAL operands are required in expression at %L",
1349 case INTRINSIC_PARENTHESES
:
1353 gfc_error ("Only intrinsic operators can be used in expression at %L",
1361 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1368 /* Certain inquiry functions are specifically allowed to have variable
1369 arguments, which is an exception to the normal requirement that an
1370 initialization function have initialization arguments. We head off
1371 this problem here. */
1374 check_inquiry (gfc_expr
* e
, int not_restricted
)
1378 /* FIXME: This should be moved into the intrinsic definitions,
1379 to eliminate this ugly hack. */
1380 static const char * const inquiry_function
[] = {
1381 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1382 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1383 "lbound", "ubound", NULL
1388 /* An undeclared parameter will get us here (PR25018). */
1389 if (e
->symtree
== NULL
)
1392 name
= e
->symtree
->n
.sym
->name
;
1394 for (i
= 0; inquiry_function
[i
]; i
++)
1395 if (strcmp (inquiry_function
[i
], name
) == 0)
1398 if (inquiry_function
[i
] == NULL
)
1401 e
= e
->value
.function
.actual
->expr
;
1403 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1406 /* At this point we have an inquiry function with a variable argument. The
1407 type of the variable might be undefined, but we need it now, because the
1408 arguments of these functions are allowed to be undefined. */
1410 if (e
->ts
.type
== BT_UNKNOWN
)
1412 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1413 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1417 e
->ts
= e
->symtree
->n
.sym
->ts
;
1420 /* Assumed character length will not reduce to a constant expression
1421 with LEN, as required by the standard. */
1422 if (i
== 4 && not_restricted
1423 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1424 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1425 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1426 "variable '%s' in constant expression at %L",
1427 e
->symtree
->n
.sym
->name
, &e
->where
);
1433 /* Verify that an expression is an initialization expression. A side
1434 effect is that the expression tree is reduced to a single constant
1435 node if all goes well. This would normally happen when the
1436 expression is constructed but function references are assumed to be
1437 intrinsics in the context of initialization expressions. If
1438 FAILURE is returned an error message has been generated. */
1441 check_init_expr (gfc_expr
* e
)
1443 gfc_actual_arglist
*ap
;
1450 switch (e
->expr_type
)
1453 t
= check_intrinsic_op (e
, check_init_expr
);
1455 t
= gfc_simplify_expr (e
, 0);
1462 if (check_inquiry (e
, 1) != SUCCESS
)
1465 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1466 if (check_init_expr (ap
->expr
) == FAILURE
)
1475 m
= gfc_intrinsic_func_interface (e
, 0);
1478 gfc_error ("Function '%s' in initialization expression at %L "
1479 "must be an intrinsic function",
1480 e
->symtree
->n
.sym
->name
, &e
->where
);
1491 if (gfc_check_iter_variable (e
) == SUCCESS
)
1494 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1496 t
= simplify_parameter_variable (e
, 0);
1500 gfc_error ("Parameter '%s' at %L has not been declared or is "
1501 "a variable, which does not reduce to a constant "
1502 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1511 case EXPR_SUBSTRING
:
1512 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1516 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1518 t
= gfc_simplify_expr (e
, 0);
1522 case EXPR_STRUCTURE
:
1523 t
= gfc_check_constructor (e
, check_init_expr
);
1527 t
= gfc_check_constructor (e
, check_init_expr
);
1531 t
= gfc_expand_constructor (e
);
1535 t
= gfc_check_constructor_type (e
);
1539 gfc_internal_error ("check_init_expr(): Unknown expression type");
1546 /* Match an initialization expression. We work by first matching an
1547 expression, then reducing it to a constant. */
1550 gfc_match_init_expr (gfc_expr
** result
)
1556 m
= gfc_match_expr (&expr
);
1561 t
= gfc_resolve_expr (expr
);
1563 t
= check_init_expr (expr
);
1568 gfc_free_expr (expr
);
1572 if (expr
->expr_type
== EXPR_ARRAY
1573 && (gfc_check_constructor_type (expr
) == FAILURE
1574 || gfc_expand_constructor (expr
) == FAILURE
))
1576 gfc_free_expr (expr
);
1580 /* Not all inquiry functions are simplified to constant expressions
1581 so it is necessary to call check_inquiry again. */
1582 if (!gfc_is_constant_expr (expr
)
1583 && check_inquiry (expr
, 1) == FAILURE
)
1585 gfc_error ("Initialization expression didn't reduce %C");
1596 static try check_restricted (gfc_expr
*);
1598 /* Given an actual argument list, test to see that each argument is a
1599 restricted expression and optionally if the expression type is
1600 integer or character. */
1603 restricted_args (gfc_actual_arglist
* a
)
1605 for (; a
; a
= a
->next
)
1607 if (check_restricted (a
->expr
) == FAILURE
)
1615 /************* Restricted/specification expressions *************/
1618 /* Make sure a non-intrinsic function is a specification function. */
1621 external_spec_function (gfc_expr
* e
)
1625 f
= e
->value
.function
.esym
;
1627 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1629 gfc_error ("Specification function '%s' at %L cannot be a statement "
1630 "function", f
->name
, &e
->where
);
1634 if (f
->attr
.proc
== PROC_INTERNAL
)
1636 gfc_error ("Specification function '%s' at %L cannot be an internal "
1637 "function", f
->name
, &e
->where
);
1641 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
1643 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1648 if (f
->attr
.recursive
)
1650 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1651 f
->name
, &e
->where
);
1655 return restricted_args (e
->value
.function
.actual
);
1659 /* Check to see that a function reference to an intrinsic is a
1660 restricted expression. */
1663 restricted_intrinsic (gfc_expr
* e
)
1665 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1666 if (check_inquiry (e
, 0) == SUCCESS
)
1669 return restricted_args (e
->value
.function
.actual
);
1673 /* Verify that an expression is a restricted expression. Like its
1674 cousin check_init_expr(), an error message is generated if we
1678 check_restricted (gfc_expr
* e
)
1686 switch (e
->expr_type
)
1689 t
= check_intrinsic_op (e
, check_restricted
);
1691 t
= gfc_simplify_expr (e
, 0);
1696 t
= e
->value
.function
.esym
?
1697 external_spec_function (e
) : restricted_intrinsic (e
);
1702 sym
= e
->symtree
->n
.sym
;
1705 if (sym
->attr
.optional
)
1707 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1708 sym
->name
, &e
->where
);
1712 if (sym
->attr
.intent
== INTENT_OUT
)
1714 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1715 sym
->name
, &e
->where
);
1719 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1720 in resolve.c(resolve_formal_arglist). This is done so that host associated
1721 dummy array indices are accepted (PR23446). */
1722 if (sym
->attr
.in_common
1723 || sym
->attr
.use_assoc
1725 || sym
->ns
!= gfc_current_ns
1726 || (sym
->ns
->proc_name
!= NULL
1727 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1728 || gfc_is_formal_arg ())
1734 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1735 sym
->name
, &e
->where
);
1744 case EXPR_SUBSTRING
:
1745 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
1749 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
1751 t
= gfc_simplify_expr (e
, 0);
1755 case EXPR_STRUCTURE
:
1756 t
= gfc_check_constructor (e
, check_restricted
);
1760 t
= gfc_check_constructor (e
, check_restricted
);
1764 gfc_internal_error ("check_restricted(): Unknown expression type");
1771 /* Check to see that an expression is a specification expression. If
1772 we return FAILURE, an error has been generated. */
1775 gfc_specification_expr (gfc_expr
* e
)
1780 if (e
->ts
.type
!= BT_INTEGER
)
1782 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
1788 gfc_error ("Expression at %L must be scalar", &e
->where
);
1792 if (gfc_simplify_expr (e
, 0) == FAILURE
)
1795 return check_restricted (e
);
1799 /************** Expression conformance checks. *************/
1801 /* Given two expressions, make sure that the arrays are conformable. */
1804 gfc_check_conformance (const char *optype_msgid
,
1805 gfc_expr
* op1
, gfc_expr
* op2
)
1807 int op1_flag
, op2_flag
, d
;
1808 mpz_t op1_size
, op2_size
;
1811 if (op1
->rank
== 0 || op2
->rank
== 0)
1814 if (op1
->rank
!= op2
->rank
)
1816 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
1823 for (d
= 0; d
< op1
->rank
; d
++)
1825 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
1826 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
1828 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
1830 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
1831 _(optype_msgid
), &op1
->where
, d
+ 1,
1832 (int) mpz_get_si (op1_size
),
1833 (int) mpz_get_si (op2_size
));
1839 mpz_clear (op1_size
);
1841 mpz_clear (op2_size
);
1851 /* Given an assignable expression and an arbitrary expression, make
1852 sure that the assignment can take place. */
1855 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
1859 sym
= lvalue
->symtree
->n
.sym
;
1861 if (sym
->attr
.intent
== INTENT_IN
)
1863 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1864 sym
->name
, &lvalue
->where
);
1868 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
1869 variable local to a function subprogram. Its existence begins when
1870 execution of the function is initiated and ends when execution of the
1871 function is terminated.....
1872 Therefore, the left hand side is no longer a varaiable, when it is:*/
1873 if (sym
->attr
.flavor
== FL_PROCEDURE
1874 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1875 && !sym
->attr
.external
)
1880 /* (i) Use associated; */
1881 if (sym
->attr
.use_assoc
)
1884 /* (ii) The assignment is in the main program; or */
1885 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
1888 /* (iii) A module or internal procedure.... */
1889 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
1890 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
1891 && gfc_current_ns
->parent
1892 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
1893 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
1894 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
1896 /* .... that is not a function.... */
1897 if (!gfc_current_ns
->proc_name
->attr
.function
)
1900 /* .... or is not an entry and has a different name. */
1901 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
1907 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
1912 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
1914 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1915 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
1919 if (lvalue
->ts
.type
== BT_UNKNOWN
)
1921 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1926 if (rvalue
->expr_type
== EXPR_NULL
)
1928 gfc_error ("NULL appears on right-hand side in assignment at %L",
1933 if (sym
->attr
.cray_pointee
1934 && lvalue
->ref
!= NULL
1935 && lvalue
->ref
->u
.ar
.type
== AR_FULL
1936 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
1938 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
1939 " is illegal.", &lvalue
->where
);
1943 /* This is possibly a typo: x = f() instead of x => f() */
1944 if (gfc_option
.warn_surprising
1945 && rvalue
->expr_type
== EXPR_FUNCTION
1946 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
1947 gfc_warning ("POINTER valued function appears on right-hand side of "
1948 "assignment at %L", &rvalue
->where
);
1950 /* Check size of array assignments. */
1951 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
1952 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
1955 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1960 /* Numeric can be converted to any other numeric. And Hollerith can be
1961 converted to any other type. */
1962 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
1963 || rvalue
->ts
.type
== BT_HOLLERITH
)
1966 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
1969 gfc_error ("Incompatible types in assignment at %L, %s to %s",
1970 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
1971 gfc_typename (&lvalue
->ts
));
1976 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
1980 /* Check that a pointer assignment is OK. We first check lvalue, and
1981 we only check rvalue if it's not an assignment to NULL() or a
1982 NULLIFY statement. */
1985 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
1987 symbol_attribute attr
;
1990 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
1992 gfc_error ("Pointer assignment target is not a POINTER at %L",
1997 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
1998 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2000 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2001 "l-value since it is a procedure",
2002 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2006 attr
= gfc_variable_attr (lvalue
, NULL
);
2009 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2013 is_pure
= gfc_pure (NULL
);
2015 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2017 gfc_error ("Bad pointer object in PURE procedure at %L",
2022 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2023 kind, etc for lvalue and rvalue must match, and rvalue must be a
2024 pure variable if we're in a pure function. */
2025 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2028 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2030 gfc_error ("Different types in pointer assignment at %L",
2035 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2037 gfc_error ("Different kind type parameters in pointer "
2038 "assignment at %L", &lvalue
->where
);
2042 if (lvalue
->rank
!= rvalue
->rank
)
2044 gfc_error ("Different ranks in pointer assignment at %L",
2049 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2050 if (rvalue
->expr_type
== EXPR_NULL
)
2053 if (lvalue
->ts
.type
== BT_CHARACTER
2054 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2055 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2056 rvalue
->ts
.cl
->length
)) == 1)
2058 gfc_error ("Different character lengths in pointer "
2059 "assignment at %L", &lvalue
->where
);
2063 attr
= gfc_expr_attr (rvalue
);
2064 if (!attr
.target
&& !attr
.pointer
)
2066 gfc_error ("Pointer assignment target is neither TARGET "
2067 "nor POINTER at %L", &rvalue
->where
);
2071 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2073 gfc_error ("Bad target in pointer assignment in PURE "
2074 "procedure at %L", &rvalue
->where
);
2077 if (gfc_has_vector_index (rvalue
))
2079 gfc_error ("Pointer assignment with vector subscript "
2080 "on rhs at %L", &rvalue
->where
);
2088 /* Relative of gfc_check_assign() except that the lvalue is a single
2089 symbol. Used for initialization assignments. */
2092 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
2097 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2099 lvalue
.expr_type
= EXPR_VARIABLE
;
2100 lvalue
.ts
= sym
->ts
;
2102 lvalue
.rank
= sym
->as
->rank
;
2103 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
2104 lvalue
.symtree
->n
.sym
= sym
;
2105 lvalue
.where
= sym
->declared_at
;
2107 if (sym
->attr
.pointer
)
2108 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2110 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2112 gfc_free (lvalue
.symtree
);
2118 /* Get an expression for a default initializer. */
2121 gfc_default_initializer (gfc_typespec
*ts
)
2123 gfc_constructor
*tail
;
2129 /* See if we have a default initializer. */
2130 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2132 if (c
->initializer
&& init
== NULL
)
2133 init
= gfc_get_expr ();
2139 /* Build the constructor. */
2140 init
->expr_type
= EXPR_STRUCTURE
;
2142 init
->where
= ts
->derived
->declared_at
;
2144 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2147 init
->value
.constructor
= tail
= gfc_get_constructor ();
2150 tail
->next
= gfc_get_constructor ();
2155 tail
->expr
= gfc_copy_expr (c
->initializer
);
2161 /* Given a symbol, create an expression node with that symbol as a
2162 variable. If the symbol is array valued, setup a reference of the
2166 gfc_get_variable_expr (gfc_symtree
* var
)
2170 e
= gfc_get_expr ();
2171 e
->expr_type
= EXPR_VARIABLE
;
2173 e
->ts
= var
->n
.sym
->ts
;
2175 if (var
->n
.sym
->as
!= NULL
)
2177 e
->rank
= var
->n
.sym
->as
->rank
;
2178 e
->ref
= gfc_get_ref ();
2179 e
->ref
->type
= REF_ARRAY
;
2180 e
->ref
->u
.ar
.type
= AR_FULL
;
2187 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2190 gfc_expr_set_symbols_referenced (gfc_expr
* expr
)
2192 gfc_actual_arglist
*arg
;
2199 switch (expr
->expr_type
)
2202 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2203 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2207 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2208 gfc_expr_set_symbols_referenced (arg
->expr
);
2212 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2217 case EXPR_SUBSTRING
:
2220 case EXPR_STRUCTURE
:
2222 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2223 gfc_expr_set_symbols_referenced (c
->expr
);
2231 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2235 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2237 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2238 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2239 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2247 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2248 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);