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/>. */
27 #include "target-memory.h" /* for gfc_convert_boz */
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new;
72 for (; p
; p
= p
->next
)
74 new = gfc_get_actual_arglist ();
77 new->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
109 gfc_free_expr (p
->u
.ar
.start
[i
]);
110 gfc_free_expr (p
->u
.ar
.end
[i
]);
111 gfc_free_expr (p
->u
.ar
.stride
[i
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
159 mpfr_clear (e
->value
.complex.r
);
160 mpfr_clear (e
->value
.complex.i
);
167 /* Free the representation, except in character constants where it
168 is the same as value.character.string and thus already freed. */
169 if (e
->representation
.string
&& e
->ts
.type
!= BT_CHARACTER
)
170 gfc_free (e
->representation
.string
);
175 if (e
->value
.op
.op1
!= NULL
)
176 gfc_free_expr (e
->value
.op
.op1
);
177 if (e
->value
.op
.op2
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op2
);
182 gfc_free_actual_arglist (e
->value
.function
.actual
);
190 gfc_free_constructor (e
->value
.constructor
);
194 gfc_free (e
->value
.character
.string
);
201 gfc_internal_error ("free_expr0(): Bad expr type");
204 /* Free a shape array. */
205 if (e
->shape
!= NULL
)
207 for (n
= 0; n
< e
->rank
; n
++)
208 mpz_clear (e
->shape
[n
]);
213 gfc_free_ref_list (e
->ref
);
215 memset (e
, '\0', sizeof (gfc_expr
));
219 /* Free an expression node and everything beneath it. */
222 gfc_free_expr (gfc_expr
*e
)
226 if (e
->con_by_offset
)
227 splay_tree_delete (e
->con_by_offset
);
233 /* Graft the *src expression onto the *dest subexpression. */
236 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
244 /* Try to extract an integer constant from the passed expression node.
245 Returns an error message or NULL if the result is set. It is
246 tempting to generate an error and return SUCCESS or FAILURE, but
247 failure is OK for some callers. */
250 gfc_extract_int (gfc_expr
*expr
, int *result
)
252 if (expr
->expr_type
!= EXPR_CONSTANT
)
253 return _("Constant expression required at %C");
255 if (expr
->ts
.type
!= BT_INTEGER
)
256 return _("Integer expression required at %C");
258 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
259 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
261 return _("Integer value too large in expression at %C");
264 *result
= (int) mpz_get_si (expr
->value
.integer
);
270 /* Recursively copy a list of reference structures. */
273 copy_ref (gfc_ref
*src
)
281 dest
= gfc_get_ref ();
282 dest
->type
= src
->type
;
287 ar
= gfc_copy_array_ref (&src
->u
.ar
);
293 dest
->u
.c
= src
->u
.c
;
297 dest
->u
.ss
= src
->u
.ss
;
298 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
299 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
303 dest
->next
= copy_ref (src
->next
);
309 /* Detect whether an expression has any vector index array references. */
312 gfc_has_vector_index (gfc_expr
*e
)
316 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
317 if (ref
->type
== REF_ARRAY
)
318 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
319 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
325 /* Copy a shape array. */
328 gfc_copy_shape (mpz_t
*shape
, int rank
)
336 new_shape
= gfc_get_shape (rank
);
338 for (n
= 0; n
< rank
; n
++)
339 mpz_init_set (new_shape
[n
], shape
[n
]);
345 /* Copy a shape array excluding dimension N, where N is an integer
346 constant expression. Dimensions are numbered in fortran style --
349 So, if the original shape array contains R elements
350 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
351 the result contains R-1 elements:
352 { s1 ... sN-1 sN+1 ... sR-1}
354 If anything goes wrong -- N is not a constant, its value is out
355 of range -- or anything else, just returns NULL. */
358 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
360 mpz_t
*new_shape
, *s
;
366 || dim
->expr_type
!= EXPR_CONSTANT
367 || dim
->ts
.type
!= BT_INTEGER
)
370 n
= mpz_get_si (dim
->value
.integer
);
371 n
--; /* Convert to zero based index. */
372 if (n
< 0 || n
>= rank
)
375 s
= new_shape
= gfc_get_shape (rank
- 1);
377 for (i
= 0; i
< rank
; i
++)
381 mpz_init_set (*s
, shape
[i
]);
389 /* Given an expression pointer, return a copy of the expression. This
390 subroutine is recursive. */
393 gfc_copy_expr (gfc_expr
*p
)
404 switch (q
->expr_type
)
407 s
= gfc_getmem (p
->value
.character
.length
+ 1);
408 q
->value
.character
.string
= s
;
410 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
414 /* Copy target representation, if it exists. */
415 if (p
->representation
.string
)
417 s
= gfc_getmem (p
->representation
.length
+ 1);
418 q
->representation
.string
= s
;
420 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
423 /* Copy the values of any pointer components of p->value. */
427 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
431 gfc_set_model_kind (q
->ts
.kind
);
432 mpfr_init (q
->value
.real
);
433 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
437 gfc_set_model_kind (q
->ts
.kind
);
438 mpfr_init (q
->value
.complex.r
);
439 mpfr_init (q
->value
.complex.i
);
440 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
441 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
445 if (p
->representation
.string
)
446 q
->value
.character
.string
= q
->representation
.string
;
449 s
= gfc_getmem (p
->value
.character
.length
+ 1);
450 q
->value
.character
.string
= s
;
452 /* This is the case for the C_NULL_CHAR named constant. */
453 if (p
->value
.character
.length
== 0
454 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
457 /* Need to set the length to 1 to make sure the NUL
458 terminator is copied. */
459 q
->value
.character
.length
= 1;
462 memcpy (s
, p
->value
.character
.string
,
463 p
->value
.character
.length
+ 1);
470 break; /* Already done. */
474 /* Should never be reached. */
476 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
483 switch (q
->value
.op
.operator)
486 case INTRINSIC_PARENTHESES
:
487 case INTRINSIC_UPLUS
:
488 case INTRINSIC_UMINUS
:
489 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
492 default: /* Binary operators. */
493 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
494 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
501 q
->value
.function
.actual
=
502 gfc_copy_actual_arglist (p
->value
.function
.actual
);
507 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
515 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
517 q
->ref
= copy_ref (p
->ref
);
523 /* Return the maximum kind of two expressions. In general, higher
524 kind numbers mean more precision for numeric types. */
527 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
529 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
533 /* Returns nonzero if the type is numeric, zero otherwise. */
536 numeric_type (bt type
)
538 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
542 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
545 gfc_numeric_ts (gfc_typespec
*ts
)
547 return numeric_type (ts
->type
);
551 /* Returns an expression node that is an integer constant. */
560 p
->expr_type
= EXPR_CONSTANT
;
561 p
->ts
.type
= BT_INTEGER
;
562 p
->ts
.kind
= gfc_default_integer_kind
;
564 p
->where
= gfc_current_locus
;
565 mpz_init_set_si (p
->value
.integer
, i
);
571 /* Returns an expression node that is a logical constant. */
574 gfc_logical_expr (int i
, locus
*where
)
580 p
->expr_type
= EXPR_CONSTANT
;
581 p
->ts
.type
= BT_LOGICAL
;
582 p
->ts
.kind
= gfc_default_logical_kind
;
585 where
= &gfc_current_locus
;
587 p
->value
.logical
= i
;
593 /* Return an expression node with an optional argument list attached.
594 A variable number of gfc_expr pointers are strung together in an
595 argument list with a NULL pointer terminating the list. */
598 gfc_build_conversion (gfc_expr
*e
)
603 p
->expr_type
= EXPR_FUNCTION
;
605 p
->value
.function
.actual
= NULL
;
607 p
->value
.function
.actual
= gfc_get_actual_arglist ();
608 p
->value
.function
.actual
->expr
= e
;
614 /* Given an expression node with some sort of numeric binary
615 expression, insert type conversions required to make the operands
618 The exception is that the operands of an exponential don't have to
619 have the same type. If possible, the base is promoted to the type
620 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
621 1.0**2 stays as it is. */
624 gfc_type_convert_binary (gfc_expr
*e
)
628 op1
= e
->value
.op
.op1
;
629 op2
= e
->value
.op
.op2
;
631 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
633 gfc_clear_ts (&e
->ts
);
637 /* Kind conversions of same type. */
638 if (op1
->ts
.type
== op2
->ts
.type
)
640 if (op1
->ts
.kind
== op2
->ts
.kind
)
642 /* No type conversions. */
647 if (op1
->ts
.kind
> op2
->ts
.kind
)
648 gfc_convert_type (op2
, &op1
->ts
, 2);
650 gfc_convert_type (op1
, &op2
->ts
, 2);
656 /* Integer combined with real or complex. */
657 if (op2
->ts
.type
== BT_INTEGER
)
661 /* Special case for ** operator. */
662 if (e
->value
.op
.operator == INTRINSIC_POWER
)
665 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
669 if (op1
->ts
.type
== BT_INTEGER
)
672 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
676 /* Real combined with complex. */
677 e
->ts
.type
= BT_COMPLEX
;
678 if (op1
->ts
.kind
> op2
->ts
.kind
)
679 e
->ts
.kind
= op1
->ts
.kind
;
681 e
->ts
.kind
= op2
->ts
.kind
;
682 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
683 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
684 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
685 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
693 check_specification_function (gfc_expr
*e
)
700 sym
= e
->symtree
->n
.sym
;
702 /* F95, 7.1.6.2; F2003, 7.1.7 */
704 && sym
->attr
.function
706 && !sym
->attr
.intrinsic
707 && !sym
->attr
.recursive
708 && sym
->attr
.proc
!= PROC_INTERNAL
709 && sym
->attr
.proc
!= PROC_ST_FUNCTION
710 && sym
->attr
.proc
!= PROC_UNKNOWN
711 && sym
->formal
== NULL
)
717 /* Function to determine if an expression is constant or not. This
718 function expects that the expression has already been simplified. */
721 gfc_is_constant_expr (gfc_expr
*e
)
724 gfc_actual_arglist
*arg
;
730 switch (e
->expr_type
)
733 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
734 && (e
->value
.op
.op2
== NULL
735 || gfc_is_constant_expr (e
->value
.op
.op2
)));
743 /* Specification functions are constant. */
744 if (check_specification_function (e
) == MATCH_YES
)
750 /* Call to intrinsic with at least one argument. */
752 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
754 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
756 if (!gfc_is_constant_expr (arg
->expr
))
770 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
771 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
776 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
777 if (!gfc_is_constant_expr (c
->expr
))
785 rv
= gfc_constant_ac (e
);
789 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
796 /* Is true if an array reference is followed by a component or substring
799 is_subref_array (gfc_expr
* e
)
804 if (e
->expr_type
!= EXPR_VARIABLE
)
807 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
811 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
813 if (ref
->type
== REF_ARRAY
814 && ref
->u
.ar
.type
!= AR_ELEMENT
)
818 && ref
->type
!= REF_ARRAY
)
825 /* Try to collapse intrinsic expressions. */
828 simplify_intrinsic_op (gfc_expr
*p
, int type
)
831 gfc_expr
*op1
, *op2
, *result
;
833 if (p
->value
.op
.operator == INTRINSIC_USER
)
836 op1
= p
->value
.op
.op1
;
837 op2
= p
->value
.op
.op2
;
838 op
= p
->value
.op
.operator;
840 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
842 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
845 if (!gfc_is_constant_expr (op1
)
846 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
850 p
->value
.op
.op1
= NULL
;
851 p
->value
.op
.op2
= NULL
;
855 case INTRINSIC_PARENTHESES
:
856 result
= gfc_parentheses (op1
);
859 case INTRINSIC_UPLUS
:
860 result
= gfc_uplus (op1
);
863 case INTRINSIC_UMINUS
:
864 result
= gfc_uminus (op1
);
868 result
= gfc_add (op1
, op2
);
871 case INTRINSIC_MINUS
:
872 result
= gfc_subtract (op1
, op2
);
875 case INTRINSIC_TIMES
:
876 result
= gfc_multiply (op1
, op2
);
879 case INTRINSIC_DIVIDE
:
880 result
= gfc_divide (op1
, op2
);
883 case INTRINSIC_POWER
:
884 result
= gfc_power (op1
, op2
);
887 case INTRINSIC_CONCAT
:
888 result
= gfc_concat (op1
, op2
);
892 case INTRINSIC_EQ_OS
:
893 result
= gfc_eq (op1
, op2
, op
);
897 case INTRINSIC_NE_OS
:
898 result
= gfc_ne (op1
, op2
, op
);
902 case INTRINSIC_GT_OS
:
903 result
= gfc_gt (op1
, op2
, op
);
907 case INTRINSIC_GE_OS
:
908 result
= gfc_ge (op1
, op2
, op
);
912 case INTRINSIC_LT_OS
:
913 result
= gfc_lt (op1
, op2
, op
);
917 case INTRINSIC_LE_OS
:
918 result
= gfc_le (op1
, op2
, op
);
922 result
= gfc_not (op1
);
926 result
= gfc_and (op1
, op2
);
930 result
= gfc_or (op1
, op2
);
934 result
= gfc_eqv (op1
, op2
);
938 result
= gfc_neqv (op1
, op2
);
942 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
952 result
->rank
= p
->rank
;
953 result
->where
= p
->where
;
954 gfc_replace_expr (p
, result
);
960 /* Subroutine to simplify constructor expressions. Mutually recursive
961 with gfc_simplify_expr(). */
964 simplify_constructor (gfc_constructor
*c
, int type
)
966 for (; c
; c
= c
->next
)
969 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
970 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
971 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
974 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
982 /* Pull a single array element out of an array constructor. */
985 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
986 gfc_constructor
**rval
)
988 unsigned long nelemen
;
1000 mpz_init_set_ui (offset
, 0);
1003 mpz_init_set_ui (span
, 1);
1004 for (i
= 0; i
< ar
->dimen
; i
++)
1006 e
= gfc_copy_expr (ar
->start
[i
]);
1007 if (e
->expr_type
!= EXPR_CONSTANT
)
1013 /* Check the bounds. */
1014 if (ar
->as
->upper
[i
]
1015 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
1016 || mpz_cmp (e
->value
.integer
,
1017 ar
->as
->lower
[i
]->value
.integer
) < 0))
1019 gfc_error ("index in dimension %d is out of bounds "
1020 "at %L", i
+ 1, &ar
->c_where
[i
]);
1026 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1027 mpz_mul (delta
, delta
, span
);
1028 mpz_add (offset
, offset
, delta
);
1030 mpz_set_ui (tmp
, 1);
1031 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1032 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1033 mpz_mul (span
, span
, tmp
);
1038 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1061 /* Find a component of a structure constructor. */
1063 static gfc_constructor
*
1064 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1066 gfc_component
*comp
;
1067 gfc_component
*pick
;
1069 comp
= ref
->u
.c
.sym
->components
;
1070 pick
= ref
->u
.c
.component
;
1071 while (comp
!= pick
)
1081 /* Replace an expression with the contents of a constructor, removing
1082 the subobject reference in the process. */
1085 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1091 e
->ref
= p
->ref
->next
;
1092 p
->ref
->next
= NULL
;
1093 gfc_replace_expr (p
, e
);
1097 /* Pull an array section out of an array constructor. */
1100 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1106 long unsigned one
= 1;
1108 mpz_t start
[GFC_MAX_DIMENSIONS
];
1109 mpz_t end
[GFC_MAX_DIMENSIONS
];
1110 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1111 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1112 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1118 gfc_constructor
*cons
;
1119 gfc_constructor
*base
;
1125 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1130 base
= expr
->value
.constructor
;
1131 expr
->value
.constructor
= NULL
;
1133 rank
= ref
->u
.ar
.as
->rank
;
1135 if (expr
->shape
== NULL
)
1136 expr
->shape
= gfc_get_shape (rank
);
1138 mpz_init_set_ui (delta_mpz
, one
);
1139 mpz_init_set_ui (nelts
, one
);
1142 /* Do the initialization now, so that we can cleanup without
1143 keeping track of where we were. */
1144 for (d
= 0; d
< rank
; d
++)
1146 mpz_init (delta
[d
]);
1147 mpz_init (start
[d
]);
1150 mpz_init (stride
[d
]);
1154 /* Build the counters to clock through the array reference. */
1156 for (d
= 0; d
< rank
; d
++)
1158 /* Make this stretch of code easier on the eye! */
1159 begin
= ref
->u
.ar
.start
[d
];
1160 finish
= ref
->u
.ar
.end
[d
];
1161 step
= ref
->u
.ar
.stride
[d
];
1162 lower
= ref
->u
.ar
.as
->lower
[d
];
1163 upper
= ref
->u
.ar
.as
->upper
[d
];
1165 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1169 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1175 gcc_assert (begin
->rank
== 1);
1176 gcc_assert (begin
->shape
);
1178 vecsub
[d
] = begin
->value
.constructor
;
1179 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1180 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1181 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1184 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1186 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1187 || mpz_cmp (c
->expr
->value
.integer
,
1188 lower
->value
.integer
) < 0)
1190 gfc_error ("index in dimension %d is out of bounds "
1191 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1199 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1200 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1201 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1207 /* Obtain the stride. */
1209 mpz_set (stride
[d
], step
->value
.integer
);
1211 mpz_set_ui (stride
[d
], one
);
1213 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1214 mpz_set_ui (stride
[d
], one
);
1216 /* Obtain the start value for the index. */
1218 mpz_set (start
[d
], begin
->value
.integer
);
1220 mpz_set (start
[d
], lower
->value
.integer
);
1222 mpz_set (ctr
[d
], start
[d
]);
1224 /* Obtain the end value for the index. */
1226 mpz_set (end
[d
], finish
->value
.integer
);
1228 mpz_set (end
[d
], upper
->value
.integer
);
1230 /* Separate 'if' because elements sometimes arrive with
1232 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1233 mpz_set (end
[d
], begin
->value
.integer
);
1235 /* Check the bounds. */
1236 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1237 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1238 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1239 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1241 gfc_error ("index in dimension %d is out of bounds "
1242 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1247 /* Calculate the number of elements and the shape. */
1248 mpz_set (tmp_mpz
, stride
[d
]);
1249 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1250 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1251 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1252 mpz_mul (nelts
, nelts
, tmp_mpz
);
1254 /* An element reference reduces the rank of the expression; don't
1255 add anything to the shape array. */
1256 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1257 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1260 /* Calculate the 'stride' (=delta) for conversion of the
1261 counter values into the index along the constructor. */
1262 mpz_set (delta
[d
], delta_mpz
);
1263 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1264 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1265 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1272 /* Now clock through the array reference, calculating the index in
1273 the source constructor and transferring the elements to the new
1275 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1277 if (ref
->u
.ar
.offset
)
1278 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1280 mpz_init_set_ui (ptr
, 0);
1283 for (d
= 0; d
< rank
; d
++)
1285 mpz_set (tmp_mpz
, ctr
[d
]);
1286 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1287 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1288 mpz_add (ptr
, ptr
, tmp_mpz
);
1290 if (!incr_ctr
) continue;
1292 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1294 gcc_assert(vecsub
[d
]);
1296 if (!vecsub
[d
]->next
)
1297 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1300 vecsub
[d
] = vecsub
[d
]->next
;
1303 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1307 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1309 if (mpz_cmp_ui (stride
[d
], 0) > 0
1310 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1311 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1312 mpz_set (ctr
[d
], start
[d
]);
1318 /* There must be a better way of dealing with negative strides
1319 than resetting the index and the constructor pointer! */
1320 if (mpz_cmp (ptr
, index
) < 0)
1322 mpz_set_ui (index
, 0);
1326 while (mpz_cmp (ptr
, index
) > 0)
1328 mpz_add_ui (index
, index
, one
);
1332 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1340 mpz_clear (delta_mpz
);
1341 mpz_clear (tmp_mpz
);
1343 for (d
= 0; d
< rank
; d
++)
1345 mpz_clear (delta
[d
]);
1346 mpz_clear (start
[d
]);
1349 mpz_clear (stride
[d
]);
1351 gfc_free_constructor (base
);
1355 /* Pull a substring out of an expression. */
1358 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1365 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1366 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1369 *newp
= gfc_copy_expr (p
);
1370 gfc_free ((*newp
)->value
.character
.string
);
1372 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1373 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1374 length
= end
- start
+ 1;
1376 chr
= (*newp
)->value
.character
.string
= gfc_getmem (length
+ 1);
1377 (*newp
)->value
.character
.length
= length
;
1378 memcpy (chr
, &p
->value
.character
.string
[start
- 1], length
);
1385 /* Simplify a subobject reference of a constructor. This occurs when
1386 parameter variable values are substituted. */
1389 simplify_const_ref (gfc_expr
*p
)
1391 gfc_constructor
*cons
;
1396 switch (p
->ref
->type
)
1399 switch (p
->ref
->u
.ar
.type
)
1402 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1409 remove_subobject_ref (p
, cons
);
1413 if (find_array_section (p
, p
->ref
) == FAILURE
)
1415 p
->ref
->u
.ar
.type
= AR_FULL
;
1420 if (p
->ref
->next
!= NULL
1421 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1423 cons
= p
->value
.constructor
;
1424 for (; cons
; cons
= cons
->next
)
1426 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1427 simplify_const_ref (cons
->expr
);
1430 gfc_free_ref_list (p
->ref
);
1441 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1442 remove_subobject_ref (p
, cons
);
1446 if (find_substring_ref (p
, &newp
) == FAILURE
)
1449 gfc_replace_expr (p
, newp
);
1450 gfc_free_ref_list (p
->ref
);
1460 /* Simplify a chain of references. */
1463 simplify_ref_chain (gfc_ref
*ref
, int type
)
1467 for (; ref
; ref
= ref
->next
)
1472 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1474 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1476 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1478 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1484 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1486 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1498 /* Try to substitute the value of a parameter variable. */
1501 simplify_parameter_variable (gfc_expr
*p
, int type
)
1506 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1512 /* Do not copy subobject refs for constant. */
1513 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1514 e
->ref
= copy_ref (p
->ref
);
1515 t
= gfc_simplify_expr (e
, type
);
1517 /* Only use the simplification if it eliminated all subobject references. */
1518 if (t
== SUCCESS
&& !e
->ref
)
1519 gfc_replace_expr (p
, e
);
1526 /* Given an expression, simplify it by collapsing constant
1527 expressions. Most simplification takes place when the expression
1528 tree is being constructed. If an intrinsic function is simplified
1529 at some point, we get called again to collapse the result against
1532 We work by recursively simplifying expression nodes, simplifying
1533 intrinsic functions where possible, which can lead to further
1534 constant collapsing. If an operator has constant operand(s), we
1535 rip the expression apart, and rebuild it, hoping that it becomes
1538 The expression type is defined for:
1539 0 Basic expression parsing
1540 1 Simplifying array constructors -- will substitute
1542 Returns FAILURE on error, SUCCESS otherwise.
1543 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1546 gfc_simplify_expr (gfc_expr
*p
, int type
)
1548 gfc_actual_arglist
*ap
;
1553 switch (p
->expr_type
)
1560 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1561 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1564 if (p
->value
.function
.isym
!= NULL
1565 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1570 case EXPR_SUBSTRING
:
1571 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1574 if (gfc_is_constant_expr (p
))
1579 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1581 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1582 start
--; /* Convert from one-based to zero-based. */
1587 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1588 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1590 end
= p
->value
.character
.length
;
1592 s
= gfc_getmem (end
- start
+ 2);
1593 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1594 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1595 gfc_free (p
->value
.character
.string
);
1596 p
->value
.character
.string
= s
;
1597 p
->value
.character
.length
= end
- start
;
1598 p
->ts
.cl
= gfc_get_charlen ();
1599 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1600 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1601 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1602 gfc_free_ref_list (p
->ref
);
1604 p
->expr_type
= EXPR_CONSTANT
;
1609 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1614 /* Only substitute array parameter variables if we are in an
1615 initialization expression, or we want a subsection. */
1616 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1617 && (gfc_init_expr
|| p
->ref
1618 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1620 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1627 gfc_simplify_iterator_var (p
);
1630 /* Simplify subcomponent references. */
1631 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1636 case EXPR_STRUCTURE
:
1638 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1641 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1644 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1645 && p
->ref
->u
.ar
.type
== AR_FULL
)
1646 gfc_expand_constructor (p
);
1648 if (simplify_const_ref (p
) == FAILURE
)
1658 /* Returns the type of an expression with the exception that iterator
1659 variables are automatically integers no matter what else they may
1665 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1672 /* Check an intrinsic arithmetic operation to see if it is consistent
1673 with some type of expression. */
1675 static try check_init_expr (gfc_expr
*);
1678 /* Scalarize an expression for an elemental intrinsic call. */
1681 scalarize_intrinsic_call (gfc_expr
*e
)
1683 gfc_actual_arglist
*a
, *b
;
1684 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1685 gfc_expr
*expr
, *old
;
1688 old
= gfc_copy_expr (e
);
1690 /* Assume that the old expression carries the type information and
1691 that the first arg carries all the shape information. */
1692 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1693 gfc_free_constructor (expr
->value
.constructor
);
1694 expr
->value
.constructor
= NULL
;
1697 expr
->expr_type
= EXPR_ARRAY
;
1699 /* Copy the array argument constructors into an array, with nulls
1702 a
= old
->value
.function
.actual
;
1703 for (; a
; a
= a
->next
)
1705 /* Check that this is OK for an initialization expression. */
1706 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1710 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1712 rank
[n
] = a
->expr
->rank
;
1713 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1714 args
[n
] = gfc_copy_constructor (ctor
);
1716 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1719 rank
[n
] = a
->expr
->rank
;
1722 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1729 for (i
= 1; i
< n
; i
++)
1730 if (rank
[i
] && rank
[i
] != rank
[0])
1733 /* Using the first argument as the master, step through the array
1734 calling the function for each element and advancing the array
1735 constructors together. */
1738 for (; ctor
; ctor
= ctor
->next
)
1740 if (expr
->value
.constructor
== NULL
)
1741 expr
->value
.constructor
1742 = new_ctor
= gfc_get_constructor ();
1745 new_ctor
->next
= gfc_get_constructor ();
1746 new_ctor
= new_ctor
->next
;
1748 new_ctor
->expr
= gfc_copy_expr (old
);
1749 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1751 b
= old
->value
.function
.actual
;
1752 for (i
= 0; i
< n
; i
++)
1755 new_ctor
->expr
->value
.function
.actual
1756 = a
= gfc_get_actual_arglist ();
1759 a
->next
= gfc_get_actual_arglist ();
1763 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1765 a
->expr
= gfc_copy_expr (b
->expr
);
1770 /* Simplify the function calls. */
1771 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1774 for (i
= 0; i
< n
; i
++)
1776 args
[i
] = args
[i
]->next
;
1778 for (i
= 1; i
< n
; i
++)
1779 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1780 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1786 gfc_free_expr (old
);
1790 gfc_error_now ("elemental function arguments at %C are not compliant");
1793 gfc_free_expr (expr
);
1794 gfc_free_expr (old
);
1800 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1802 gfc_expr
*op1
= e
->value
.op
.op1
;
1803 gfc_expr
*op2
= e
->value
.op
.op2
;
1805 if ((*check_function
) (op1
) == FAILURE
)
1808 switch (e
->value
.op
.operator)
1810 case INTRINSIC_UPLUS
:
1811 case INTRINSIC_UMINUS
:
1812 if (!numeric_type (et0 (op1
)))
1817 case INTRINSIC_EQ_OS
:
1819 case INTRINSIC_NE_OS
:
1821 case INTRINSIC_GT_OS
:
1823 case INTRINSIC_GE_OS
:
1825 case INTRINSIC_LT_OS
:
1827 case INTRINSIC_LE_OS
:
1828 if ((*check_function
) (op2
) == FAILURE
)
1831 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1832 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1834 gfc_error ("Numeric or CHARACTER operands are required in "
1835 "expression at %L", &e
->where
);
1840 case INTRINSIC_PLUS
:
1841 case INTRINSIC_MINUS
:
1842 case INTRINSIC_TIMES
:
1843 case INTRINSIC_DIVIDE
:
1844 case INTRINSIC_POWER
:
1845 if ((*check_function
) (op2
) == FAILURE
)
1848 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1851 if (e
->value
.op
.operator == INTRINSIC_POWER
1852 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1854 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1855 "exponent in an initialization "
1856 "expression at %L", &op2
->where
)
1863 case INTRINSIC_CONCAT
:
1864 if ((*check_function
) (op2
) == FAILURE
)
1867 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1869 gfc_error ("Concatenation operator in expression at %L "
1870 "must have two CHARACTER operands", &op1
->where
);
1874 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1876 gfc_error ("Concat operator at %L must concatenate strings of the "
1877 "same kind", &e
->where
);
1884 if (et0 (op1
) != BT_LOGICAL
)
1886 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1887 "operand", &op1
->where
);
1896 case INTRINSIC_NEQV
:
1897 if ((*check_function
) (op2
) == FAILURE
)
1900 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1902 gfc_error ("LOGICAL operands are required in expression at %L",
1909 case INTRINSIC_PARENTHESES
:
1913 gfc_error ("Only intrinsic operators can be used in expression at %L",
1921 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1928 check_init_expr_arguments (gfc_expr
*e
)
1930 gfc_actual_arglist
*ap
;
1932 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1933 if (check_init_expr (ap
->expr
) == FAILURE
)
1939 /* F95, 7.1.6.1, Initialization expressions, (7)
1940 F2003, 7.1.7 Initialization expression, (8) */
1943 check_inquiry (gfc_expr
*e
, int not_restricted
)
1946 const char *const *functions
;
1948 static const char *const inquiry_func_f95
[] = {
1949 "lbound", "shape", "size", "ubound",
1950 "bit_size", "len", "kind",
1951 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1952 "precision", "radix", "range", "tiny",
1956 static const char *const inquiry_func_f2003
[] = {
1957 "lbound", "shape", "size", "ubound",
1958 "bit_size", "len", "kind",
1959 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1960 "precision", "radix", "range", "tiny",
1965 gfc_actual_arglist
*ap
;
1967 if (!e
->value
.function
.isym
1968 || !e
->value
.function
.isym
->inquiry
)
1971 /* An undeclared parameter will get us here (PR25018). */
1972 if (e
->symtree
== NULL
)
1975 name
= e
->symtree
->n
.sym
->name
;
1977 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1978 ? inquiry_func_f2003
: inquiry_func_f95
;
1980 for (i
= 0; functions
[i
]; i
++)
1981 if (strcmp (functions
[i
], name
) == 0)
1984 if (functions
[i
] == NULL
)
1987 /* At this point we have an inquiry function with a variable argument. The
1988 type of the variable might be undefined, but we need it now, because the
1989 arguments of these functions are not allowed to be undefined. */
1991 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1996 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
1998 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1999 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2003 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2006 /* Assumed character length will not reduce to a constant expression
2007 with LEN, as required by the standard. */
2008 if (i
== 5 && not_restricted
2009 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2010 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2012 gfc_error ("Assumed character length variable '%s' in constant "
2013 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2016 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2024 /* F95, 7.1.6.1, Initialization expressions, (5)
2025 F2003, 7.1.7 Initialization expression, (5) */
2028 check_transformational (gfc_expr
*e
)
2030 static const char * const trans_func_f95
[] = {
2031 "repeat", "reshape", "selected_int_kind",
2032 "selected_real_kind", "transfer", "trim", NULL
2038 if (!e
->value
.function
.isym
2039 || !e
->value
.function
.isym
->transformational
)
2042 name
= e
->symtree
->n
.sym
->name
;
2044 /* NULL() is dealt with below. */
2045 if (strcmp ("null", name
) == 0)
2048 for (i
= 0; trans_func_f95
[i
]; i
++)
2049 if (strcmp (trans_func_f95
[i
], name
) == 0)
2052 /* FIXME, F2003: implement translation of initialization
2053 expressions before enabling this check. For F95, error
2054 out if the transformational function is not in the list. */
2056 if (trans_func_f95
[i
] == NULL
2057 && gfc_notify_std (GFC_STD_F2003
,
2058 "transformational intrinsic '%s' at %L is not permitted "
2059 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2062 if (trans_func_f95
[i
] == NULL
)
2064 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2065 "in an initialization expression", name
, &e
->where
);
2070 return check_init_expr_arguments (e
);
2074 /* F95, 7.1.6.1, Initialization expressions, (6)
2075 F2003, 7.1.7 Initialization expression, (6) */
2078 check_null (gfc_expr
*e
)
2080 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2083 return check_init_expr_arguments (e
);
2088 check_elemental (gfc_expr
*e
)
2090 if (!e
->value
.function
.isym
2091 || !e
->value
.function
.isym
->elemental
)
2094 if ((e
->ts
.type
!= BT_INTEGER
|| e
->ts
.type
!= BT_CHARACTER
)
2095 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2096 "nonstandard initialization expression at %L",
2097 &e
->where
) == FAILURE
)
2100 return check_init_expr_arguments (e
);
2105 check_conversion (gfc_expr
*e
)
2107 if (!e
->value
.function
.isym
2108 || !e
->value
.function
.isym
->conversion
)
2111 return check_init_expr_arguments (e
);
2115 /* Verify that an expression is an initialization expression. A side
2116 effect is that the expression tree is reduced to a single constant
2117 node if all goes well. This would normally happen when the
2118 expression is constructed but function references are assumed to be
2119 intrinsics in the context of initialization expressions. If
2120 FAILURE is returned an error message has been generated. */
2123 check_init_expr (gfc_expr
*e
)
2127 gfc_intrinsic_sym
*isym
;
2132 switch (e
->expr_type
)
2135 t
= check_intrinsic_op (e
, check_init_expr
);
2137 t
= gfc_simplify_expr (e
, 0);
2144 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2146 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2148 gfc_error ("Function '%s' in initialization expression at %L "
2149 "must be an intrinsic or a specification function",
2150 e
->symtree
->n
.sym
->name
, &e
->where
);
2154 if ((m
= check_conversion (e
)) == MATCH_NO
2155 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2156 && (m
= check_null (e
)) == MATCH_NO
2157 && (m
= check_transformational (e
)) == MATCH_NO
2158 && (m
= check_elemental (e
)) == MATCH_NO
)
2160 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2161 "in an initialization expression",
2162 e
->symtree
->n
.sym
->name
, &e
->where
);
2166 /* Try to scalarize an elemental intrinsic function that has an
2168 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2169 if (isym
&& isym
->elemental
2170 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2172 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2178 t
= gfc_simplify_expr (e
, 0);
2185 if (gfc_check_iter_variable (e
) == SUCCESS
)
2188 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2190 t
= simplify_parameter_variable (e
, 0);
2194 if (gfc_in_match_data ())
2199 if (e
->symtree
->n
.sym
->as
)
2201 switch (e
->symtree
->n
.sym
->as
->type
)
2203 case AS_ASSUMED_SIZE
:
2204 gfc_error ("Assumed size array '%s' at %L is not permitted "
2205 "in an initialization expression",
2206 e
->symtree
->n
.sym
->name
, &e
->where
);
2209 case AS_ASSUMED_SHAPE
:
2210 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2211 "in an initialization expression",
2212 e
->symtree
->n
.sym
->name
, &e
->where
);
2216 gfc_error ("Deferred array '%s' at %L is not permitted "
2217 "in an initialization expression",
2218 e
->symtree
->n
.sym
->name
, &e
->where
);
2226 gfc_error ("Parameter '%s' at %L has not been declared or is "
2227 "a variable, which does not reduce to a constant "
2228 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2237 case EXPR_SUBSTRING
:
2238 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2242 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2244 t
= gfc_simplify_expr (e
, 0);
2248 case EXPR_STRUCTURE
:
2252 t
= gfc_check_constructor (e
, check_init_expr
);
2256 t
= gfc_check_constructor (e
, check_init_expr
);
2260 t
= gfc_expand_constructor (e
);
2264 t
= gfc_check_constructor_type (e
);
2268 gfc_internal_error ("check_init_expr(): Unknown expression type");
2275 /* Match an initialization expression. We work by first matching an
2276 expression, then reducing it to a constant. */
2279 gfc_match_init_expr (gfc_expr
**result
)
2285 m
= gfc_match_expr (&expr
);
2290 t
= gfc_resolve_expr (expr
);
2292 t
= check_init_expr (expr
);
2297 gfc_free_expr (expr
);
2301 if (expr
->expr_type
== EXPR_ARRAY
2302 && (gfc_check_constructor_type (expr
) == FAILURE
2303 || gfc_expand_constructor (expr
) == FAILURE
))
2305 gfc_free_expr (expr
);
2309 /* Not all inquiry functions are simplified to constant expressions
2310 so it is necessary to call check_inquiry again. */
2311 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2312 && !gfc_in_match_data ())
2314 gfc_error ("Initialization expression didn't reduce %C");
2324 static try check_restricted (gfc_expr
*);
2326 /* Given an actual argument list, test to see that each argument is a
2327 restricted expression and optionally if the expression type is
2328 integer or character. */
2331 restricted_args (gfc_actual_arglist
*a
)
2333 for (; a
; a
= a
->next
)
2335 if (check_restricted (a
->expr
) == FAILURE
)
2343 /************* Restricted/specification expressions *************/
2346 /* Make sure a non-intrinsic function is a specification function. */
2349 external_spec_function (gfc_expr
*e
)
2353 f
= e
->value
.function
.esym
;
2355 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2357 gfc_error ("Specification function '%s' at %L cannot be a statement "
2358 "function", f
->name
, &e
->where
);
2362 if (f
->attr
.proc
== PROC_INTERNAL
)
2364 gfc_error ("Specification function '%s' at %L cannot be an internal "
2365 "function", f
->name
, &e
->where
);
2369 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2371 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2376 if (f
->attr
.recursive
)
2378 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2379 f
->name
, &e
->where
);
2383 return restricted_args (e
->value
.function
.actual
);
2387 /* Check to see that a function reference to an intrinsic is a
2388 restricted expression. */
2391 restricted_intrinsic (gfc_expr
*e
)
2393 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2394 if (check_inquiry (e
, 0) == MATCH_YES
)
2397 return restricted_args (e
->value
.function
.actual
);
2401 /* Verify that an expression is a restricted expression. Like its
2402 cousin check_init_expr(), an error message is generated if we
2406 check_restricted (gfc_expr
*e
)
2414 switch (e
->expr_type
)
2417 t
= check_intrinsic_op (e
, check_restricted
);
2419 t
= gfc_simplify_expr (e
, 0);
2424 t
= e
->value
.function
.esym
? external_spec_function (e
)
2425 : restricted_intrinsic (e
);
2429 sym
= e
->symtree
->n
.sym
;
2432 /* If a dummy argument appears in a context that is valid for a
2433 restricted expression in an elemental procedure, it will have
2434 already been simplified away once we get here. Therefore we
2435 don't need to jump through hoops to distinguish valid from
2437 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2438 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2440 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2441 sym
->name
, &e
->where
);
2445 if (sym
->attr
.optional
)
2447 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2448 sym
->name
, &e
->where
);
2452 if (sym
->attr
.intent
== INTENT_OUT
)
2454 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2455 sym
->name
, &e
->where
);
2459 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2460 processed in resolve.c(resolve_formal_arglist). This is done so
2461 that host associated dummy array indices are accepted (PR23446).
2462 This mechanism also does the same for the specification expressions
2463 of array-valued functions. */
2464 if (sym
->attr
.in_common
2465 || sym
->attr
.use_assoc
2467 || sym
->ns
!= gfc_current_ns
2468 || (sym
->ns
->proc_name
!= NULL
2469 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2470 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2476 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2477 sym
->name
, &e
->where
);
2486 case EXPR_SUBSTRING
:
2487 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2491 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2493 t
= gfc_simplify_expr (e
, 0);
2497 case EXPR_STRUCTURE
:
2498 t
= gfc_check_constructor (e
, check_restricted
);
2502 t
= gfc_check_constructor (e
, check_restricted
);
2506 gfc_internal_error ("check_restricted(): Unknown expression type");
2513 /* Check to see that an expression is a specification expression. If
2514 we return FAILURE, an error has been generated. */
2517 gfc_specification_expr (gfc_expr
*e
)
2523 if (e
->ts
.type
!= BT_INTEGER
)
2525 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2529 if (e
->expr_type
== EXPR_FUNCTION
2530 && !e
->value
.function
.isym
2531 && !e
->value
.function
.esym
2532 && !gfc_pure (e
->symtree
->n
.sym
))
2534 gfc_error ("Function '%s' at %L must be PURE",
2535 e
->symtree
->n
.sym
->name
, &e
->where
);
2536 /* Prevent repeat error messages. */
2537 e
->symtree
->n
.sym
->attr
.pure
= 1;
2543 gfc_error ("Expression at %L must be scalar", &e
->where
);
2547 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2550 return check_restricted (e
);
2554 /************** Expression conformance checks. *************/
2556 /* Given two expressions, make sure that the arrays are conformable. */
2559 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2561 int op1_flag
, op2_flag
, d
;
2562 mpz_t op1_size
, op2_size
;
2565 if (op1
->rank
== 0 || op2
->rank
== 0)
2568 if (op1
->rank
!= op2
->rank
)
2570 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2571 op1
->rank
, op2
->rank
, &op1
->where
);
2577 for (d
= 0; d
< op1
->rank
; d
++)
2579 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2580 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2582 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2584 gfc_error ("Different shape for %s at %L on dimension %d "
2585 "(%d and %d)", _(optype_msgid
), &op1
->where
, d
+ 1,
2586 (int) mpz_get_si (op1_size
),
2587 (int) mpz_get_si (op2_size
));
2593 mpz_clear (op1_size
);
2595 mpz_clear (op2_size
);
2605 /* Given an assignable expression and an arbitrary expression, make
2606 sure that the assignment can take place. */
2609 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2615 sym
= lvalue
->symtree
->n
.sym
;
2617 /* Check INTENT(IN), unless the object itself is the component or
2618 sub-component of a pointer. */
2619 has_pointer
= sym
->attr
.pointer
;
2621 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2622 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2628 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2630 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2631 sym
->name
, &lvalue
->where
);
2635 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2636 variable local to a function subprogram. Its existence begins when
2637 execution of the function is initiated and ends when execution of the
2638 function is terminated...
2639 Therefore, the left hand side is no longer a variable, when it is: */
2640 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2641 && !sym
->attr
.external
)
2646 /* (i) Use associated; */
2647 if (sym
->attr
.use_assoc
)
2650 /* (ii) The assignment is in the main program; or */
2651 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2654 /* (iii) A module or internal procedure... */
2655 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2656 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2657 && gfc_current_ns
->parent
2658 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2659 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2660 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2662 /* ... that is not a function... */
2663 if (!gfc_current_ns
->proc_name
->attr
.function
)
2666 /* ... or is not an entry and has a different name. */
2667 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2673 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2678 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2680 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2681 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2685 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2687 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2692 if (rvalue
->expr_type
== EXPR_NULL
)
2694 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2695 && lvalue
->symtree
->n
.sym
->attr
.data
)
2699 gfc_error ("NULL appears on right-hand side in assignment at %L",
2705 if (sym
->attr
.cray_pointee
2706 && lvalue
->ref
!= NULL
2707 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2708 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2710 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2711 "is illegal", &lvalue
->where
);
2715 /* This is possibly a typo: x = f() instead of x => f(). */
2716 if (gfc_option
.warn_surprising
2717 && rvalue
->expr_type
== EXPR_FUNCTION
2718 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2719 gfc_warning ("POINTER valued function appears on right-hand side of "
2720 "assignment at %L", &rvalue
->where
);
2722 /* Check size of array assignments. */
2723 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2724 && gfc_check_conformance ("array assignment", lvalue
, rvalue
) != SUCCESS
)
2727 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
2728 && lvalue
->symtree
->n
.sym
->attr
.data
2729 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
2730 "initialize non-integer variable '%s'",
2731 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
2734 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
2735 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
2736 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2737 &rvalue
->where
) == FAILURE
)
2740 /* Handle the case of a BOZ literal on the RHS. */
2741 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
2743 if (gfc_option
.warn_surprising
)
2744 gfc_warning ("BOZ literal at %L is bitwise transferred "
2745 "non-integer symbol '%s'", &rvalue
->where
,
2746 lvalue
->symtree
->n
.sym
->name
);
2747 gfc_convert_boz (rvalue
, &lvalue
->ts
);
2750 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2755 /* Numeric can be converted to any other numeric. And Hollerith can be
2756 converted to any other type. */
2757 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2758 || rvalue
->ts
.type
== BT_HOLLERITH
)
2761 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2764 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2765 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2766 gfc_typename (&lvalue
->ts
));
2771 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2775 /* Check that a pointer assignment is OK. We first check lvalue, and
2776 we only check rvalue if it's not an assignment to NULL() or a
2777 NULLIFY statement. */
2780 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2782 symbol_attribute attr
;
2785 int pointer
, check_intent_in
;
2787 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2789 gfc_error ("Pointer assignment target is not a POINTER at %L",
2794 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2795 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2797 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2798 "l-value since it is a procedure",
2799 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2804 /* Check INTENT(IN), unless the object itself is the component or
2805 sub-component of a pointer. */
2806 check_intent_in
= 1;
2807 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2809 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2812 check_intent_in
= 0;
2814 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2818 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2820 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2821 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2827 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2831 is_pure
= gfc_pure (NULL
);
2833 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
2834 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
2836 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2840 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2841 kind, etc for lvalue and rvalue must match, and rvalue must be a
2842 pure variable if we're in a pure function. */
2843 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2846 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2848 gfc_error ("Different types in pointer assignment at %L",
2853 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2855 gfc_error ("Different kind type parameters in pointer "
2856 "assignment at %L", &lvalue
->where
);
2860 if (lvalue
->rank
!= rvalue
->rank
)
2862 gfc_error ("Different ranks in pointer assignment at %L",
2867 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2868 if (rvalue
->expr_type
== EXPR_NULL
)
2871 if (lvalue
->ts
.type
== BT_CHARACTER
2872 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2873 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2874 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2875 rvalue
->ts
.cl
->length
)) == 1)
2877 gfc_error ("Different character lengths in pointer "
2878 "assignment at %L", &lvalue
->where
);
2882 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
2883 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
2885 attr
= gfc_expr_attr (rvalue
);
2886 if (!attr
.target
&& !attr
.pointer
)
2888 gfc_error ("Pointer assignment target is neither TARGET "
2889 "nor POINTER at %L", &rvalue
->where
);
2893 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2895 gfc_error ("Bad target in pointer assignment in PURE "
2896 "procedure at %L", &rvalue
->where
);
2899 if (gfc_has_vector_index (rvalue
))
2901 gfc_error ("Pointer assignment with vector subscript "
2902 "on rhs at %L", &rvalue
->where
);
2906 if (attr
.protected && attr
.use_assoc
)
2908 gfc_error ("Pointer assigment target has PROTECTED "
2909 "attribute at %L", &rvalue
->where
);
2917 /* Relative of gfc_check_assign() except that the lvalue is a single
2918 symbol. Used for initialization assignments. */
2921 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2926 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2928 lvalue
.expr_type
= EXPR_VARIABLE
;
2929 lvalue
.ts
= sym
->ts
;
2931 lvalue
.rank
= sym
->as
->rank
;
2932 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2933 lvalue
.symtree
->n
.sym
= sym
;
2934 lvalue
.where
= sym
->declared_at
;
2936 if (sym
->attr
.pointer
)
2937 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2939 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2941 gfc_free (lvalue
.symtree
);
2947 /* Get an expression for a default initializer. */
2950 gfc_default_initializer (gfc_typespec
*ts
)
2952 gfc_constructor
*tail
;
2956 /* See if we have a default initializer. */
2957 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2958 if (c
->initializer
|| c
->allocatable
)
2964 /* Build the constructor. */
2965 init
= gfc_get_expr ();
2966 init
->expr_type
= EXPR_STRUCTURE
;
2968 init
->where
= ts
->derived
->declared_at
;
2971 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2974 init
->value
.constructor
= tail
= gfc_get_constructor ();
2977 tail
->next
= gfc_get_constructor ();
2982 tail
->expr
= gfc_copy_expr (c
->initializer
);
2986 tail
->expr
= gfc_get_expr ();
2987 tail
->expr
->expr_type
= EXPR_NULL
;
2988 tail
->expr
->ts
= c
->ts
;
2995 /* Given a symbol, create an expression node with that symbol as a
2996 variable. If the symbol is array valued, setup a reference of the
3000 gfc_get_variable_expr (gfc_symtree
*var
)
3004 e
= gfc_get_expr ();
3005 e
->expr_type
= EXPR_VARIABLE
;
3007 e
->ts
= var
->n
.sym
->ts
;
3009 if (var
->n
.sym
->as
!= NULL
)
3011 e
->rank
= var
->n
.sym
->as
->rank
;
3012 e
->ref
= gfc_get_ref ();
3013 e
->ref
->type
= REF_ARRAY
;
3014 e
->ref
->u
.ar
.type
= AR_FULL
;
3021 /* General expression traversal function. */
3024 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3025 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3030 gfc_actual_arglist
*args
;
3037 if ((*func
) (expr
, sym
, &f
))
3040 if (expr
->ts
.type
== BT_CHARACTER
3042 && expr
->ts
.cl
->length
3043 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3044 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3047 switch (expr
->expr_type
)
3050 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3052 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3060 case EXPR_SUBSTRING
:
3063 case EXPR_STRUCTURE
:
3065 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3067 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3071 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3073 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3075 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3077 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3084 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3086 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3102 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3104 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3106 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3108 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3114 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3116 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3121 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3122 && ref
->u
.c
.component
->ts
.cl
3123 && ref
->u
.c
.component
->ts
.cl
->length
3124 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3126 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3130 if (ref
->u
.c
.component
->as
)
3131 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3133 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3136 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3150 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3153 expr_set_symbols_referenced (gfc_expr
*expr
,
3154 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3155 int *f ATTRIBUTE_UNUSED
)
3157 if (expr
->expr_type
!= EXPR_VARIABLE
)
3159 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3164 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3166 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);