1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #include "constructor.h"
32 /* The following set of functions provide access to gfc_expr* of
33 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35 There are two functions available elsewhere that provide
36 slightly different flavours of variables. Namely:
37 expr.c (gfc_get_variable_expr)
38 symbol.c (gfc_lval_expr_from_sym)
39 TODO: Merge these functions, if possible. */
41 /* Get a new expression node. */
49 gfc_clear_ts (&e
->ts
);
57 /* Get a new expression node that is an array constructor
58 of given type and kind. */
61 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
66 e
->expr_type
= EXPR_ARRAY
;
67 e
->value
.constructor
= NULL
;
80 /* Get a new expression node that is the NULL expression. */
83 gfc_get_null_expr (locus
*where
)
88 e
->expr_type
= EXPR_NULL
;
89 e
->ts
.type
= BT_UNKNOWN
;
98 /* Get a new expression node that is an operator expression node. */
101 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
102 gfc_expr
*op1
, gfc_expr
*op2
)
107 e
->expr_type
= EXPR_OP
;
109 e
->value
.op
.op1
= op1
;
110 e
->value
.op
.op2
= op2
;
119 /* Get a new expression node that is an structure constructor
120 of given type and kind. */
123 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
128 e
->expr_type
= EXPR_STRUCTURE
;
129 e
->value
.constructor
= NULL
;
140 /* Get a new expression node that is an constant of given type and kind. */
143 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
148 gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
152 e
->expr_type
= EXPR_CONSTANT
;
160 mpz_init (e
->value
.integer
);
164 gfc_set_model_kind (kind
);
165 mpfr_init (e
->value
.real
);
169 gfc_set_model_kind (kind
);
170 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
181 /* Get a new expression node that is an string constant.
182 If no string is passed, a string of len is allocated,
183 blanked and null-terminated. */
186 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, int len
)
193 dest
= gfc_get_wide_string (len
+ 1);
194 gfc_wide_memset (dest
, ' ', len
);
198 dest
= gfc_char_to_widechar (src
);
200 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
201 where
? where
: &gfc_current_locus
);
202 e
->value
.character
.string
= dest
;
203 e
->value
.character
.length
= len
;
209 /* Get a new expression node that is an integer constant. */
212 gfc_get_int_expr (int kind
, locus
*where
, int value
)
215 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
216 where
? where
: &gfc_current_locus
);
218 mpz_set_si (p
->value
.integer
, value
);
224 /* Get a new expression node that is a logical constant. */
227 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
230 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
231 where
? where
: &gfc_current_locus
);
233 p
->value
.logical
= value
;
240 gfc_get_iokind_expr (locus
*where
, io_kind k
)
244 /* Set the types to something compatible with iokind. This is needed to
245 get through gfc_free_expr later since iokind really has no Basic Type,
249 e
->expr_type
= EXPR_CONSTANT
;
250 e
->ts
.type
= BT_LOGICAL
;
258 /* Given an expression pointer, return a copy of the expression. This
259 subroutine is recursive. */
262 gfc_copy_expr (gfc_expr
*p
)
274 switch (q
->expr_type
)
277 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
278 q
->value
.character
.string
= s
;
279 memcpy (s
, p
->value
.character
.string
,
280 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
284 /* Copy target representation, if it exists. */
285 if (p
->representation
.string
)
287 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
288 q
->representation
.string
= c
;
289 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
292 /* Copy the values of any pointer components of p->value. */
296 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
300 gfc_set_model_kind (q
->ts
.kind
);
301 mpfr_init (q
->value
.real
);
302 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
306 gfc_set_model_kind (q
->ts
.kind
);
307 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
308 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
312 if (p
->representation
.string
)
313 q
->value
.character
.string
314 = gfc_char_to_widechar (q
->representation
.string
);
317 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
318 q
->value
.character
.string
= s
;
320 /* This is the case for the C_NULL_CHAR named constant. */
321 if (p
->value
.character
.length
== 0
322 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
325 /* Need to set the length to 1 to make sure the NUL
326 terminator is copied. */
327 q
->value
.character
.length
= 1;
330 memcpy (s
, p
->value
.character
.string
,
331 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
339 break; /* Already done. */
343 /* Should never be reached. */
345 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
352 switch (q
->value
.op
.op
)
355 case INTRINSIC_PARENTHESES
:
356 case INTRINSIC_UPLUS
:
357 case INTRINSIC_UMINUS
:
358 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
361 default: /* Binary operators. */
362 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
363 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
370 q
->value
.function
.actual
=
371 gfc_copy_actual_arglist (p
->value
.function
.actual
);
376 q
->value
.compcall
.actual
=
377 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
378 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
383 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
391 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
393 q
->ref
= gfc_copy_ref (p
->ref
);
400 gfc_clear_shape (mpz_t
*shape
, int rank
)
404 for (i
= 0; i
< rank
; i
++)
405 mpz_clear (shape
[i
]);
410 gfc_free_shape (mpz_t
**shape
, int rank
)
412 gfc_clear_shape (*shape
, rank
);
418 /* Workhorse function for gfc_free_expr() that frees everything
419 beneath an expression node, but not the node itself. This is
420 useful when we want to simplify a node and replace it with
421 something else or the expression node belongs to another structure. */
424 free_expr0 (gfc_expr
*e
)
426 switch (e
->expr_type
)
429 /* Free any parts of the value that need freeing. */
433 mpz_clear (e
->value
.integer
);
437 mpfr_clear (e
->value
.real
);
441 free (e
->value
.character
.string
);
445 mpc_clear (e
->value
.complex);
452 /* Free the representation. */
453 free (e
->representation
.string
);
458 if (e
->value
.op
.op1
!= NULL
)
459 gfc_free_expr (e
->value
.op
.op1
);
460 if (e
->value
.op
.op2
!= NULL
)
461 gfc_free_expr (e
->value
.op
.op2
);
465 gfc_free_actual_arglist (e
->value
.function
.actual
);
470 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
478 gfc_constructor_free (e
->value
.constructor
);
482 free (e
->value
.character
.string
);
489 gfc_internal_error ("free_expr0(): Bad expr type");
492 /* Free a shape array. */
493 if (e
->shape
!= NULL
)
494 gfc_free_shape (&e
->shape
, e
->rank
);
496 gfc_free_ref_list (e
->ref
);
498 memset (e
, '\0', sizeof (gfc_expr
));
502 /* Free an expression node and everything beneath it. */
505 gfc_free_expr (gfc_expr
*e
)
514 /* Free an argument list and everything below it. */
517 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
519 gfc_actual_arglist
*a2
;
524 gfc_free_expr (a1
->expr
);
531 /* Copy an arglist structure and all of the arguments. */
534 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
536 gfc_actual_arglist
*head
, *tail
, *new_arg
;
540 for (; p
; p
= p
->next
)
542 new_arg
= gfc_get_actual_arglist ();
545 new_arg
->expr
= gfc_copy_expr (p
->expr
);
546 new_arg
->next
= NULL
;
551 tail
->next
= new_arg
;
560 /* Free a list of reference structures. */
563 gfc_free_ref_list (gfc_ref
*p
)
575 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
577 gfc_free_expr (p
->u
.ar
.start
[i
]);
578 gfc_free_expr (p
->u
.ar
.end
[i
]);
579 gfc_free_expr (p
->u
.ar
.stride
[i
]);
585 gfc_free_expr (p
->u
.ss
.start
);
586 gfc_free_expr (p
->u
.ss
.end
);
598 /* Graft the *src expression onto the *dest subexpression. */
601 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
609 /* Try to extract an integer constant from the passed expression node.
610 Returns an error message or NULL if the result is set. It is
611 tempting to generate an error and return SUCCESS or FAILURE, but
612 failure is OK for some callers. */
615 gfc_extract_int (gfc_expr
*expr
, int *result
)
617 if (expr
->expr_type
!= EXPR_CONSTANT
)
618 return _("Constant expression required at %C");
620 if (expr
->ts
.type
!= BT_INTEGER
)
621 return _("Integer expression required at %C");
623 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
624 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
626 return _("Integer value too large in expression at %C");
629 *result
= (int) mpz_get_si (expr
->value
.integer
);
635 /* Recursively copy a list of reference structures. */
638 gfc_copy_ref (gfc_ref
*src
)
646 dest
= gfc_get_ref ();
647 dest
->type
= src
->type
;
652 ar
= gfc_copy_array_ref (&src
->u
.ar
);
658 dest
->u
.c
= src
->u
.c
;
662 dest
->u
.ss
= src
->u
.ss
;
663 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
664 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
668 dest
->next
= gfc_copy_ref (src
->next
);
674 /* Detect whether an expression has any vector index array references. */
677 gfc_has_vector_index (gfc_expr
*e
)
681 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
682 if (ref
->type
== REF_ARRAY
)
683 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
684 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
690 /* Copy a shape array. */
693 gfc_copy_shape (mpz_t
*shape
, int rank
)
701 new_shape
= gfc_get_shape (rank
);
703 for (n
= 0; n
< rank
; n
++)
704 mpz_init_set (new_shape
[n
], shape
[n
]);
710 /* Copy a shape array excluding dimension N, where N is an integer
711 constant expression. Dimensions are numbered in fortran style --
714 So, if the original shape array contains R elements
715 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
716 the result contains R-1 elements:
717 { s1 ... sN-1 sN+1 ... sR-1}
719 If anything goes wrong -- N is not a constant, its value is out
720 of range -- or anything else, just returns NULL. */
723 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
725 mpz_t
*new_shape
, *s
;
731 || dim
->expr_type
!= EXPR_CONSTANT
732 || dim
->ts
.type
!= BT_INTEGER
)
735 n
= mpz_get_si (dim
->value
.integer
);
736 n
--; /* Convert to zero based index. */
737 if (n
< 0 || n
>= rank
)
740 s
= new_shape
= gfc_get_shape (rank
- 1);
742 for (i
= 0; i
< rank
; i
++)
746 mpz_init_set (*s
, shape
[i
]);
754 /* Return the maximum kind of two expressions. In general, higher
755 kind numbers mean more precision for numeric types. */
758 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
760 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
764 /* Returns nonzero if the type is numeric, zero otherwise. */
767 numeric_type (bt type
)
769 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
773 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
776 gfc_numeric_ts (gfc_typespec
*ts
)
778 return numeric_type (ts
->type
);
782 /* Return an expression node with an optional argument list attached.
783 A variable number of gfc_expr pointers are strung together in an
784 argument list with a NULL pointer terminating the list. */
787 gfc_build_conversion (gfc_expr
*e
)
792 p
->expr_type
= EXPR_FUNCTION
;
794 p
->value
.function
.actual
= NULL
;
796 p
->value
.function
.actual
= gfc_get_actual_arglist ();
797 p
->value
.function
.actual
->expr
= e
;
803 /* Given an expression node with some sort of numeric binary
804 expression, insert type conversions required to make the operands
805 have the same type. Conversion warnings are disabled if wconversion
808 The exception is that the operands of an exponential don't have to
809 have the same type. If possible, the base is promoted to the type
810 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
811 1.0**2 stays as it is. */
814 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
818 op1
= e
->value
.op
.op1
;
819 op2
= e
->value
.op
.op2
;
821 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
823 gfc_clear_ts (&e
->ts
);
827 /* Kind conversions of same type. */
828 if (op1
->ts
.type
== op2
->ts
.type
)
830 if (op1
->ts
.kind
== op2
->ts
.kind
)
832 /* No type conversions. */
837 if (op1
->ts
.kind
> op2
->ts
.kind
)
838 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
840 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
846 /* Integer combined with real or complex. */
847 if (op2
->ts
.type
== BT_INTEGER
)
851 /* Special case for ** operator. */
852 if (e
->value
.op
.op
== INTRINSIC_POWER
)
855 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
859 if (op1
->ts
.type
== BT_INTEGER
)
862 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
866 /* Real combined with complex. */
867 e
->ts
.type
= BT_COMPLEX
;
868 if (op1
->ts
.kind
> op2
->ts
.kind
)
869 e
->ts
.kind
= op1
->ts
.kind
;
871 e
->ts
.kind
= op2
->ts
.kind
;
872 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
873 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
874 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
875 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
882 /* Function to determine if an expression is constant or not. This
883 function expects that the expression has already been simplified. */
886 gfc_is_constant_expr (gfc_expr
*e
)
889 gfc_actual_arglist
*arg
;
895 switch (e
->expr_type
)
898 return (gfc_is_constant_expr (e
->value
.op
.op1
)
899 && (e
->value
.op
.op2
== NULL
900 || gfc_is_constant_expr (e
->value
.op
.op2
)));
908 gcc_assert (e
->symtree
|| e
->value
.function
.esym
909 || e
->value
.function
.isym
);
911 /* Call to intrinsic with at least one argument. */
912 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
914 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
915 if (!gfc_is_constant_expr (arg
->expr
))
919 /* Specification functions are constant. */
920 /* F95, 7.1.6.2; F2003, 7.1.7 */
923 sym
= e
->symtree
->n
.sym
;
924 if (e
->value
.function
.esym
)
925 sym
= e
->value
.function
.esym
;
928 && sym
->attr
.function
930 && !sym
->attr
.intrinsic
931 && !sym
->attr
.recursive
932 && sym
->attr
.proc
!= PROC_INTERNAL
933 && sym
->attr
.proc
!= PROC_ST_FUNCTION
934 && sym
->attr
.proc
!= PROC_UNKNOWN
935 && sym
->formal
== NULL
)
938 if (e
->value
.function
.isym
939 && (e
->value
.function
.isym
->elemental
940 || e
->value
.function
.isym
->pure
941 || e
->value
.function
.isym
->inquiry
942 || e
->value
.function
.isym
->transformational
))
952 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
953 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
957 c
= gfc_constructor_first (e
->value
.constructor
);
958 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
959 return gfc_constant_ac (e
);
961 for (; c
; c
= gfc_constructor_next (c
))
962 if (!gfc_is_constant_expr (c
->expr
))
969 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
975 /* Is true if an array reference is followed by a component or substring
978 is_subref_array (gfc_expr
* e
)
983 if (e
->expr_type
!= EXPR_VARIABLE
)
986 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
990 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
992 if (ref
->type
== REF_ARRAY
993 && ref
->u
.ar
.type
!= AR_ELEMENT
)
997 && ref
->type
!= REF_ARRAY
)
1004 /* Try to collapse intrinsic expressions. */
1007 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1009 gfc_intrinsic_op op
;
1010 gfc_expr
*op1
, *op2
, *result
;
1012 if (p
->value
.op
.op
== INTRINSIC_USER
)
1015 op1
= p
->value
.op
.op1
;
1016 op2
= p
->value
.op
.op2
;
1017 op
= p
->value
.op
.op
;
1019 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1021 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1024 if (!gfc_is_constant_expr (op1
)
1025 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1029 p
->value
.op
.op1
= NULL
;
1030 p
->value
.op
.op2
= NULL
;
1034 case INTRINSIC_PARENTHESES
:
1035 result
= gfc_parentheses (op1
);
1038 case INTRINSIC_UPLUS
:
1039 result
= gfc_uplus (op1
);
1042 case INTRINSIC_UMINUS
:
1043 result
= gfc_uminus (op1
);
1046 case INTRINSIC_PLUS
:
1047 result
= gfc_add (op1
, op2
);
1050 case INTRINSIC_MINUS
:
1051 result
= gfc_subtract (op1
, op2
);
1054 case INTRINSIC_TIMES
:
1055 result
= gfc_multiply (op1
, op2
);
1058 case INTRINSIC_DIVIDE
:
1059 result
= gfc_divide (op1
, op2
);
1062 case INTRINSIC_POWER
:
1063 result
= gfc_power (op1
, op2
);
1066 case INTRINSIC_CONCAT
:
1067 result
= gfc_concat (op1
, op2
);
1071 case INTRINSIC_EQ_OS
:
1072 result
= gfc_eq (op1
, op2
, op
);
1076 case INTRINSIC_NE_OS
:
1077 result
= gfc_ne (op1
, op2
, op
);
1081 case INTRINSIC_GT_OS
:
1082 result
= gfc_gt (op1
, op2
, op
);
1086 case INTRINSIC_GE_OS
:
1087 result
= gfc_ge (op1
, op2
, op
);
1091 case INTRINSIC_LT_OS
:
1092 result
= gfc_lt (op1
, op2
, op
);
1096 case INTRINSIC_LE_OS
:
1097 result
= gfc_le (op1
, op2
, op
);
1101 result
= gfc_not (op1
);
1105 result
= gfc_and (op1
, op2
);
1109 result
= gfc_or (op1
, op2
);
1113 result
= gfc_eqv (op1
, op2
);
1116 case INTRINSIC_NEQV
:
1117 result
= gfc_neqv (op1
, op2
);
1121 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1126 gfc_free_expr (op1
);
1127 gfc_free_expr (op2
);
1131 result
->rank
= p
->rank
;
1132 result
->where
= p
->where
;
1133 gfc_replace_expr (p
, result
);
1139 /* Subroutine to simplify constructor expressions. Mutually recursive
1140 with gfc_simplify_expr(). */
1143 simplify_constructor (gfc_constructor_base base
, int type
)
1148 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1151 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1152 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1153 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1158 /* Try and simplify a copy. Replace the original if successful
1159 but keep going through the constructor at all costs. Not
1160 doing so can make a dog's dinner of complicated things. */
1161 p
= gfc_copy_expr (c
->expr
);
1163 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1169 gfc_replace_expr (c
->expr
, p
);
1177 /* Pull a single array element out of an array constructor. */
1180 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1181 gfc_constructor
**rval
)
1183 unsigned long nelemen
;
1189 gfc_constructor
*cons
;
1196 mpz_init_set_ui (offset
, 0);
1199 mpz_init_set_ui (span
, 1);
1200 for (i
= 0; i
< ar
->dimen
; i
++)
1202 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1203 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1210 e
= gfc_copy_expr (ar
->start
[i
]);
1211 if (e
->expr_type
!= EXPR_CONSTANT
)
1217 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1218 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1220 /* Check the bounds. */
1221 if ((ar
->as
->upper
[i
]
1222 && mpz_cmp (e
->value
.integer
,
1223 ar
->as
->upper
[i
]->value
.integer
) > 0)
1224 || (mpz_cmp (e
->value
.integer
,
1225 ar
->as
->lower
[i
]->value
.integer
) < 0))
1227 gfc_error ("Index in dimension %d is out of bounds "
1228 "at %L", i
+ 1, &ar
->c_where
[i
]);
1234 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1235 mpz_mul (delta
, delta
, span
);
1236 mpz_add (offset
, offset
, delta
);
1238 mpz_set_ui (tmp
, 1);
1239 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1240 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1241 mpz_mul (span
, span
, tmp
);
1244 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1245 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1266 /* Find a component of a structure constructor. */
1268 static gfc_constructor
*
1269 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1271 gfc_component
*comp
;
1272 gfc_component
*pick
;
1273 gfc_constructor
*c
= gfc_constructor_first (base
);
1275 comp
= ref
->u
.c
.sym
->components
;
1276 pick
= ref
->u
.c
.component
;
1277 while (comp
!= pick
)
1280 c
= gfc_constructor_next (c
);
1287 /* Replace an expression with the contents of a constructor, removing
1288 the subobject reference in the process. */
1291 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1301 e
= gfc_copy_expr (p
);
1302 e
->ref
= p
->ref
->next
;
1303 p
->ref
->next
= NULL
;
1304 gfc_replace_expr (p
, e
);
1308 /* Pull an array section out of an array constructor. */
1311 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1318 long unsigned one
= 1;
1320 mpz_t start
[GFC_MAX_DIMENSIONS
];
1321 mpz_t end
[GFC_MAX_DIMENSIONS
];
1322 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1323 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1324 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1329 gfc_constructor_base base
;
1330 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1340 base
= expr
->value
.constructor
;
1341 expr
->value
.constructor
= NULL
;
1343 rank
= ref
->u
.ar
.as
->rank
;
1345 if (expr
->shape
== NULL
)
1346 expr
->shape
= gfc_get_shape (rank
);
1348 mpz_init_set_ui (delta_mpz
, one
);
1349 mpz_init_set_ui (nelts
, one
);
1352 /* Do the initialization now, so that we can cleanup without
1353 keeping track of where we were. */
1354 for (d
= 0; d
< rank
; d
++)
1356 mpz_init (delta
[d
]);
1357 mpz_init (start
[d
]);
1360 mpz_init (stride
[d
]);
1364 /* Build the counters to clock through the array reference. */
1366 for (d
= 0; d
< rank
; d
++)
1368 /* Make this stretch of code easier on the eye! */
1369 begin
= ref
->u
.ar
.start
[d
];
1370 finish
= ref
->u
.ar
.end
[d
];
1371 step
= ref
->u
.ar
.stride
[d
];
1372 lower
= ref
->u
.ar
.as
->lower
[d
];
1373 upper
= ref
->u
.ar
.as
->upper
[d
];
1375 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1377 gfc_constructor
*ci
;
1380 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1386 gcc_assert (begin
->rank
== 1);
1387 /* Zero-sized arrays have no shape and no elements, stop early. */
1390 mpz_init_set_ui (nelts
, 0);
1394 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1395 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1396 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1397 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1400 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1402 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1403 || mpz_cmp (ci
->expr
->value
.integer
,
1404 lower
->value
.integer
) < 0)
1406 gfc_error ("index in dimension %d is out of bounds "
1407 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1415 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1416 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1417 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1423 /* Obtain the stride. */
1425 mpz_set (stride
[d
], step
->value
.integer
);
1427 mpz_set_ui (stride
[d
], one
);
1429 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1430 mpz_set_ui (stride
[d
], one
);
1432 /* Obtain the start value for the index. */
1434 mpz_set (start
[d
], begin
->value
.integer
);
1436 mpz_set (start
[d
], lower
->value
.integer
);
1438 mpz_set (ctr
[d
], start
[d
]);
1440 /* Obtain the end value for the index. */
1442 mpz_set (end
[d
], finish
->value
.integer
);
1444 mpz_set (end
[d
], upper
->value
.integer
);
1446 /* Separate 'if' because elements sometimes arrive with
1448 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1449 mpz_set (end
[d
], begin
->value
.integer
);
1451 /* Check the bounds. */
1452 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1453 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1454 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1455 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1457 gfc_error ("index in dimension %d is out of bounds "
1458 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1463 /* Calculate the number of elements and the shape. */
1464 mpz_set (tmp_mpz
, stride
[d
]);
1465 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1466 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1467 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1468 mpz_mul (nelts
, nelts
, tmp_mpz
);
1470 /* An element reference reduces the rank of the expression; don't
1471 add anything to the shape array. */
1472 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1473 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1476 /* Calculate the 'stride' (=delta) for conversion of the
1477 counter values into the index along the constructor. */
1478 mpz_set (delta
[d
], delta_mpz
);
1479 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1480 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1481 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1485 cons
= gfc_constructor_first (base
);
1487 /* Now clock through the array reference, calculating the index in
1488 the source constructor and transferring the elements to the new
1490 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1492 if (ref
->u
.ar
.offset
)
1493 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1495 mpz_init_set_ui (ptr
, 0);
1498 for (d
= 0; d
< rank
; d
++)
1500 mpz_set (tmp_mpz
, ctr
[d
]);
1501 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1502 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1503 mpz_add (ptr
, ptr
, tmp_mpz
);
1505 if (!incr_ctr
) continue;
1507 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1509 gcc_assert(vecsub
[d
]);
1511 if (!gfc_constructor_next (vecsub
[d
]))
1512 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1515 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1518 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1522 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1524 if (mpz_cmp_ui (stride
[d
], 0) > 0
1525 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1526 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1527 mpz_set (ctr
[d
], start
[d
]);
1533 limit
= mpz_get_ui (ptr
);
1534 if (limit
>= gfc_option
.flag_max_array_constructor
)
1536 gfc_error ("The number of elements in the array constructor "
1537 "at %L requires an increase of the allowed %d "
1538 "upper limit. See -fmax-array-constructor "
1539 "option", &expr
->where
,
1540 gfc_option
.flag_max_array_constructor
);
1544 cons
= gfc_constructor_lookup (base
, limit
);
1546 gfc_constructor_append_expr (&expr
->value
.constructor
,
1547 gfc_copy_expr (cons
->expr
), NULL
);
1554 mpz_clear (delta_mpz
);
1555 mpz_clear (tmp_mpz
);
1557 for (d
= 0; d
< rank
; d
++)
1559 mpz_clear (delta
[d
]);
1560 mpz_clear (start
[d
]);
1563 mpz_clear (stride
[d
]);
1565 gfc_constructor_free (base
);
1569 /* Pull a substring out of an expression. */
1572 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1579 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1580 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1583 *newp
= gfc_copy_expr (p
);
1584 free ((*newp
)->value
.character
.string
);
1586 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1587 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1588 length
= end
- start
+ 1;
1590 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1591 (*newp
)->value
.character
.length
= length
;
1592 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1593 length
* sizeof (gfc_char_t
));
1600 /* Simplify a subobject reference of a constructor. This occurs when
1601 parameter variable values are substituted. */
1604 simplify_const_ref (gfc_expr
*p
)
1606 gfc_constructor
*cons
, *c
;
1612 switch (p
->ref
->type
)
1615 switch (p
->ref
->u
.ar
.type
)
1618 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1619 will generate this. */
1620 if (p
->expr_type
!= EXPR_ARRAY
)
1622 remove_subobject_ref (p
, NULL
);
1625 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1632 remove_subobject_ref (p
, cons
);
1636 if (find_array_section (p
, p
->ref
) == FAILURE
)
1638 p
->ref
->u
.ar
.type
= AR_FULL
;
1643 if (p
->ref
->next
!= NULL
1644 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1646 for (c
= gfc_constructor_first (p
->value
.constructor
);
1647 c
; c
= gfc_constructor_next (c
))
1649 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1650 if (simplify_const_ref (c
->expr
) == FAILURE
)
1654 if (p
->ts
.type
== BT_DERIVED
1656 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1658 /* There may have been component references. */
1659 p
->ts
= c
->expr
->ts
;
1663 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1665 if (p
->ts
.type
== BT_CHARACTER
1666 && last_ref
->type
== REF_SUBSTRING
)
1668 /* If this is a CHARACTER array and we possibly took
1669 a substring out of it, update the type-spec's
1670 character length according to the first element
1671 (as all should have the same length). */
1673 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1675 const gfc_expr
* first
= c
->expr
;
1676 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1677 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1678 string_len
= first
->value
.character
.length
;
1684 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1687 gfc_free_expr (p
->ts
.u
.cl
->length
);
1690 = gfc_get_int_expr (gfc_default_integer_kind
,
1694 gfc_free_ref_list (p
->ref
);
1705 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1706 remove_subobject_ref (p
, cons
);
1710 if (find_substring_ref (p
, &newp
) == FAILURE
)
1713 gfc_replace_expr (p
, newp
);
1714 gfc_free_ref_list (p
->ref
);
1724 /* Simplify a chain of references. */
1727 simplify_ref_chain (gfc_ref
*ref
, int type
)
1731 for (; ref
; ref
= ref
->next
)
1736 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1738 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1740 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1742 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1748 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1750 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1762 /* Try to substitute the value of a parameter variable. */
1765 simplify_parameter_variable (gfc_expr
*p
, int type
)
1770 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1776 /* Do not copy subobject refs for constant. */
1777 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1778 e
->ref
= gfc_copy_ref (p
->ref
);
1779 t
= gfc_simplify_expr (e
, type
);
1781 /* Only use the simplification if it eliminated all subobject references. */
1782 if (t
== SUCCESS
&& !e
->ref
)
1783 gfc_replace_expr (p
, e
);
1790 /* Given an expression, simplify it by collapsing constant
1791 expressions. Most simplification takes place when the expression
1792 tree is being constructed. If an intrinsic function is simplified
1793 at some point, we get called again to collapse the result against
1796 We work by recursively simplifying expression nodes, simplifying
1797 intrinsic functions where possible, which can lead to further
1798 constant collapsing. If an operator has constant operand(s), we
1799 rip the expression apart, and rebuild it, hoping that it becomes
1802 The expression type is defined for:
1803 0 Basic expression parsing
1804 1 Simplifying array constructors -- will substitute
1806 Returns FAILURE on error, SUCCESS otherwise.
1807 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1810 gfc_simplify_expr (gfc_expr
*p
, int type
)
1812 gfc_actual_arglist
*ap
;
1817 switch (p
->expr_type
)
1824 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1825 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1828 if (p
->value
.function
.isym
!= NULL
1829 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1834 case EXPR_SUBSTRING
:
1835 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1838 if (gfc_is_constant_expr (p
))
1844 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1846 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1847 start
--; /* Convert from one-based to zero-based. */
1850 end
= p
->value
.character
.length
;
1851 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1852 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1857 s
= gfc_get_wide_string (end
- start
+ 2);
1858 memcpy (s
, p
->value
.character
.string
+ start
,
1859 (end
- start
) * sizeof (gfc_char_t
));
1860 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1861 free (p
->value
.character
.string
);
1862 p
->value
.character
.string
= s
;
1863 p
->value
.character
.length
= end
- start
;
1864 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1865 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1867 p
->value
.character
.length
);
1868 gfc_free_ref_list (p
->ref
);
1870 p
->expr_type
= EXPR_CONSTANT
;
1875 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1880 /* Only substitute array parameter variables if we are in an
1881 initialization expression, or we want a subsection. */
1882 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1883 && (gfc_init_expr_flag
|| p
->ref
1884 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1886 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1893 gfc_simplify_iterator_var (p
);
1896 /* Simplify subcomponent references. */
1897 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1902 case EXPR_STRUCTURE
:
1904 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1907 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1910 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1911 && p
->ref
->u
.ar
.type
== AR_FULL
)
1912 gfc_expand_constructor (p
, false);
1914 if (simplify_const_ref (p
) == FAILURE
)
1929 /* Returns the type of an expression with the exception that iterator
1930 variables are automatically integers no matter what else they may
1936 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1943 /* Check an intrinsic arithmetic operation to see if it is consistent
1944 with some type of expression. */
1946 static gfc_try
check_init_expr (gfc_expr
*);
1949 /* Scalarize an expression for an elemental intrinsic call. */
1952 scalarize_intrinsic_call (gfc_expr
*e
)
1954 gfc_actual_arglist
*a
, *b
;
1955 gfc_constructor_base ctor
;
1956 gfc_constructor
*args
[5];
1957 gfc_constructor
*ci
, *new_ctor
;
1958 gfc_expr
*expr
, *old
;
1959 int n
, i
, rank
[5], array_arg
;
1961 /* Find which, if any, arguments are arrays. Assume that the old
1962 expression carries the type information and that the first arg
1963 that is an array expression carries all the shape information.*/
1965 a
= e
->value
.function
.actual
;
1966 for (; a
; a
= a
->next
)
1969 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1972 expr
= gfc_copy_expr (a
->expr
);
1979 old
= gfc_copy_expr (e
);
1981 gfc_constructor_free (expr
->value
.constructor
);
1982 expr
->value
.constructor
= NULL
;
1984 expr
->where
= old
->where
;
1985 expr
->expr_type
= EXPR_ARRAY
;
1987 /* Copy the array argument constructors into an array, with nulls
1990 a
= old
->value
.function
.actual
;
1991 for (; a
; a
= a
->next
)
1993 /* Check that this is OK for an initialization expression. */
1994 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1998 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2000 rank
[n
] = a
->expr
->rank
;
2001 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2002 args
[n
] = gfc_constructor_first (ctor
);
2004 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2007 rank
[n
] = a
->expr
->rank
;
2010 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2011 args
[n
] = gfc_constructor_first (ctor
);
2020 /* Using the array argument as the master, step through the array
2021 calling the function for each element and advancing the array
2022 constructors together. */
2023 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2025 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2026 gfc_copy_expr (old
), NULL
);
2028 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2030 b
= old
->value
.function
.actual
;
2031 for (i
= 0; i
< n
; i
++)
2034 new_ctor
->expr
->value
.function
.actual
2035 = a
= gfc_get_actual_arglist ();
2038 a
->next
= gfc_get_actual_arglist ();
2043 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2045 a
->expr
= gfc_copy_expr (b
->expr
);
2050 /* Simplify the function calls. If the simplification fails, the
2051 error will be flagged up down-stream or the library will deal
2053 gfc_simplify_expr (new_ctor
->expr
, 0);
2055 for (i
= 0; i
< n
; i
++)
2057 args
[i
] = gfc_constructor_next (args
[i
]);
2059 for (i
= 1; i
< n
; i
++)
2060 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2061 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2067 gfc_free_expr (old
);
2071 gfc_error_now ("elemental function arguments at %C are not compliant");
2074 gfc_free_expr (expr
);
2075 gfc_free_expr (old
);
2081 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2083 gfc_expr
*op1
= e
->value
.op
.op1
;
2084 gfc_expr
*op2
= e
->value
.op
.op2
;
2086 if ((*check_function
) (op1
) == FAILURE
)
2089 switch (e
->value
.op
.op
)
2091 case INTRINSIC_UPLUS
:
2092 case INTRINSIC_UMINUS
:
2093 if (!numeric_type (et0 (op1
)))
2098 case INTRINSIC_EQ_OS
:
2100 case INTRINSIC_NE_OS
:
2102 case INTRINSIC_GT_OS
:
2104 case INTRINSIC_GE_OS
:
2106 case INTRINSIC_LT_OS
:
2108 case INTRINSIC_LE_OS
:
2109 if ((*check_function
) (op2
) == FAILURE
)
2112 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2113 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2115 gfc_error ("Numeric or CHARACTER operands are required in "
2116 "expression at %L", &e
->where
);
2121 case INTRINSIC_PLUS
:
2122 case INTRINSIC_MINUS
:
2123 case INTRINSIC_TIMES
:
2124 case INTRINSIC_DIVIDE
:
2125 case INTRINSIC_POWER
:
2126 if ((*check_function
) (op2
) == FAILURE
)
2129 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2134 case INTRINSIC_CONCAT
:
2135 if ((*check_function
) (op2
) == FAILURE
)
2138 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2140 gfc_error ("Concatenation operator in expression at %L "
2141 "must have two CHARACTER operands", &op1
->where
);
2145 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2147 gfc_error ("Concat operator at %L must concatenate strings of the "
2148 "same kind", &e
->where
);
2155 if (et0 (op1
) != BT_LOGICAL
)
2157 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2158 "operand", &op1
->where
);
2167 case INTRINSIC_NEQV
:
2168 if ((*check_function
) (op2
) == FAILURE
)
2171 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2173 gfc_error ("LOGICAL operands are required in expression at %L",
2180 case INTRINSIC_PARENTHESES
:
2184 gfc_error ("Only intrinsic operators can be used in expression at %L",
2192 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2197 /* F2003, 7.1.7 (3): In init expression, allocatable components
2198 must not be data-initialized. */
2200 check_alloc_comp_init (gfc_expr
*e
)
2202 gfc_component
*comp
;
2203 gfc_constructor
*ctor
;
2205 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2206 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2208 for (comp
= e
->ts
.u
.derived
->components
,
2209 ctor
= gfc_constructor_first (e
->value
.constructor
);
2210 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2212 if (comp
->attr
.allocatable
2213 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2215 gfc_error("Invalid initialization expression for ALLOCATABLE "
2216 "component '%s' in structure constructor at %L",
2217 comp
->name
, &ctor
->expr
->where
);
2226 check_init_expr_arguments (gfc_expr
*e
)
2228 gfc_actual_arglist
*ap
;
2230 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2231 if (check_init_expr (ap
->expr
) == FAILURE
)
2237 static gfc_try
check_restricted (gfc_expr
*);
2239 /* F95, 7.1.6.1, Initialization expressions, (7)
2240 F2003, 7.1.7 Initialization expression, (8) */
2243 check_inquiry (gfc_expr
*e
, int not_restricted
)
2246 const char *const *functions
;
2248 static const char *const inquiry_func_f95
[] = {
2249 "lbound", "shape", "size", "ubound",
2250 "bit_size", "len", "kind",
2251 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2252 "precision", "radix", "range", "tiny",
2256 static const char *const inquiry_func_f2003
[] = {
2257 "lbound", "shape", "size", "ubound",
2258 "bit_size", "len", "kind",
2259 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2260 "precision", "radix", "range", "tiny",
2265 gfc_actual_arglist
*ap
;
2267 if (!e
->value
.function
.isym
2268 || !e
->value
.function
.isym
->inquiry
)
2271 /* An undeclared parameter will get us here (PR25018). */
2272 if (e
->symtree
== NULL
)
2275 name
= e
->symtree
->n
.sym
->name
;
2277 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2278 ? inquiry_func_f2003
: inquiry_func_f95
;
2280 for (i
= 0; functions
[i
]; i
++)
2281 if (strcmp (functions
[i
], name
) == 0)
2284 if (functions
[i
] == NULL
)
2287 /* At this point we have an inquiry function with a variable argument. The
2288 type of the variable might be undefined, but we need it now, because the
2289 arguments of these functions are not allowed to be undefined. */
2291 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2296 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2298 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2299 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2303 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2306 /* Assumed character length will not reduce to a constant expression
2307 with LEN, as required by the standard. */
2308 if (i
== 5 && not_restricted
2309 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2310 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2311 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2313 gfc_error ("Assumed or deferred character length variable '%s' "
2314 " in constant expression at %L",
2315 ap
->expr
->symtree
->n
.sym
->name
,
2319 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2322 if (not_restricted
== 0
2323 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2324 && check_restricted (ap
->expr
) == FAILURE
)
2327 if (not_restricted
== 0
2328 && ap
->expr
->expr_type
== EXPR_VARIABLE
2329 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2330 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2338 /* F95, 7.1.6.1, Initialization expressions, (5)
2339 F2003, 7.1.7 Initialization expression, (5) */
2342 check_transformational (gfc_expr
*e
)
2344 static const char * const trans_func_f95
[] = {
2345 "repeat", "reshape", "selected_int_kind",
2346 "selected_real_kind", "transfer", "trim", NULL
2349 static const char * const trans_func_f2003
[] = {
2350 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2351 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2352 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2353 "trim", "unpack", NULL
2358 const char *const *functions
;
2360 if (!e
->value
.function
.isym
2361 || !e
->value
.function
.isym
->transformational
)
2364 name
= e
->symtree
->n
.sym
->name
;
2366 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2367 ? trans_func_f2003
: trans_func_f95
;
2369 /* NULL() is dealt with below. */
2370 if (strcmp ("null", name
) == 0)
2373 for (i
= 0; functions
[i
]; i
++)
2374 if (strcmp (functions
[i
], name
) == 0)
2377 if (functions
[i
] == NULL
)
2379 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2380 "in an initialization expression", name
, &e
->where
);
2384 return check_init_expr_arguments (e
);
2388 /* F95, 7.1.6.1, Initialization expressions, (6)
2389 F2003, 7.1.7 Initialization expression, (6) */
2392 check_null (gfc_expr
*e
)
2394 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2397 return check_init_expr_arguments (e
);
2402 check_elemental (gfc_expr
*e
)
2404 if (!e
->value
.function
.isym
2405 || !e
->value
.function
.isym
->elemental
)
2408 if (e
->ts
.type
!= BT_INTEGER
2409 && e
->ts
.type
!= BT_CHARACTER
2410 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2411 "nonstandard initialization expression at %L",
2412 &e
->where
) == FAILURE
)
2415 return check_init_expr_arguments (e
);
2420 check_conversion (gfc_expr
*e
)
2422 if (!e
->value
.function
.isym
2423 || !e
->value
.function
.isym
->conversion
)
2426 return check_init_expr_arguments (e
);
2430 /* Verify that an expression is an initialization expression. A side
2431 effect is that the expression tree is reduced to a single constant
2432 node if all goes well. This would normally happen when the
2433 expression is constructed but function references are assumed to be
2434 intrinsics in the context of initialization expressions. If
2435 FAILURE is returned an error message has been generated. */
2438 check_init_expr (gfc_expr
*e
)
2446 switch (e
->expr_type
)
2449 t
= check_intrinsic_op (e
, check_init_expr
);
2451 t
= gfc_simplify_expr (e
, 0);
2459 gfc_intrinsic_sym
* isym
;
2462 sym
= e
->symtree
->n
.sym
;
2463 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2464 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2466 gfc_error ("Function '%s' in initialization expression at %L "
2467 "must be an intrinsic function",
2468 e
->symtree
->n
.sym
->name
, &e
->where
);
2472 if ((m
= check_conversion (e
)) == MATCH_NO
2473 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2474 && (m
= check_null (e
)) == MATCH_NO
2475 && (m
= check_transformational (e
)) == MATCH_NO
2476 && (m
= check_elemental (e
)) == MATCH_NO
)
2478 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2479 "in an initialization expression",
2480 e
->symtree
->n
.sym
->name
, &e
->where
);
2484 if (m
== MATCH_ERROR
)
2487 /* Try to scalarize an elemental intrinsic function that has an
2489 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2490 if (isym
&& isym
->elemental
2491 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2496 t
= gfc_simplify_expr (e
, 0);
2503 if (gfc_check_iter_variable (e
) == SUCCESS
)
2506 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2508 /* A PARAMETER shall not be used to define itself, i.e.
2509 REAL, PARAMETER :: x = transfer(0, x)
2511 if (!e
->symtree
->n
.sym
->value
)
2513 gfc_error("PARAMETER '%s' is used at %L before its definition "
2514 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2518 t
= simplify_parameter_variable (e
, 0);
2523 if (gfc_in_match_data ())
2528 if (e
->symtree
->n
.sym
->as
)
2530 switch (e
->symtree
->n
.sym
->as
->type
)
2532 case AS_ASSUMED_SIZE
:
2533 gfc_error ("Assumed size array '%s' at %L is not permitted "
2534 "in an initialization expression",
2535 e
->symtree
->n
.sym
->name
, &e
->where
);
2538 case AS_ASSUMED_SHAPE
:
2539 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2540 "in an initialization expression",
2541 e
->symtree
->n
.sym
->name
, &e
->where
);
2545 gfc_error ("Deferred array '%s' at %L is not permitted "
2546 "in an initialization expression",
2547 e
->symtree
->n
.sym
->name
, &e
->where
);
2551 gfc_error ("Array '%s' at %L is a variable, which does "
2552 "not reduce to a constant expression",
2553 e
->symtree
->n
.sym
->name
, &e
->where
);
2561 gfc_error ("Parameter '%s' at %L has not been declared or is "
2562 "a variable, which does not reduce to a constant "
2563 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2572 case EXPR_SUBSTRING
:
2573 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2577 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2579 t
= gfc_simplify_expr (e
, 0);
2583 case EXPR_STRUCTURE
:
2584 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2588 t
= check_alloc_comp_init (e
);
2592 t
= gfc_check_constructor (e
, check_init_expr
);
2599 t
= gfc_check_constructor (e
, check_init_expr
);
2603 t
= gfc_expand_constructor (e
, true);
2607 t
= gfc_check_constructor_type (e
);
2611 gfc_internal_error ("check_init_expr(): Unknown expression type");
2617 /* Reduces a general expression to an initialization expression (a constant).
2618 This used to be part of gfc_match_init_expr.
2619 Note that this function doesn't free the given expression on FAILURE. */
2622 gfc_reduce_init_expr (gfc_expr
*expr
)
2626 gfc_init_expr_flag
= true;
2627 t
= gfc_resolve_expr (expr
);
2629 t
= check_init_expr (expr
);
2630 gfc_init_expr_flag
= false;
2635 if (expr
->expr_type
== EXPR_ARRAY
)
2637 if (gfc_check_constructor_type (expr
) == FAILURE
)
2639 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2647 /* Match an initialization expression. We work by first matching an
2648 expression, then reducing it to a constant. */
2651 gfc_match_init_expr (gfc_expr
**result
)
2659 gfc_init_expr_flag
= true;
2661 m
= gfc_match_expr (&expr
);
2664 gfc_init_expr_flag
= false;
2668 t
= gfc_reduce_init_expr (expr
);
2671 gfc_free_expr (expr
);
2672 gfc_init_expr_flag
= false;
2677 gfc_init_expr_flag
= false;
2683 /* Given an actual argument list, test to see that each argument is a
2684 restricted expression and optionally if the expression type is
2685 integer or character. */
2688 restricted_args (gfc_actual_arglist
*a
)
2690 for (; a
; a
= a
->next
)
2692 if (check_restricted (a
->expr
) == FAILURE
)
2700 /************* Restricted/specification expressions *************/
2703 /* Make sure a non-intrinsic function is a specification function. */
2706 external_spec_function (gfc_expr
*e
)
2710 f
= e
->value
.function
.esym
;
2712 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2714 gfc_error ("Specification function '%s' at %L cannot be a statement "
2715 "function", f
->name
, &e
->where
);
2719 if (f
->attr
.proc
== PROC_INTERNAL
)
2721 gfc_error ("Specification function '%s' at %L cannot be an internal "
2722 "function", f
->name
, &e
->where
);
2726 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2728 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2733 if (f
->attr
.recursive
)
2735 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2736 f
->name
, &e
->where
);
2740 return restricted_args (e
->value
.function
.actual
);
2744 /* Check to see that a function reference to an intrinsic is a
2745 restricted expression. */
2748 restricted_intrinsic (gfc_expr
*e
)
2750 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2751 if (check_inquiry (e
, 0) == MATCH_YES
)
2754 return restricted_args (e
->value
.function
.actual
);
2758 /* Check the expressions of an actual arglist. Used by check_restricted. */
2761 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2763 for (; arg
; arg
= arg
->next
)
2764 if (checker (arg
->expr
) == FAILURE
)
2771 /* Check the subscription expressions of a reference chain with a checking
2772 function; used by check_restricted. */
2775 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2785 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2787 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2789 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2791 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2797 /* Nothing needed, just proceed to next reference. */
2801 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2803 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2812 return check_references (ref
->next
, checker
);
2816 /* Verify that an expression is a restricted expression. Like its
2817 cousin check_init_expr(), an error message is generated if we
2821 check_restricted (gfc_expr
*e
)
2829 switch (e
->expr_type
)
2832 t
= check_intrinsic_op (e
, check_restricted
);
2834 t
= gfc_simplify_expr (e
, 0);
2839 if (e
->value
.function
.esym
)
2841 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2843 t
= external_spec_function (e
);
2847 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2850 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2853 t
= restricted_intrinsic (e
);
2858 sym
= e
->symtree
->n
.sym
;
2861 /* If a dummy argument appears in a context that is valid for a
2862 restricted expression in an elemental procedure, it will have
2863 already been simplified away once we get here. Therefore we
2864 don't need to jump through hoops to distinguish valid from
2866 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2867 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2869 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2870 sym
->name
, &e
->where
);
2874 if (sym
->attr
.optional
)
2876 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2877 sym
->name
, &e
->where
);
2881 if (sym
->attr
.intent
== INTENT_OUT
)
2883 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2884 sym
->name
, &e
->where
);
2888 /* Check reference chain if any. */
2889 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2892 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2893 processed in resolve.c(resolve_formal_arglist). This is done so
2894 that host associated dummy array indices are accepted (PR23446).
2895 This mechanism also does the same for the specification expressions
2896 of array-valued functions. */
2898 || sym
->attr
.in_common
2899 || sym
->attr
.use_assoc
2901 || sym
->attr
.implied_index
2902 || sym
->attr
.flavor
== FL_PARAMETER
2903 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2904 || (sym
->ns
&& gfc_current_ns
->parent
2905 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2906 || (sym
->ns
->proc_name
!= NULL
2907 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2908 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2914 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2915 sym
->name
, &e
->where
);
2916 /* Prevent a repetition of the error. */
2925 case EXPR_SUBSTRING
:
2926 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2930 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2932 t
= gfc_simplify_expr (e
, 0);
2936 case EXPR_STRUCTURE
:
2937 t
= gfc_check_constructor (e
, check_restricted
);
2941 t
= gfc_check_constructor (e
, check_restricted
);
2945 gfc_internal_error ("check_restricted(): Unknown expression type");
2952 /* Check to see that an expression is a specification expression. If
2953 we return FAILURE, an error has been generated. */
2956 gfc_specification_expr (gfc_expr
*e
)
2958 gfc_component
*comp
;
2963 if (e
->ts
.type
!= BT_INTEGER
)
2965 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2966 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2970 if (e
->expr_type
== EXPR_FUNCTION
2971 && !e
->value
.function
.isym
2972 && !e
->value
.function
.esym
2973 && !gfc_pure (e
->symtree
->n
.sym
)
2974 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2975 || !comp
->attr
.pure
))
2977 gfc_error ("Function '%s' at %L must be PURE",
2978 e
->symtree
->n
.sym
->name
, &e
->where
);
2979 /* Prevent repeat error messages. */
2980 e
->symtree
->n
.sym
->attr
.pure
= 1;
2986 gfc_error ("Expression at %L must be scalar", &e
->where
);
2990 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2993 return check_restricted (e
);
2997 /************** Expression conformance checks. *************/
2999 /* Given two expressions, make sure that the arrays are conformable. */
3002 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3004 int op1_flag
, op2_flag
, d
;
3005 mpz_t op1_size
, op2_size
;
3011 if (op1
->rank
== 0 || op2
->rank
== 0)
3014 va_start (argp
, optype_msgid
);
3015 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3018 if (op1
->rank
!= op2
->rank
)
3020 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3021 op1
->rank
, op2
->rank
, &op1
->where
);
3027 for (d
= 0; d
< op1
->rank
; d
++)
3029 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3030 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3032 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3034 gfc_error ("Different shape for %s at %L on dimension %d "
3035 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3036 (int) mpz_get_si (op1_size
),
3037 (int) mpz_get_si (op2_size
));
3043 mpz_clear (op1_size
);
3045 mpz_clear (op2_size
);
3055 /* Given an assignable expression and an arbitrary expression, make
3056 sure that the assignment can take place. */
3059 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3065 sym
= lvalue
->symtree
->n
.sym
;
3067 /* See if this is the component or subcomponent of a pointer. */
3068 has_pointer
= sym
->attr
.pointer
;
3069 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3070 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3076 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3077 variable local to a function subprogram. Its existence begins when
3078 execution of the function is initiated and ends when execution of the
3079 function is terminated...
3080 Therefore, the left hand side is no longer a variable, when it is: */
3081 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3082 && !sym
->attr
.external
)
3087 /* (i) Use associated; */
3088 if (sym
->attr
.use_assoc
)
3091 /* (ii) The assignment is in the main program; or */
3092 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3095 /* (iii) A module or internal procedure... */
3096 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3097 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3098 && gfc_current_ns
->parent
3099 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3100 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3101 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3103 /* ... that is not a function... */
3104 if (!gfc_current_ns
->proc_name
->attr
.function
)
3107 /* ... or is not an entry and has a different name. */
3108 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3112 /* (iv) Host associated and not the function symbol or the
3113 parent result. This picks up sibling references, which
3114 cannot be entries. */
3115 if (!sym
->attr
.entry
3116 && sym
->ns
== gfc_current_ns
->parent
3117 && sym
!= gfc_current_ns
->proc_name
3118 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3123 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3128 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3130 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3131 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3135 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3137 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3142 if (rvalue
->expr_type
== EXPR_NULL
)
3144 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3145 && lvalue
->symtree
->n
.sym
->attr
.data
)
3149 gfc_error ("NULL appears on right-hand side in assignment at %L",
3155 /* This is possibly a typo: x = f() instead of x => f(). */
3156 if (gfc_option
.warn_surprising
3157 && rvalue
->expr_type
== EXPR_FUNCTION
3158 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3159 gfc_warning ("POINTER valued function appears on right-hand side of "
3160 "assignment at %L", &rvalue
->where
);
3162 /* Check size of array assignments. */
3163 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3164 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3167 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3168 && lvalue
->symtree
->n
.sym
->attr
.data
3169 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3170 "initialize non-integer variable '%s'",
3171 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3174 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3175 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3176 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3177 &rvalue
->where
) == FAILURE
)
3180 /* Handle the case of a BOZ literal on the RHS. */
3181 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3184 if (gfc_option
.warn_surprising
)
3185 gfc_warning ("BOZ literal at %L is bitwise transferred "
3186 "non-integer symbol '%s'", &rvalue
->where
,
3187 lvalue
->symtree
->n
.sym
->name
);
3188 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3190 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3192 if (rc
== ARITH_UNDERFLOW
)
3193 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3194 ". This check can be disabled with the option "
3195 "-fno-range-check", &rvalue
->where
);
3196 else if (rc
== ARITH_OVERFLOW
)
3197 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3198 ". This check can be disabled with the option "
3199 "-fno-range-check", &rvalue
->where
);
3200 else if (rc
== ARITH_NAN
)
3201 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3202 ". This check can be disabled with the option "
3203 "-fno-range-check", &rvalue
->where
);
3208 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3209 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3210 will warn anyway, so there is no need to to so here. */
3212 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3213 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3215 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3217 /* As a special bonus, don't warn about REAL rvalues which are not
3218 changed by the conversion if -Wconversion is specified. */
3219 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3221 /* Calculate the difference between the constant and the rounded
3222 value and check it against zero. */
3224 gfc_set_model_kind (lvalue
->ts
.kind
);
3226 gfc_set_model_kind (rvalue
->ts
.kind
);
3229 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3230 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3232 if (!mpfr_zero_p (diff
))
3233 gfc_warning ("Change of value in conversion from "
3234 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3235 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3241 gfc_warning ("Possible change of value in conversion from %s "
3242 "to %s at %L",gfc_typename (&rvalue
->ts
),
3243 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3246 else if (gfc_option
.warn_conversion_extra
3247 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3249 gfc_warning ("Conversion from %s to %s at %L",
3250 gfc_typename (&rvalue
->ts
),
3251 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3255 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3258 /* Only DATA Statements come here. */
3261 /* Numeric can be converted to any other numeric. And Hollerith can be
3262 converted to any other type. */
3263 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3264 || rvalue
->ts
.type
== BT_HOLLERITH
)
3267 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3270 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3271 "conversion of %s to %s", &lvalue
->where
,
3272 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3277 /* Assignment is the only case where character variables of different
3278 kind values can be converted into one another. */
3279 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3281 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3282 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3287 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3291 /* Check that a pointer assignment is OK. We first check lvalue, and
3292 we only check rvalue if it's not an assignment to NULL() or a
3293 NULLIFY statement. */
3296 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3298 symbol_attribute attr
;
3300 bool is_pure
, is_implicit_pure
, rank_remap
;
3303 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3304 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3306 gfc_error ("Pointer assignment target is not a POINTER at %L",
3311 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3312 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3313 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3315 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3316 "l-value since it is a procedure",
3317 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3321 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3324 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3326 if (ref
->type
== REF_COMPONENT
)
3327 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3329 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3333 if (ref
->u
.ar
.type
== AR_FULL
)
3336 if (ref
->u
.ar
.type
!= AR_SECTION
)
3338 gfc_error ("Expected bounds specification for '%s' at %L",
3339 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3343 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3344 "specification for '%s' in pointer assignment "
3345 "at %L", lvalue
->symtree
->n
.sym
->name
,
3346 &lvalue
->where
) == FAILURE
)
3349 /* When bounds are given, all lbounds are necessary and either all
3350 or none of the upper bounds; no strides are allowed. If the
3351 upper bounds are present, we may do rank remapping. */
3352 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3354 if (!ref
->u
.ar
.start
[dim
]
3355 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3357 gfc_error ("Lower bound has to be present at %L",
3361 if (ref
->u
.ar
.stride
[dim
])
3363 gfc_error ("Stride must not be present at %L",
3369 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3372 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3373 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3375 gfc_error ("Either all or none of the upper bounds"
3376 " must be specified at %L", &lvalue
->where
);
3384 is_pure
= gfc_pure (NULL
);
3385 is_implicit_pure
= gfc_implicit_pure (NULL
);
3387 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3388 kind, etc for lvalue and rvalue must match, and rvalue must be a
3389 pure variable if we're in a pure function. */
3390 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3393 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3394 if (lvalue
->expr_type
== EXPR_VARIABLE
3395 && gfc_is_coindexed (lvalue
))
3398 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3399 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3401 gfc_error ("Pointer object at %L shall not have a coindex",
3407 /* Checks on rvalue for procedure pointer assignments. */
3412 gfc_component
*comp
;
3415 attr
= gfc_expr_attr (rvalue
);
3416 if (!((rvalue
->expr_type
== EXPR_NULL
)
3417 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3418 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3419 || (rvalue
->expr_type
== EXPR_VARIABLE
3420 && attr
.flavor
== FL_PROCEDURE
)))
3422 gfc_error ("Invalid procedure pointer assignment at %L",
3428 gfc_error ("Abstract interface '%s' is invalid "
3429 "in procedure pointer assignment at %L",
3430 rvalue
->symtree
->name
, &rvalue
->where
);
3433 /* Check for C727. */
3434 if (attr
.flavor
== FL_PROCEDURE
)
3436 if (attr
.proc
== PROC_ST_FUNCTION
)
3438 gfc_error ("Statement function '%s' is invalid "
3439 "in procedure pointer assignment at %L",
3440 rvalue
->symtree
->name
, &rvalue
->where
);
3443 if (attr
.proc
== PROC_INTERNAL
&&
3444 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3445 "invalid in procedure pointer assignment at %L",
3446 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3450 /* Ensure that the calling convention is the same. As other attributes
3451 such as DLLEXPORT may differ, one explicitly only tests for the
3452 calling conventions. */
3453 if (rvalue
->expr_type
== EXPR_VARIABLE
3454 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3455 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3457 symbol_attribute calls
;
3460 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3461 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3462 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3464 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3465 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3467 gfc_error ("Mismatch in the procedure pointer assignment "
3468 "at %L: mismatch in the calling convention",
3474 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3475 s1
= comp
->ts
.interface
;
3477 s1
= lvalue
->symtree
->n
.sym
;
3479 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3481 s2
= comp
->ts
.interface
;
3484 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3486 s2
= rvalue
->symtree
->n
.sym
->result
;
3487 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3491 s2
= rvalue
->symtree
->n
.sym
;
3492 name
= rvalue
->symtree
->n
.sym
->name
;
3495 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3498 gfc_error ("Interface mismatch in procedure pointer assignment "
3499 "at %L: %s", &rvalue
->where
, err
);
3506 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3508 gfc_error ("Different types in pointer assignment at %L; attempted "
3509 "assignment of %s to %s", &lvalue
->where
,
3510 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3514 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3516 gfc_error ("Different kind type parameters in pointer "
3517 "assignment at %L", &lvalue
->where
);
3521 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3523 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3527 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3528 /* Make sure the vtab is present. */
3529 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3531 /* Check rank remapping. */
3536 /* If this can be determined, check that the target must be at least as
3537 large as the pointer assigned to it is. */
3538 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3539 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3540 && mpz_cmp (rsize
, lsize
) < 0)
3542 gfc_error ("Rank remapping target is smaller than size of the"
3543 " pointer (%ld < %ld) at %L",
3544 mpz_get_si (rsize
), mpz_get_si (lsize
),
3549 /* The target must be either rank one or it must be simply contiguous
3550 and F2008 must be allowed. */
3551 if (rvalue
->rank
!= 1)
3553 if (!gfc_is_simply_contiguous (rvalue
, true))
3555 gfc_error ("Rank remapping target must be rank 1 or"
3556 " simply contiguous at %L", &rvalue
->where
);
3559 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Rank remapping"
3560 " target is not rank 1 at %L", &rvalue
->where
)
3566 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3567 if (rvalue
->expr_type
== EXPR_NULL
)
3570 if (lvalue
->ts
.type
== BT_CHARACTER
)
3572 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3577 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3578 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3580 attr
= gfc_expr_attr (rvalue
);
3582 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3584 gfc_error ("Target expression in pointer assignment "
3585 "at %L must deliver a pointer result",
3590 if (!attr
.target
&& !attr
.pointer
)
3592 gfc_error ("Pointer assignment target is neither TARGET "
3593 "nor POINTER at %L", &rvalue
->where
);
3597 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3599 gfc_error ("Bad target in pointer assignment in PURE "
3600 "procedure at %L", &rvalue
->where
);
3603 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3604 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3607 if (gfc_has_vector_index (rvalue
))
3609 gfc_error ("Pointer assignment with vector subscript "
3610 "on rhs at %L", &rvalue
->where
);
3614 if (attr
.is_protected
&& attr
.use_assoc
3615 && !(attr
.pointer
|| attr
.proc_pointer
))
3617 gfc_error ("Pointer assignment target has PROTECTED "
3618 "attribute at %L", &rvalue
->where
);
3622 /* F2008, C725. For PURE also C1283. */
3623 if (rvalue
->expr_type
== EXPR_VARIABLE
3624 && gfc_is_coindexed (rvalue
))
3627 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3628 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3630 gfc_error ("Data target at %L shall not have a coindex",
3640 /* Relative of gfc_check_assign() except that the lvalue is a single
3641 symbol. Used for initialization assignments. */
3644 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3649 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3651 lvalue
.expr_type
= EXPR_VARIABLE
;
3652 lvalue
.ts
= sym
->ts
;
3654 lvalue
.rank
= sym
->as
->rank
;
3655 lvalue
.symtree
= XCNEW (gfc_symtree
);
3656 lvalue
.symtree
->n
.sym
= sym
;
3657 lvalue
.where
= sym
->declared_at
;
3659 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3660 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
3661 && rvalue
->expr_type
== EXPR_NULL
))
3662 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3664 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3666 free (lvalue
.symtree
);
3671 if (sym
->attr
.pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3673 /* F08:C461. Additional checks for pointer initialization. */
3674 symbol_attribute attr
;
3675 attr
= gfc_expr_attr (rvalue
);
3676 if (attr
.allocatable
)
3678 gfc_error ("Pointer initialization target at %C "
3679 "must not be ALLOCATABLE ");
3682 if (!attr
.target
|| attr
.pointer
)
3684 gfc_error ("Pointer initialization target at %C "
3685 "must have the TARGET attribute");
3690 gfc_error ("Pointer initialization target at %C "
3691 "must have the SAVE attribute");
3696 if (sym
->attr
.proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3698 /* F08:C1220. Additional checks for procedure pointer initialization. */
3699 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3700 if (attr
.proc_pointer
)
3702 gfc_error ("Procedure pointer initialization target at %L "
3703 "may not be a procedure pointer", &rvalue
->where
);
3712 /* Check for default initializer; sym->value is not enough
3713 as it is also set for EXPR_NULL of allocatables. */
3716 gfc_has_default_initializer (gfc_symbol
*der
)
3720 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3721 for (c
= der
->components
; c
; c
= c
->next
)
3722 if (c
->ts
.type
== BT_DERIVED
)
3724 if (!c
->attr
.pointer
3725 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3737 /* Get an expression for a default initializer. */
3740 gfc_default_initializer (gfc_typespec
*ts
)
3743 gfc_component
*comp
;
3745 /* See if we have a default initializer in this, but not in nested
3746 types (otherwise we could use gfc_has_default_initializer()). */
3747 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3748 if (comp
->initializer
|| comp
->attr
.allocatable
3749 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3755 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3756 &ts
->u
.derived
->declared_at
);
3759 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3761 gfc_constructor
*ctor
= gfc_constructor_get();
3763 if (comp
->initializer
)
3764 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3766 if (comp
->attr
.allocatable
3767 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3769 ctor
->expr
= gfc_get_expr ();
3770 ctor
->expr
->expr_type
= EXPR_NULL
;
3771 ctor
->expr
->ts
= comp
->ts
;
3774 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3781 /* Given a symbol, create an expression node with that symbol as a
3782 variable. If the symbol is array valued, setup a reference of the
3786 gfc_get_variable_expr (gfc_symtree
*var
)
3790 e
= gfc_get_expr ();
3791 e
->expr_type
= EXPR_VARIABLE
;
3793 e
->ts
= var
->n
.sym
->ts
;
3795 if (var
->n
.sym
->as
!= NULL
)
3797 e
->rank
= var
->n
.sym
->as
->rank
;
3798 e
->ref
= gfc_get_ref ();
3799 e
->ref
->type
= REF_ARRAY
;
3800 e
->ref
->u
.ar
.type
= AR_FULL
;
3808 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3811 lval
= gfc_get_expr ();
3812 lval
->expr_type
= EXPR_VARIABLE
;
3813 lval
->where
= sym
->declared_at
;
3815 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3817 /* It will always be a full array. */
3818 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
3821 lval
->ref
= gfc_get_ref ();
3822 lval
->ref
->type
= REF_ARRAY
;
3823 lval
->ref
->u
.ar
.type
= AR_FULL
;
3824 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
3825 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
3826 lval
->ref
->u
.ar
.as
= sym
->as
;
3833 /* Returns the array_spec of a full array expression. A NULL is
3834 returned otherwise. */
3836 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3841 if (expr
->rank
== 0)
3844 /* Follow any component references. */
3845 if (expr
->expr_type
== EXPR_VARIABLE
3846 || expr
->expr_type
== EXPR_CONSTANT
)
3848 as
= expr
->symtree
->n
.sym
->as
;
3849 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3854 as
= ref
->u
.c
.component
->as
;
3862 switch (ref
->u
.ar
.type
)
3885 /* General expression traversal function. */
3888 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3889 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3894 gfc_actual_arglist
*args
;
3901 if ((*func
) (expr
, sym
, &f
))
3904 if (expr
->ts
.type
== BT_CHARACTER
3906 && expr
->ts
.u
.cl
->length
3907 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3908 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3911 switch (expr
->expr_type
)
3916 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3918 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3926 case EXPR_SUBSTRING
:
3929 case EXPR_STRUCTURE
:
3931 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3932 c
; c
= gfc_constructor_next (c
))
3934 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3938 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3940 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3942 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3944 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3951 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3953 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3969 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3971 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3973 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3975 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3981 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3983 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3988 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3989 && ref
->u
.c
.component
->ts
.u
.cl
3990 && ref
->u
.c
.component
->ts
.u
.cl
->length
3991 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
3993 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
3997 if (ref
->u
.c
.component
->as
)
3998 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
3999 + ref
->u
.c
.component
->as
->corank
; i
++)
4001 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4004 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4018 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4021 expr_set_symbols_referenced (gfc_expr
*expr
,
4022 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4023 int *f ATTRIBUTE_UNUSED
)
4025 if (expr
->expr_type
!= EXPR_VARIABLE
)
4027 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4032 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4034 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4038 /* Determine if an expression is a procedure pointer component. If yes, the
4039 argument 'comp' will point to the component (provided that 'comp' was
4043 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
4048 if (!expr
|| !expr
->ref
)
4055 if (ref
->type
== REF_COMPONENT
)
4057 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
4059 *comp
= ref
->u
.c
.component
;
4066 /* Walk an expression tree and check each variable encountered for being typed.
4067 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4068 mode as is a basic arithmetic expression using those; this is for things in
4071 INTEGER :: arr(n), n
4072 INTEGER :: arr(n + 1), n
4074 The namespace is needed for IMPLICIT typing. */
4076 static gfc_namespace
* check_typed_ns
;
4079 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4080 int* f ATTRIBUTE_UNUSED
)
4084 if (e
->expr_type
!= EXPR_VARIABLE
)
4087 gcc_assert (e
->symtree
);
4088 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4091 return (t
== FAILURE
);
4095 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4099 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4103 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4104 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4106 if (e
->expr_type
== EXPR_OP
)
4108 gfc_try t
= SUCCESS
;
4110 gcc_assert (e
->value
.op
.op1
);
4111 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4113 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4114 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4120 /* Otherwise, walk the expression and do it strictly. */
4121 check_typed_ns
= ns
;
4122 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4124 return error_found
? FAILURE
: SUCCESS
;
4127 /* Walk an expression tree and replace all symbols with a corresponding symbol
4128 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4129 statements. The boolean return value is required by gfc_traverse_expr. */
4132 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4134 if ((expr
->expr_type
== EXPR_VARIABLE
4135 || (expr
->expr_type
== EXPR_FUNCTION
4136 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4137 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
4140 gfc_namespace
*ns
= sym
->formal_ns
;
4141 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4142 the symtree rather than create a new one (and probably fail later). */
4143 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4144 expr
->symtree
->n
.sym
->name
);
4146 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4147 expr
->symtree
= stree
;
4153 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
4155 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
4158 /* The following is analogous to 'replace_symbol', and needed for copying
4159 interfaces for procedure pointer components. The argument 'sym' must formally
4160 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4161 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4162 component in whose formal_ns the arguments have to be). */
4165 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4167 gfc_component
*comp
;
4168 comp
= (gfc_component
*)sym
;
4169 if ((expr
->expr_type
== EXPR_VARIABLE
4170 || (expr
->expr_type
== EXPR_FUNCTION
4171 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4172 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4175 gfc_namespace
*ns
= comp
->formal_ns
;
4176 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4177 the symtree rather than create a new one (and probably fail later). */
4178 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4179 expr
->symtree
->n
.sym
->name
);
4181 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4182 expr
->symtree
= stree
;
4188 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4190 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4195 gfc_ref_this_image (gfc_ref
*ref
)
4199 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4201 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4202 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4210 gfc_is_coindexed (gfc_expr
*e
)
4214 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4215 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4216 return !gfc_ref_this_image (ref
);
4222 /* Coarrays are variables with a corank but not being coindexed. However, also
4223 the following is a coarray: A subobject of a coarray is a coarray if it does
4224 not have any cosubscripts, vector subscripts, allocatable component
4225 selection, or pointer component selection. (F2008, 2.4.7) */
4228 gfc_is_coarray (gfc_expr
*e
)
4232 gfc_component
*comp
;
4237 if (e
->expr_type
!= EXPR_VARIABLE
)
4241 sym
= e
->symtree
->n
.sym
;
4243 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4244 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4246 coarray
= sym
->attr
.codimension
;
4248 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4252 comp
= ref
->u
.c
.component
;
4253 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4256 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
)
4257 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4259 coarray
= comp
->attr
.codimension
;
4267 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4273 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4274 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4285 return coarray
&& !coindexed
;
4290 gfc_get_corank (gfc_expr
*e
)
4294 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4295 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4297 if (ref
->type
== REF_ARRAY
)
4298 corank
= ref
->u
.ar
.as
->corank
;
4299 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4305 /* Check whether the expression has an ultimate allocatable component.
4306 Being itself allocatable does not count. */
4308 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4310 gfc_ref
*ref
, *last
= NULL
;
4312 if (e
->expr_type
!= EXPR_VARIABLE
)
4315 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4316 if (ref
->type
== REF_COMPONENT
)
4319 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4320 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4321 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4322 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4326 if (e
->ts
.type
== BT_CLASS
)
4327 return CLASS_DATA (e
)->attr
.alloc_comp
;
4328 else if (e
->ts
.type
== BT_DERIVED
)
4329 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4335 /* Check whether the expression has an pointer component.
4336 Being itself a pointer does not count. */
4338 gfc_has_ultimate_pointer (gfc_expr
*e
)
4340 gfc_ref
*ref
, *last
= NULL
;
4342 if (e
->expr_type
!= EXPR_VARIABLE
)
4345 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4346 if (ref
->type
== REF_COMPONENT
)
4349 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4350 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4351 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4352 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4356 if (e
->ts
.type
== BT_CLASS
)
4357 return CLASS_DATA (e
)->attr
.pointer_comp
;
4358 else if (e
->ts
.type
== BT_DERIVED
)
4359 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4365 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4366 Note: A scalar is not regarded as "simply contiguous" by the standard.
4367 if bool is not strict, some futher checks are done - for instance,
4368 a "(::1)" is accepted. */
4371 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4375 gfc_array_ref
*ar
= NULL
;
4376 gfc_ref
*ref
, *part_ref
= NULL
;
4378 if (expr
->expr_type
== EXPR_FUNCTION
)
4379 return expr
->value
.function
.esym
4380 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4381 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4384 if (expr
->rank
== 0)
4387 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4390 return false; /* Array shall be last part-ref. */
4392 if (ref
->type
== REF_COMPONENT
)
4394 else if (ref
->type
== REF_SUBSTRING
)
4396 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4400 if ((part_ref
&& !part_ref
->u
.c
.component
->attr
.contiguous
4401 && part_ref
->u
.c
.component
->attr
.pointer
)
4402 || (!part_ref
&& !expr
->symtree
->n
.sym
->attr
.contiguous
4403 && (expr
->symtree
->n
.sym
->attr
.pointer
4404 || expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)))
4407 if (!ar
|| ar
->type
== AR_FULL
)
4410 gcc_assert (ar
->type
== AR_SECTION
);
4412 /* Check for simply contiguous array */
4414 for (i
= 0; i
< ar
->dimen
; i
++)
4416 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4419 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4425 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4428 /* If the previous section was not contiguous, that's an error,
4429 unless we have effective only one element and checking is not
4431 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4432 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4433 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4434 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4435 ar
->end
[i
]->value
.integer
) != 0))
4438 /* Following the standard, "(::1)" or - if known at compile time -
4439 "(lbound:ubound)" are not simply contigous; if strict
4440 is false, they are regarded as simply contiguous. */
4441 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4442 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4443 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4447 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4448 || !ar
->as
->lower
[i
]
4449 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4450 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4451 ar
->as
->lower
[i
]->value
.integer
) != 0))
4455 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4456 || !ar
->as
->upper
[i
]
4457 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4458 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4459 ar
->as
->upper
[i
]->value
.integer
) != 0))
4467 /* Build call to an intrinsic procedure. The number of arguments has to be
4468 passed (rather than ending the list with a NULL value) because we may
4469 want to add arguments but with a NULL-expression. */
4472 gfc_build_intrinsic_call (const char* name
, locus where
, unsigned numarg
, ...)
4475 gfc_actual_arglist
* atail
;
4476 gfc_intrinsic_sym
* isym
;
4480 isym
= gfc_find_function (name
);
4483 result
= gfc_get_expr ();
4484 result
->expr_type
= EXPR_FUNCTION
;
4485 result
->ts
= isym
->ts
;
4486 result
->where
= where
;
4487 result
->value
.function
.name
= name
;
4488 result
->value
.function
.isym
= isym
;
4490 va_start (ap
, numarg
);
4492 for (i
= 0; i
< numarg
; ++i
)
4496 atail
->next
= gfc_get_actual_arglist ();
4497 atail
= atail
->next
;
4500 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4502 atail
->expr
= va_arg (ap
, gfc_expr
*);
4510 /* Check if an expression may appear in a variable definition context
4511 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4512 This is called from the various places when resolving
4513 the pieces that make up such a context.
4515 Optionally, a possible error message can be suppressed if context is NULL
4516 and just the return status (SUCCESS / FAILURE) be requested. */
4519 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4520 const char* context
)
4522 gfc_symbol
* sym
= NULL
;
4524 bool check_intentin
;
4526 symbol_attribute attr
;
4529 if (e
->expr_type
== EXPR_VARIABLE
)
4531 gcc_assert (e
->symtree
);
4532 sym
= e
->symtree
->n
.sym
;
4534 else if (e
->expr_type
== EXPR_FUNCTION
)
4536 gcc_assert (e
->symtree
);
4537 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4540 attr
= gfc_expr_attr (e
);
4541 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4543 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4546 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4547 " context (%s) at %L", context
, &e
->where
);
4551 else if (e
->expr_type
!= EXPR_VARIABLE
)
4554 gfc_error ("Non-variable expression in variable definition context (%s)"
4555 " at %L", context
, &e
->where
);
4559 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4562 gfc_error ("Named constant '%s' in variable definition context (%s)"
4563 " at %L", sym
->name
, context
, &e
->where
);
4566 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4567 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4568 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4571 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4572 " a variable", sym
->name
, context
, &e
->where
);
4576 /* Find out whether the expr is a pointer; this also means following
4577 component references to the last one. */
4578 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4579 if (pointer
&& !is_pointer
)
4582 gfc_error ("Non-POINTER in pointer association context (%s)"
4583 " at %L", context
, &e
->where
);
4590 || (e
->ts
.type
== BT_DERIVED
4591 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4592 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4595 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4596 context
, &e
->where
);
4600 /* INTENT(IN) dummy argument. Check this, unless the object itself is
4601 the component of sub-component of a pointer. Obviously,
4602 procedure pointers are of no interest here. */
4603 check_intentin
= true;
4604 ptr_component
= sym
->attr
.pointer
;
4605 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4607 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4608 check_intentin
= false;
4609 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4610 ptr_component
= true;
4612 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4614 if (pointer
&& is_pointer
)
4617 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4618 " association context (%s) at %L",
4619 sym
->name
, context
, &e
->where
);
4622 if (!pointer
&& !is_pointer
)
4625 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4626 " definition context (%s) at %L",
4627 sym
->name
, context
, &e
->where
);
4632 /* PROTECTED and use-associated. */
4633 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4635 if (pointer
&& is_pointer
)
4638 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4639 " pointer association context (%s) at %L",
4640 sym
->name
, context
, &e
->where
);
4643 if (!pointer
&& !is_pointer
)
4646 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4647 " variable definition context (%s) at %L",
4648 sym
->name
, context
, &e
->where
);
4653 /* Variable not assignable from a PURE procedure but appears in
4654 variable definition context. */
4655 if (!pointer
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4658 gfc_error ("Variable '%s' can not appear in a variable definition"
4659 " context (%s) at %L in PURE procedure",
4660 sym
->name
, context
, &e
->where
);
4664 if (!pointer
&& gfc_implicit_pure (NULL
) && gfc_impure_variable (sym
))
4665 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4667 /* Check variable definition context for associate-names. */
4668 if (!pointer
&& sym
->assoc
)
4671 gfc_association_list
* assoc
;
4673 gcc_assert (sym
->assoc
->target
);
4675 /* If this is a SELECT TYPE temporary (the association is used internally
4676 for SELECT TYPE), silently go over to the target. */
4677 if (sym
->attr
.select_type_temporary
)
4679 gfc_expr
* t
= sym
->assoc
->target
;
4681 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4682 name
= t
->symtree
->name
;
4684 if (t
->symtree
->n
.sym
->assoc
)
4685 assoc
= t
->symtree
->n
.sym
->assoc
;
4694 gcc_assert (name
&& assoc
);
4696 /* Is association to a valid variable? */
4697 if (!assoc
->variable
)
4701 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4702 gfc_error ("'%s' at %L associated to vector-indexed target can"
4703 " not be used in a variable definition context (%s)",
4704 name
, &e
->where
, context
);
4706 gfc_error ("'%s' at %L associated to expression can"
4707 " not be used in a variable definition context (%s)",
4708 name
, &e
->where
, context
);
4713 /* Target must be allowed to appear in a variable definition context. */
4714 if (gfc_check_vardef_context (assoc
->target
, pointer
, false, NULL
)
4718 gfc_error ("Associate-name '%s' can not appear in a variable"
4719 " definition context (%s) at %L because its target"
4720 " at %L can not, either",
4721 name
, context
, &e
->where
,
4722 &assoc
->target
->where
);