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
);
399 /* Workhorse function for gfc_free_expr() that frees everything
400 beneath an expression node, but not the node itself. This is
401 useful when we want to simplify a node and replace it with
402 something else or the expression node belongs to another structure. */
405 free_expr0 (gfc_expr
*e
)
409 switch (e
->expr_type
)
412 /* Free any parts of the value that need freeing. */
416 mpz_clear (e
->value
.integer
);
420 mpfr_clear (e
->value
.real
);
424 free (e
->value
.character
.string
);
428 mpc_clear (e
->value
.complex);
435 /* Free the representation. */
436 free (e
->representation
.string
);
441 if (e
->value
.op
.op1
!= NULL
)
442 gfc_free_expr (e
->value
.op
.op1
);
443 if (e
->value
.op
.op2
!= NULL
)
444 gfc_free_expr (e
->value
.op
.op2
);
448 gfc_free_actual_arglist (e
->value
.function
.actual
);
453 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
461 gfc_constructor_free (e
->value
.constructor
);
465 free (e
->value
.character
.string
);
472 gfc_internal_error ("free_expr0(): Bad expr type");
475 /* Free a shape array. */
476 if (e
->shape
!= NULL
)
478 for (n
= 0; n
< e
->rank
; n
++)
479 mpz_clear (e
->shape
[n
]);
484 gfc_free_ref_list (e
->ref
);
486 memset (e
, '\0', sizeof (gfc_expr
));
490 /* Free an expression node and everything beneath it. */
493 gfc_free_expr (gfc_expr
*e
)
502 /* Free an argument list and everything below it. */
505 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
507 gfc_actual_arglist
*a2
;
512 gfc_free_expr (a1
->expr
);
519 /* Copy an arglist structure and all of the arguments. */
522 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
524 gfc_actual_arglist
*head
, *tail
, *new_arg
;
528 for (; p
; p
= p
->next
)
530 new_arg
= gfc_get_actual_arglist ();
533 new_arg
->expr
= gfc_copy_expr (p
->expr
);
534 new_arg
->next
= NULL
;
539 tail
->next
= new_arg
;
548 /* Free a list of reference structures. */
551 gfc_free_ref_list (gfc_ref
*p
)
563 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
565 gfc_free_expr (p
->u
.ar
.start
[i
]);
566 gfc_free_expr (p
->u
.ar
.end
[i
]);
567 gfc_free_expr (p
->u
.ar
.stride
[i
]);
573 gfc_free_expr (p
->u
.ss
.start
);
574 gfc_free_expr (p
->u
.ss
.end
);
586 /* Graft the *src expression onto the *dest subexpression. */
589 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
597 /* Try to extract an integer constant from the passed expression node.
598 Returns an error message or NULL if the result is set. It is
599 tempting to generate an error and return SUCCESS or FAILURE, but
600 failure is OK for some callers. */
603 gfc_extract_int (gfc_expr
*expr
, int *result
)
605 if (expr
->expr_type
!= EXPR_CONSTANT
)
606 return _("Constant expression required at %C");
608 if (expr
->ts
.type
!= BT_INTEGER
)
609 return _("Integer expression required at %C");
611 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
612 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
614 return _("Integer value too large in expression at %C");
617 *result
= (int) mpz_get_si (expr
->value
.integer
);
623 /* Recursively copy a list of reference structures. */
626 gfc_copy_ref (gfc_ref
*src
)
634 dest
= gfc_get_ref ();
635 dest
->type
= src
->type
;
640 ar
= gfc_copy_array_ref (&src
->u
.ar
);
646 dest
->u
.c
= src
->u
.c
;
650 dest
->u
.ss
= src
->u
.ss
;
651 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
652 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
656 dest
->next
= gfc_copy_ref (src
->next
);
662 /* Detect whether an expression has any vector index array references. */
665 gfc_has_vector_index (gfc_expr
*e
)
669 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
670 if (ref
->type
== REF_ARRAY
)
671 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
672 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
678 /* Copy a shape array. */
681 gfc_copy_shape (mpz_t
*shape
, int rank
)
689 new_shape
= gfc_get_shape (rank
);
691 for (n
= 0; n
< rank
; n
++)
692 mpz_init_set (new_shape
[n
], shape
[n
]);
698 /* Copy a shape array excluding dimension N, where N is an integer
699 constant expression. Dimensions are numbered in fortran style --
702 So, if the original shape array contains R elements
703 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
704 the result contains R-1 elements:
705 { s1 ... sN-1 sN+1 ... sR-1}
707 If anything goes wrong -- N is not a constant, its value is out
708 of range -- or anything else, just returns NULL. */
711 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
713 mpz_t
*new_shape
, *s
;
719 || dim
->expr_type
!= EXPR_CONSTANT
720 || dim
->ts
.type
!= BT_INTEGER
)
723 n
= mpz_get_si (dim
->value
.integer
);
724 n
--; /* Convert to zero based index. */
725 if (n
< 0 || n
>= rank
)
728 s
= new_shape
= gfc_get_shape (rank
- 1);
730 for (i
= 0; i
< rank
; i
++)
734 mpz_init_set (*s
, shape
[i
]);
742 /* Return the maximum kind of two expressions. In general, higher
743 kind numbers mean more precision for numeric types. */
746 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
748 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
752 /* Returns nonzero if the type is numeric, zero otherwise. */
755 numeric_type (bt type
)
757 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
761 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
764 gfc_numeric_ts (gfc_typespec
*ts
)
766 return numeric_type (ts
->type
);
770 /* Return an expression node with an optional argument list attached.
771 A variable number of gfc_expr pointers are strung together in an
772 argument list with a NULL pointer terminating the list. */
775 gfc_build_conversion (gfc_expr
*e
)
780 p
->expr_type
= EXPR_FUNCTION
;
782 p
->value
.function
.actual
= NULL
;
784 p
->value
.function
.actual
= gfc_get_actual_arglist ();
785 p
->value
.function
.actual
->expr
= e
;
791 /* Given an expression node with some sort of numeric binary
792 expression, insert type conversions required to make the operands
793 have the same type. Conversion warnings are disabled if wconversion
796 The exception is that the operands of an exponential don't have to
797 have the same type. If possible, the base is promoted to the type
798 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
799 1.0**2 stays as it is. */
802 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
806 op1
= e
->value
.op
.op1
;
807 op2
= e
->value
.op
.op2
;
809 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
811 gfc_clear_ts (&e
->ts
);
815 /* Kind conversions of same type. */
816 if (op1
->ts
.type
== op2
->ts
.type
)
818 if (op1
->ts
.kind
== op2
->ts
.kind
)
820 /* No type conversions. */
825 if (op1
->ts
.kind
> op2
->ts
.kind
)
826 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
828 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
834 /* Integer combined with real or complex. */
835 if (op2
->ts
.type
== BT_INTEGER
)
839 /* Special case for ** operator. */
840 if (e
->value
.op
.op
== INTRINSIC_POWER
)
843 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
847 if (op1
->ts
.type
== BT_INTEGER
)
850 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
854 /* Real combined with complex. */
855 e
->ts
.type
= BT_COMPLEX
;
856 if (op1
->ts
.kind
> op2
->ts
.kind
)
857 e
->ts
.kind
= op1
->ts
.kind
;
859 e
->ts
.kind
= op2
->ts
.kind
;
860 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
861 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
862 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
863 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
870 /* Function to determine if an expression is constant or not. This
871 function expects that the expression has already been simplified. */
874 gfc_is_constant_expr (gfc_expr
*e
)
877 gfc_actual_arglist
*arg
;
883 switch (e
->expr_type
)
886 return (gfc_is_constant_expr (e
->value
.op
.op1
)
887 && (e
->value
.op
.op2
== NULL
888 || gfc_is_constant_expr (e
->value
.op
.op2
)));
896 gcc_assert (e
->symtree
|| e
->value
.function
.esym
897 || e
->value
.function
.isym
);
899 /* Call to intrinsic with at least one argument. */
900 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
902 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
903 if (!gfc_is_constant_expr (arg
->expr
))
907 /* Specification functions are constant. */
908 /* F95, 7.1.6.2; F2003, 7.1.7 */
911 sym
= e
->symtree
->n
.sym
;
912 if (e
->value
.function
.esym
)
913 sym
= e
->value
.function
.esym
;
916 && sym
->attr
.function
918 && !sym
->attr
.intrinsic
919 && !sym
->attr
.recursive
920 && sym
->attr
.proc
!= PROC_INTERNAL
921 && sym
->attr
.proc
!= PROC_ST_FUNCTION
922 && sym
->attr
.proc
!= PROC_UNKNOWN
923 && sym
->formal
== NULL
)
926 if (e
->value
.function
.isym
927 && (e
->value
.function
.isym
->elemental
928 || e
->value
.function
.isym
->pure
929 || e
->value
.function
.isym
->inquiry
930 || e
->value
.function
.isym
->transformational
))
940 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
941 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
945 c
= gfc_constructor_first (e
->value
.constructor
);
946 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
947 return gfc_constant_ac (e
);
949 for (; c
; c
= gfc_constructor_next (c
))
950 if (!gfc_is_constant_expr (c
->expr
))
957 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
963 /* Is true if an array reference is followed by a component or substring
966 is_subref_array (gfc_expr
* e
)
971 if (e
->expr_type
!= EXPR_VARIABLE
)
974 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
978 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
980 if (ref
->type
== REF_ARRAY
981 && ref
->u
.ar
.type
!= AR_ELEMENT
)
985 && ref
->type
!= REF_ARRAY
)
992 /* Try to collapse intrinsic expressions. */
995 simplify_intrinsic_op (gfc_expr
*p
, int type
)
998 gfc_expr
*op1
, *op2
, *result
;
1000 if (p
->value
.op
.op
== INTRINSIC_USER
)
1003 op1
= p
->value
.op
.op1
;
1004 op2
= p
->value
.op
.op2
;
1005 op
= p
->value
.op
.op
;
1007 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1009 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1012 if (!gfc_is_constant_expr (op1
)
1013 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1017 p
->value
.op
.op1
= NULL
;
1018 p
->value
.op
.op2
= NULL
;
1022 case INTRINSIC_PARENTHESES
:
1023 result
= gfc_parentheses (op1
);
1026 case INTRINSIC_UPLUS
:
1027 result
= gfc_uplus (op1
);
1030 case INTRINSIC_UMINUS
:
1031 result
= gfc_uminus (op1
);
1034 case INTRINSIC_PLUS
:
1035 result
= gfc_add (op1
, op2
);
1038 case INTRINSIC_MINUS
:
1039 result
= gfc_subtract (op1
, op2
);
1042 case INTRINSIC_TIMES
:
1043 result
= gfc_multiply (op1
, op2
);
1046 case INTRINSIC_DIVIDE
:
1047 result
= gfc_divide (op1
, op2
);
1050 case INTRINSIC_POWER
:
1051 result
= gfc_power (op1
, op2
);
1054 case INTRINSIC_CONCAT
:
1055 result
= gfc_concat (op1
, op2
);
1059 case INTRINSIC_EQ_OS
:
1060 result
= gfc_eq (op1
, op2
, op
);
1064 case INTRINSIC_NE_OS
:
1065 result
= gfc_ne (op1
, op2
, op
);
1069 case INTRINSIC_GT_OS
:
1070 result
= gfc_gt (op1
, op2
, op
);
1074 case INTRINSIC_GE_OS
:
1075 result
= gfc_ge (op1
, op2
, op
);
1079 case INTRINSIC_LT_OS
:
1080 result
= gfc_lt (op1
, op2
, op
);
1084 case INTRINSIC_LE_OS
:
1085 result
= gfc_le (op1
, op2
, op
);
1089 result
= gfc_not (op1
);
1093 result
= gfc_and (op1
, op2
);
1097 result
= gfc_or (op1
, op2
);
1101 result
= gfc_eqv (op1
, op2
);
1104 case INTRINSIC_NEQV
:
1105 result
= gfc_neqv (op1
, op2
);
1109 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1114 gfc_free_expr (op1
);
1115 gfc_free_expr (op2
);
1119 result
->rank
= p
->rank
;
1120 result
->where
= p
->where
;
1121 gfc_replace_expr (p
, result
);
1127 /* Subroutine to simplify constructor expressions. Mutually recursive
1128 with gfc_simplify_expr(). */
1131 simplify_constructor (gfc_constructor_base base
, int type
)
1136 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1139 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1140 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1141 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1146 /* Try and simplify a copy. Replace the original if successful
1147 but keep going through the constructor at all costs. Not
1148 doing so can make a dog's dinner of complicated things. */
1149 p
= gfc_copy_expr (c
->expr
);
1151 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1157 gfc_replace_expr (c
->expr
, p
);
1165 /* Pull a single array element out of an array constructor. */
1168 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1169 gfc_constructor
**rval
)
1171 unsigned long nelemen
;
1177 gfc_constructor
*cons
;
1184 mpz_init_set_ui (offset
, 0);
1187 mpz_init_set_ui (span
, 1);
1188 for (i
= 0; i
< ar
->dimen
; i
++)
1190 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1191 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1198 e
= gfc_copy_expr (ar
->start
[i
]);
1199 if (e
->expr_type
!= EXPR_CONSTANT
)
1205 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1206 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1208 /* Check the bounds. */
1209 if ((ar
->as
->upper
[i
]
1210 && mpz_cmp (e
->value
.integer
,
1211 ar
->as
->upper
[i
]->value
.integer
) > 0)
1212 || (mpz_cmp (e
->value
.integer
,
1213 ar
->as
->lower
[i
]->value
.integer
) < 0))
1215 gfc_error ("Index in dimension %d is out of bounds "
1216 "at %L", i
+ 1, &ar
->c_where
[i
]);
1222 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1223 mpz_mul (delta
, delta
, span
);
1224 mpz_add (offset
, offset
, delta
);
1226 mpz_set_ui (tmp
, 1);
1227 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1228 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1229 mpz_mul (span
, span
, tmp
);
1232 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1233 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1254 /* Find a component of a structure constructor. */
1256 static gfc_constructor
*
1257 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1259 gfc_component
*comp
;
1260 gfc_component
*pick
;
1261 gfc_constructor
*c
= gfc_constructor_first (base
);
1263 comp
= ref
->u
.c
.sym
->components
;
1264 pick
= ref
->u
.c
.component
;
1265 while (comp
!= pick
)
1268 c
= gfc_constructor_next (c
);
1275 /* Replace an expression with the contents of a constructor, removing
1276 the subobject reference in the process. */
1279 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1289 e
= gfc_copy_expr (p
);
1290 e
->ref
= p
->ref
->next
;
1291 p
->ref
->next
= NULL
;
1292 gfc_replace_expr (p
, e
);
1296 /* Pull an array section out of an array constructor. */
1299 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1306 long unsigned one
= 1;
1308 mpz_t start
[GFC_MAX_DIMENSIONS
];
1309 mpz_t end
[GFC_MAX_DIMENSIONS
];
1310 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1311 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1312 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1317 gfc_constructor_base base
;
1318 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1328 base
= expr
->value
.constructor
;
1329 expr
->value
.constructor
= NULL
;
1331 rank
= ref
->u
.ar
.as
->rank
;
1333 if (expr
->shape
== NULL
)
1334 expr
->shape
= gfc_get_shape (rank
);
1336 mpz_init_set_ui (delta_mpz
, one
);
1337 mpz_init_set_ui (nelts
, one
);
1340 /* Do the initialization now, so that we can cleanup without
1341 keeping track of where we were. */
1342 for (d
= 0; d
< rank
; d
++)
1344 mpz_init (delta
[d
]);
1345 mpz_init (start
[d
]);
1348 mpz_init (stride
[d
]);
1352 /* Build the counters to clock through the array reference. */
1354 for (d
= 0; d
< rank
; d
++)
1356 /* Make this stretch of code easier on the eye! */
1357 begin
= ref
->u
.ar
.start
[d
];
1358 finish
= ref
->u
.ar
.end
[d
];
1359 step
= ref
->u
.ar
.stride
[d
];
1360 lower
= ref
->u
.ar
.as
->lower
[d
];
1361 upper
= ref
->u
.ar
.as
->upper
[d
];
1363 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1365 gfc_constructor
*ci
;
1368 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1374 gcc_assert (begin
->rank
== 1);
1375 /* Zero-sized arrays have no shape and no elements, stop early. */
1378 mpz_init_set_ui (nelts
, 0);
1382 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1383 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1384 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1385 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1388 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1390 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1391 || mpz_cmp (ci
->expr
->value
.integer
,
1392 lower
->value
.integer
) < 0)
1394 gfc_error ("index in dimension %d is out of bounds "
1395 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1403 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1404 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1405 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1411 /* Obtain the stride. */
1413 mpz_set (stride
[d
], step
->value
.integer
);
1415 mpz_set_ui (stride
[d
], one
);
1417 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1418 mpz_set_ui (stride
[d
], one
);
1420 /* Obtain the start value for the index. */
1422 mpz_set (start
[d
], begin
->value
.integer
);
1424 mpz_set (start
[d
], lower
->value
.integer
);
1426 mpz_set (ctr
[d
], start
[d
]);
1428 /* Obtain the end value for the index. */
1430 mpz_set (end
[d
], finish
->value
.integer
);
1432 mpz_set (end
[d
], upper
->value
.integer
);
1434 /* Separate 'if' because elements sometimes arrive with
1436 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1437 mpz_set (end
[d
], begin
->value
.integer
);
1439 /* Check the bounds. */
1440 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1441 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1442 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1443 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1445 gfc_error ("index in dimension %d is out of bounds "
1446 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1451 /* Calculate the number of elements and the shape. */
1452 mpz_set (tmp_mpz
, stride
[d
]);
1453 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1454 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1455 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1456 mpz_mul (nelts
, nelts
, tmp_mpz
);
1458 /* An element reference reduces the rank of the expression; don't
1459 add anything to the shape array. */
1460 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1461 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1464 /* Calculate the 'stride' (=delta) for conversion of the
1465 counter values into the index along the constructor. */
1466 mpz_set (delta
[d
], delta_mpz
);
1467 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1468 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1469 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1473 cons
= gfc_constructor_first (base
);
1475 /* Now clock through the array reference, calculating the index in
1476 the source constructor and transferring the elements to the new
1478 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1480 if (ref
->u
.ar
.offset
)
1481 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1483 mpz_init_set_ui (ptr
, 0);
1486 for (d
= 0; d
< rank
; d
++)
1488 mpz_set (tmp_mpz
, ctr
[d
]);
1489 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1490 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1491 mpz_add (ptr
, ptr
, tmp_mpz
);
1493 if (!incr_ctr
) continue;
1495 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1497 gcc_assert(vecsub
[d
]);
1499 if (!gfc_constructor_next (vecsub
[d
]))
1500 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1503 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1506 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1510 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1512 if (mpz_cmp_ui (stride
[d
], 0) > 0
1513 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1514 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1515 mpz_set (ctr
[d
], start
[d
]);
1521 limit
= mpz_get_ui (ptr
);
1522 if (limit
>= gfc_option
.flag_max_array_constructor
)
1524 gfc_error ("The number of elements in the array constructor "
1525 "at %L requires an increase of the allowed %d "
1526 "upper limit. See -fmax-array-constructor "
1527 "option", &expr
->where
,
1528 gfc_option
.flag_max_array_constructor
);
1532 cons
= gfc_constructor_lookup (base
, limit
);
1534 gfc_constructor_append_expr (&expr
->value
.constructor
,
1535 gfc_copy_expr (cons
->expr
), NULL
);
1542 mpz_clear (delta_mpz
);
1543 mpz_clear (tmp_mpz
);
1545 for (d
= 0; d
< rank
; d
++)
1547 mpz_clear (delta
[d
]);
1548 mpz_clear (start
[d
]);
1551 mpz_clear (stride
[d
]);
1553 gfc_constructor_free (base
);
1557 /* Pull a substring out of an expression. */
1560 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1567 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1568 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1571 *newp
= gfc_copy_expr (p
);
1572 free ((*newp
)->value
.character
.string
);
1574 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1575 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1576 length
= end
- start
+ 1;
1578 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1579 (*newp
)->value
.character
.length
= length
;
1580 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1581 length
* sizeof (gfc_char_t
));
1588 /* Simplify a subobject reference of a constructor. This occurs when
1589 parameter variable values are substituted. */
1592 simplify_const_ref (gfc_expr
*p
)
1594 gfc_constructor
*cons
, *c
;
1600 switch (p
->ref
->type
)
1603 switch (p
->ref
->u
.ar
.type
)
1606 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1607 will generate this. */
1608 if (p
->expr_type
!= EXPR_ARRAY
)
1610 remove_subobject_ref (p
, NULL
);
1613 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1620 remove_subobject_ref (p
, cons
);
1624 if (find_array_section (p
, p
->ref
) == FAILURE
)
1626 p
->ref
->u
.ar
.type
= AR_FULL
;
1631 if (p
->ref
->next
!= NULL
1632 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1634 for (c
= gfc_constructor_first (p
->value
.constructor
);
1635 c
; c
= gfc_constructor_next (c
))
1637 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1638 if (simplify_const_ref (c
->expr
) == FAILURE
)
1642 if (p
->ts
.type
== BT_DERIVED
1644 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1646 /* There may have been component references. */
1647 p
->ts
= c
->expr
->ts
;
1651 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1653 if (p
->ts
.type
== BT_CHARACTER
1654 && last_ref
->type
== REF_SUBSTRING
)
1656 /* If this is a CHARACTER array and we possibly took
1657 a substring out of it, update the type-spec's
1658 character length according to the first element
1659 (as all should have the same length). */
1661 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1663 const gfc_expr
* first
= c
->expr
;
1664 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1665 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1666 string_len
= first
->value
.character
.length
;
1672 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1675 gfc_free_expr (p
->ts
.u
.cl
->length
);
1678 = gfc_get_int_expr (gfc_default_integer_kind
,
1682 gfc_free_ref_list (p
->ref
);
1693 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1694 remove_subobject_ref (p
, cons
);
1698 if (find_substring_ref (p
, &newp
) == FAILURE
)
1701 gfc_replace_expr (p
, newp
);
1702 gfc_free_ref_list (p
->ref
);
1712 /* Simplify a chain of references. */
1715 simplify_ref_chain (gfc_ref
*ref
, int type
)
1719 for (; ref
; ref
= ref
->next
)
1724 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1726 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1728 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1730 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1736 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1738 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1750 /* Try to substitute the value of a parameter variable. */
1753 simplify_parameter_variable (gfc_expr
*p
, int type
)
1758 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1764 /* Do not copy subobject refs for constant. */
1765 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1766 e
->ref
= gfc_copy_ref (p
->ref
);
1767 t
= gfc_simplify_expr (e
, type
);
1769 /* Only use the simplification if it eliminated all subobject references. */
1770 if (t
== SUCCESS
&& !e
->ref
)
1771 gfc_replace_expr (p
, e
);
1778 /* Given an expression, simplify it by collapsing constant
1779 expressions. Most simplification takes place when the expression
1780 tree is being constructed. If an intrinsic function is simplified
1781 at some point, we get called again to collapse the result against
1784 We work by recursively simplifying expression nodes, simplifying
1785 intrinsic functions where possible, which can lead to further
1786 constant collapsing. If an operator has constant operand(s), we
1787 rip the expression apart, and rebuild it, hoping that it becomes
1790 The expression type is defined for:
1791 0 Basic expression parsing
1792 1 Simplifying array constructors -- will substitute
1794 Returns FAILURE on error, SUCCESS otherwise.
1795 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1798 gfc_simplify_expr (gfc_expr
*p
, int type
)
1800 gfc_actual_arglist
*ap
;
1805 switch (p
->expr_type
)
1812 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1813 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1816 if (p
->value
.function
.isym
!= NULL
1817 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1822 case EXPR_SUBSTRING
:
1823 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1826 if (gfc_is_constant_expr (p
))
1832 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1834 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1835 start
--; /* Convert from one-based to zero-based. */
1838 end
= p
->value
.character
.length
;
1839 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1840 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1845 s
= gfc_get_wide_string (end
- start
+ 2);
1846 memcpy (s
, p
->value
.character
.string
+ start
,
1847 (end
- start
) * sizeof (gfc_char_t
));
1848 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1849 free (p
->value
.character
.string
);
1850 p
->value
.character
.string
= s
;
1851 p
->value
.character
.length
= end
- start
;
1852 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1853 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1855 p
->value
.character
.length
);
1856 gfc_free_ref_list (p
->ref
);
1858 p
->expr_type
= EXPR_CONSTANT
;
1863 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1868 /* Only substitute array parameter variables if we are in an
1869 initialization expression, or we want a subsection. */
1870 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1871 && (gfc_init_expr_flag
|| p
->ref
1872 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1874 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1881 gfc_simplify_iterator_var (p
);
1884 /* Simplify subcomponent references. */
1885 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1890 case EXPR_STRUCTURE
:
1892 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1895 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1898 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1899 && p
->ref
->u
.ar
.type
== AR_FULL
)
1900 gfc_expand_constructor (p
, false);
1902 if (simplify_const_ref (p
) == FAILURE
)
1917 /* Returns the type of an expression with the exception that iterator
1918 variables are automatically integers no matter what else they may
1924 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1931 /* Check an intrinsic arithmetic operation to see if it is consistent
1932 with some type of expression. */
1934 static gfc_try
check_init_expr (gfc_expr
*);
1937 /* Scalarize an expression for an elemental intrinsic call. */
1940 scalarize_intrinsic_call (gfc_expr
*e
)
1942 gfc_actual_arglist
*a
, *b
;
1943 gfc_constructor_base ctor
;
1944 gfc_constructor
*args
[5];
1945 gfc_constructor
*ci
, *new_ctor
;
1946 gfc_expr
*expr
, *old
;
1947 int n
, i
, rank
[5], array_arg
;
1949 /* Find which, if any, arguments are arrays. Assume that the old
1950 expression carries the type information and that the first arg
1951 that is an array expression carries all the shape information.*/
1953 a
= e
->value
.function
.actual
;
1954 for (; a
; a
= a
->next
)
1957 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1960 expr
= gfc_copy_expr (a
->expr
);
1967 old
= gfc_copy_expr (e
);
1969 gfc_constructor_free (expr
->value
.constructor
);
1970 expr
->value
.constructor
= NULL
;
1972 expr
->where
= old
->where
;
1973 expr
->expr_type
= EXPR_ARRAY
;
1975 /* Copy the array argument constructors into an array, with nulls
1978 a
= old
->value
.function
.actual
;
1979 for (; a
; a
= a
->next
)
1981 /* Check that this is OK for an initialization expression. */
1982 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1986 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1988 rank
[n
] = a
->expr
->rank
;
1989 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1990 args
[n
] = gfc_constructor_first (ctor
);
1992 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1995 rank
[n
] = a
->expr
->rank
;
1998 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
1999 args
[n
] = gfc_constructor_first (ctor
);
2008 /* Using the array argument as the master, step through the array
2009 calling the function for each element and advancing the array
2010 constructors together. */
2011 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2013 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2014 gfc_copy_expr (old
), NULL
);
2016 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2018 b
= old
->value
.function
.actual
;
2019 for (i
= 0; i
< n
; i
++)
2022 new_ctor
->expr
->value
.function
.actual
2023 = a
= gfc_get_actual_arglist ();
2026 a
->next
= gfc_get_actual_arglist ();
2031 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2033 a
->expr
= gfc_copy_expr (b
->expr
);
2038 /* Simplify the function calls. If the simplification fails, the
2039 error will be flagged up down-stream or the library will deal
2041 gfc_simplify_expr (new_ctor
->expr
, 0);
2043 for (i
= 0; i
< n
; i
++)
2045 args
[i
] = gfc_constructor_next (args
[i
]);
2047 for (i
= 1; i
< n
; i
++)
2048 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2049 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2055 gfc_free_expr (old
);
2059 gfc_error_now ("elemental function arguments at %C are not compliant");
2062 gfc_free_expr (expr
);
2063 gfc_free_expr (old
);
2069 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2071 gfc_expr
*op1
= e
->value
.op
.op1
;
2072 gfc_expr
*op2
= e
->value
.op
.op2
;
2074 if ((*check_function
) (op1
) == FAILURE
)
2077 switch (e
->value
.op
.op
)
2079 case INTRINSIC_UPLUS
:
2080 case INTRINSIC_UMINUS
:
2081 if (!numeric_type (et0 (op1
)))
2086 case INTRINSIC_EQ_OS
:
2088 case INTRINSIC_NE_OS
:
2090 case INTRINSIC_GT_OS
:
2092 case INTRINSIC_GE_OS
:
2094 case INTRINSIC_LT_OS
:
2096 case INTRINSIC_LE_OS
:
2097 if ((*check_function
) (op2
) == FAILURE
)
2100 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2101 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2103 gfc_error ("Numeric or CHARACTER operands are required in "
2104 "expression at %L", &e
->where
);
2109 case INTRINSIC_PLUS
:
2110 case INTRINSIC_MINUS
:
2111 case INTRINSIC_TIMES
:
2112 case INTRINSIC_DIVIDE
:
2113 case INTRINSIC_POWER
:
2114 if ((*check_function
) (op2
) == FAILURE
)
2117 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2122 case INTRINSIC_CONCAT
:
2123 if ((*check_function
) (op2
) == FAILURE
)
2126 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2128 gfc_error ("Concatenation operator in expression at %L "
2129 "must have two CHARACTER operands", &op1
->where
);
2133 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2135 gfc_error ("Concat operator at %L must concatenate strings of the "
2136 "same kind", &e
->where
);
2143 if (et0 (op1
) != BT_LOGICAL
)
2145 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2146 "operand", &op1
->where
);
2155 case INTRINSIC_NEQV
:
2156 if ((*check_function
) (op2
) == FAILURE
)
2159 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2161 gfc_error ("LOGICAL operands are required in expression at %L",
2168 case INTRINSIC_PARENTHESES
:
2172 gfc_error ("Only intrinsic operators can be used in expression at %L",
2180 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2185 /* F2003, 7.1.7 (3): In init expression, allocatable components
2186 must not be data-initialized. */
2188 check_alloc_comp_init (gfc_expr
*e
)
2190 gfc_component
*comp
;
2191 gfc_constructor
*ctor
;
2193 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2194 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2196 for (comp
= e
->ts
.u
.derived
->components
,
2197 ctor
= gfc_constructor_first (e
->value
.constructor
);
2198 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2200 if (comp
->attr
.allocatable
2201 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2203 gfc_error("Invalid initialization expression for ALLOCATABLE "
2204 "component '%s' in structure constructor at %L",
2205 comp
->name
, &ctor
->expr
->where
);
2214 check_init_expr_arguments (gfc_expr
*e
)
2216 gfc_actual_arglist
*ap
;
2218 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2219 if (check_init_expr (ap
->expr
) == FAILURE
)
2225 static gfc_try
check_restricted (gfc_expr
*);
2227 /* F95, 7.1.6.1, Initialization expressions, (7)
2228 F2003, 7.1.7 Initialization expression, (8) */
2231 check_inquiry (gfc_expr
*e
, int not_restricted
)
2234 const char *const *functions
;
2236 static const char *const inquiry_func_f95
[] = {
2237 "lbound", "shape", "size", "ubound",
2238 "bit_size", "len", "kind",
2239 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2240 "precision", "radix", "range", "tiny",
2244 static const char *const inquiry_func_f2003
[] = {
2245 "lbound", "shape", "size", "ubound",
2246 "bit_size", "len", "kind",
2247 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2248 "precision", "radix", "range", "tiny",
2253 gfc_actual_arglist
*ap
;
2255 if (!e
->value
.function
.isym
2256 || !e
->value
.function
.isym
->inquiry
)
2259 /* An undeclared parameter will get us here (PR25018). */
2260 if (e
->symtree
== NULL
)
2263 name
= e
->symtree
->n
.sym
->name
;
2265 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2266 ? inquiry_func_f2003
: inquiry_func_f95
;
2268 for (i
= 0; functions
[i
]; i
++)
2269 if (strcmp (functions
[i
], name
) == 0)
2272 if (functions
[i
] == NULL
)
2275 /* At this point we have an inquiry function with a variable argument. The
2276 type of the variable might be undefined, but we need it now, because the
2277 arguments of these functions are not allowed to be undefined. */
2279 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2284 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2286 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2287 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2291 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2294 /* Assumed character length will not reduce to a constant expression
2295 with LEN, as required by the standard. */
2296 if (i
== 5 && not_restricted
2297 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2298 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2299 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2301 gfc_error ("Assumed or deferred character length variable '%s' "
2302 " in constant expression at %L",
2303 ap
->expr
->symtree
->n
.sym
->name
,
2307 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2310 if (not_restricted
== 0
2311 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2312 && check_restricted (ap
->expr
) == FAILURE
)
2315 if (not_restricted
== 0
2316 && ap
->expr
->expr_type
== EXPR_VARIABLE
2317 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2318 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2326 /* F95, 7.1.6.1, Initialization expressions, (5)
2327 F2003, 7.1.7 Initialization expression, (5) */
2330 check_transformational (gfc_expr
*e
)
2332 static const char * const trans_func_f95
[] = {
2333 "repeat", "reshape", "selected_int_kind",
2334 "selected_real_kind", "transfer", "trim", NULL
2337 static const char * const trans_func_f2003
[] = {
2338 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2339 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2340 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2341 "trim", "unpack", NULL
2346 const char *const *functions
;
2348 if (!e
->value
.function
.isym
2349 || !e
->value
.function
.isym
->transformational
)
2352 name
= e
->symtree
->n
.sym
->name
;
2354 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2355 ? trans_func_f2003
: trans_func_f95
;
2357 /* NULL() is dealt with below. */
2358 if (strcmp ("null", name
) == 0)
2361 for (i
= 0; functions
[i
]; i
++)
2362 if (strcmp (functions
[i
], name
) == 0)
2365 if (functions
[i
] == NULL
)
2367 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2368 "in an initialization expression", name
, &e
->where
);
2372 return check_init_expr_arguments (e
);
2376 /* F95, 7.1.6.1, Initialization expressions, (6)
2377 F2003, 7.1.7 Initialization expression, (6) */
2380 check_null (gfc_expr
*e
)
2382 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2385 return check_init_expr_arguments (e
);
2390 check_elemental (gfc_expr
*e
)
2392 if (!e
->value
.function
.isym
2393 || !e
->value
.function
.isym
->elemental
)
2396 if (e
->ts
.type
!= BT_INTEGER
2397 && e
->ts
.type
!= BT_CHARACTER
2398 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2399 "nonstandard initialization expression at %L",
2400 &e
->where
) == FAILURE
)
2403 return check_init_expr_arguments (e
);
2408 check_conversion (gfc_expr
*e
)
2410 if (!e
->value
.function
.isym
2411 || !e
->value
.function
.isym
->conversion
)
2414 return check_init_expr_arguments (e
);
2418 /* Verify that an expression is an initialization expression. A side
2419 effect is that the expression tree is reduced to a single constant
2420 node if all goes well. This would normally happen when the
2421 expression is constructed but function references are assumed to be
2422 intrinsics in the context of initialization expressions. If
2423 FAILURE is returned an error message has been generated. */
2426 check_init_expr (gfc_expr
*e
)
2434 switch (e
->expr_type
)
2437 t
= check_intrinsic_op (e
, check_init_expr
);
2439 t
= gfc_simplify_expr (e
, 0);
2447 gfc_intrinsic_sym
* isym
;
2450 sym
= e
->symtree
->n
.sym
;
2451 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2452 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2454 gfc_error ("Function '%s' in initialization expression at %L "
2455 "must be an intrinsic function",
2456 e
->symtree
->n
.sym
->name
, &e
->where
);
2460 if ((m
= check_conversion (e
)) == MATCH_NO
2461 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2462 && (m
= check_null (e
)) == MATCH_NO
2463 && (m
= check_transformational (e
)) == MATCH_NO
2464 && (m
= check_elemental (e
)) == MATCH_NO
)
2466 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2467 "in an initialization expression",
2468 e
->symtree
->n
.sym
->name
, &e
->where
);
2472 /* Try to scalarize an elemental intrinsic function that has an
2474 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2475 if (isym
&& isym
->elemental
2476 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2481 t
= gfc_simplify_expr (e
, 0);
2488 if (gfc_check_iter_variable (e
) == SUCCESS
)
2491 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2493 /* A PARAMETER shall not be used to define itself, i.e.
2494 REAL, PARAMETER :: x = transfer(0, x)
2496 if (!e
->symtree
->n
.sym
->value
)
2498 gfc_error("PARAMETER '%s' is used at %L before its definition "
2499 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2503 t
= simplify_parameter_variable (e
, 0);
2508 if (gfc_in_match_data ())
2513 if (e
->symtree
->n
.sym
->as
)
2515 switch (e
->symtree
->n
.sym
->as
->type
)
2517 case AS_ASSUMED_SIZE
:
2518 gfc_error ("Assumed size array '%s' at %L is not permitted "
2519 "in an initialization expression",
2520 e
->symtree
->n
.sym
->name
, &e
->where
);
2523 case AS_ASSUMED_SHAPE
:
2524 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2525 "in an initialization expression",
2526 e
->symtree
->n
.sym
->name
, &e
->where
);
2530 gfc_error ("Deferred array '%s' at %L is not permitted "
2531 "in an initialization expression",
2532 e
->symtree
->n
.sym
->name
, &e
->where
);
2536 gfc_error ("Array '%s' at %L is a variable, which does "
2537 "not reduce to a constant expression",
2538 e
->symtree
->n
.sym
->name
, &e
->where
);
2546 gfc_error ("Parameter '%s' at %L has not been declared or is "
2547 "a variable, which does not reduce to a constant "
2548 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2557 case EXPR_SUBSTRING
:
2558 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2562 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2564 t
= gfc_simplify_expr (e
, 0);
2568 case EXPR_STRUCTURE
:
2569 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2573 t
= check_alloc_comp_init (e
);
2577 t
= gfc_check_constructor (e
, check_init_expr
);
2584 t
= gfc_check_constructor (e
, check_init_expr
);
2588 t
= gfc_expand_constructor (e
, true);
2592 t
= gfc_check_constructor_type (e
);
2596 gfc_internal_error ("check_init_expr(): Unknown expression type");
2602 /* Reduces a general expression to an initialization expression (a constant).
2603 This used to be part of gfc_match_init_expr.
2604 Note that this function doesn't free the given expression on FAILURE. */
2607 gfc_reduce_init_expr (gfc_expr
*expr
)
2611 gfc_init_expr_flag
= true;
2612 t
= gfc_resolve_expr (expr
);
2614 t
= check_init_expr (expr
);
2615 gfc_init_expr_flag
= false;
2620 if (expr
->expr_type
== EXPR_ARRAY
)
2622 if (gfc_check_constructor_type (expr
) == FAILURE
)
2624 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2632 /* Match an initialization expression. We work by first matching an
2633 expression, then reducing it to a constant. */
2636 gfc_match_init_expr (gfc_expr
**result
)
2644 gfc_init_expr_flag
= true;
2646 m
= gfc_match_expr (&expr
);
2649 gfc_init_expr_flag
= false;
2653 t
= gfc_reduce_init_expr (expr
);
2656 gfc_free_expr (expr
);
2657 gfc_init_expr_flag
= false;
2662 gfc_init_expr_flag
= false;
2668 /* Given an actual argument list, test to see that each argument is a
2669 restricted expression and optionally if the expression type is
2670 integer or character. */
2673 restricted_args (gfc_actual_arglist
*a
)
2675 for (; a
; a
= a
->next
)
2677 if (check_restricted (a
->expr
) == FAILURE
)
2685 /************* Restricted/specification expressions *************/
2688 /* Make sure a non-intrinsic function is a specification function. */
2691 external_spec_function (gfc_expr
*e
)
2695 f
= e
->value
.function
.esym
;
2697 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2699 gfc_error ("Specification function '%s' at %L cannot be a statement "
2700 "function", f
->name
, &e
->where
);
2704 if (f
->attr
.proc
== PROC_INTERNAL
)
2706 gfc_error ("Specification function '%s' at %L cannot be an internal "
2707 "function", f
->name
, &e
->where
);
2711 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2713 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2718 if (f
->attr
.recursive
)
2720 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2721 f
->name
, &e
->where
);
2725 return restricted_args (e
->value
.function
.actual
);
2729 /* Check to see that a function reference to an intrinsic is a
2730 restricted expression. */
2733 restricted_intrinsic (gfc_expr
*e
)
2735 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2736 if (check_inquiry (e
, 0) == MATCH_YES
)
2739 return restricted_args (e
->value
.function
.actual
);
2743 /* Check the expressions of an actual arglist. Used by check_restricted. */
2746 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2748 for (; arg
; arg
= arg
->next
)
2749 if (checker (arg
->expr
) == FAILURE
)
2756 /* Check the subscription expressions of a reference chain with a checking
2757 function; used by check_restricted. */
2760 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2770 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2772 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2774 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2776 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2782 /* Nothing needed, just proceed to next reference. */
2786 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2788 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2797 return check_references (ref
->next
, checker
);
2801 /* Verify that an expression is a restricted expression. Like its
2802 cousin check_init_expr(), an error message is generated if we
2806 check_restricted (gfc_expr
*e
)
2814 switch (e
->expr_type
)
2817 t
= check_intrinsic_op (e
, check_restricted
);
2819 t
= gfc_simplify_expr (e
, 0);
2824 if (e
->value
.function
.esym
)
2826 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2828 t
= external_spec_function (e
);
2832 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2835 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2838 t
= restricted_intrinsic (e
);
2843 sym
= e
->symtree
->n
.sym
;
2846 /* If a dummy argument appears in a context that is valid for a
2847 restricted expression in an elemental procedure, it will have
2848 already been simplified away once we get here. Therefore we
2849 don't need to jump through hoops to distinguish valid from
2851 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2852 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2854 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2855 sym
->name
, &e
->where
);
2859 if (sym
->attr
.optional
)
2861 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2862 sym
->name
, &e
->where
);
2866 if (sym
->attr
.intent
== INTENT_OUT
)
2868 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2869 sym
->name
, &e
->where
);
2873 /* Check reference chain if any. */
2874 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2877 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2878 processed in resolve.c(resolve_formal_arglist). This is done so
2879 that host associated dummy array indices are accepted (PR23446).
2880 This mechanism also does the same for the specification expressions
2881 of array-valued functions. */
2883 || sym
->attr
.in_common
2884 || sym
->attr
.use_assoc
2886 || sym
->attr
.implied_index
2887 || sym
->attr
.flavor
== FL_PARAMETER
2888 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2889 || (sym
->ns
&& gfc_current_ns
->parent
2890 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2891 || (sym
->ns
->proc_name
!= NULL
2892 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2893 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2899 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2900 sym
->name
, &e
->where
);
2901 /* Prevent a repetition of the error. */
2910 case EXPR_SUBSTRING
:
2911 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2915 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2917 t
= gfc_simplify_expr (e
, 0);
2921 case EXPR_STRUCTURE
:
2922 t
= gfc_check_constructor (e
, check_restricted
);
2926 t
= gfc_check_constructor (e
, check_restricted
);
2930 gfc_internal_error ("check_restricted(): Unknown expression type");
2937 /* Check to see that an expression is a specification expression. If
2938 we return FAILURE, an error has been generated. */
2941 gfc_specification_expr (gfc_expr
*e
)
2943 gfc_component
*comp
;
2948 if (e
->ts
.type
!= BT_INTEGER
)
2950 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2951 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2955 if (e
->expr_type
== EXPR_FUNCTION
2956 && !e
->value
.function
.isym
2957 && !e
->value
.function
.esym
2958 && !gfc_pure (e
->symtree
->n
.sym
)
2959 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2960 || !comp
->attr
.pure
))
2962 gfc_error ("Function '%s' at %L must be PURE",
2963 e
->symtree
->n
.sym
->name
, &e
->where
);
2964 /* Prevent repeat error messages. */
2965 e
->symtree
->n
.sym
->attr
.pure
= 1;
2971 gfc_error ("Expression at %L must be scalar", &e
->where
);
2975 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2978 return check_restricted (e
);
2982 /************** Expression conformance checks. *************/
2984 /* Given two expressions, make sure that the arrays are conformable. */
2987 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
2989 int op1_flag
, op2_flag
, d
;
2990 mpz_t op1_size
, op2_size
;
2996 if (op1
->rank
== 0 || op2
->rank
== 0)
2999 va_start (argp
, optype_msgid
);
3000 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3003 if (op1
->rank
!= op2
->rank
)
3005 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3006 op1
->rank
, op2
->rank
, &op1
->where
);
3012 for (d
= 0; d
< op1
->rank
; d
++)
3014 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3015 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3017 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3019 gfc_error ("Different shape for %s at %L on dimension %d "
3020 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3021 (int) mpz_get_si (op1_size
),
3022 (int) mpz_get_si (op2_size
));
3028 mpz_clear (op1_size
);
3030 mpz_clear (op2_size
);
3040 /* Given an assignable expression and an arbitrary expression, make
3041 sure that the assignment can take place. */
3044 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3050 sym
= lvalue
->symtree
->n
.sym
;
3052 /* See if this is the component or subcomponent of a pointer. */
3053 has_pointer
= sym
->attr
.pointer
;
3054 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3055 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3061 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3062 variable local to a function subprogram. Its existence begins when
3063 execution of the function is initiated and ends when execution of the
3064 function is terminated...
3065 Therefore, the left hand side is no longer a variable, when it is: */
3066 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3067 && !sym
->attr
.external
)
3072 /* (i) Use associated; */
3073 if (sym
->attr
.use_assoc
)
3076 /* (ii) The assignment is in the main program; or */
3077 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3080 /* (iii) A module or internal procedure... */
3081 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3082 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3083 && gfc_current_ns
->parent
3084 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3085 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3086 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3088 /* ... that is not a function... */
3089 if (!gfc_current_ns
->proc_name
->attr
.function
)
3092 /* ... or is not an entry and has a different name. */
3093 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3097 /* (iv) Host associated and not the function symbol or the
3098 parent result. This picks up sibling references, which
3099 cannot be entries. */
3100 if (!sym
->attr
.entry
3101 && sym
->ns
== gfc_current_ns
->parent
3102 && sym
!= gfc_current_ns
->proc_name
3103 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3108 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3113 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3115 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3116 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3120 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3122 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3127 if (rvalue
->expr_type
== EXPR_NULL
)
3129 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3130 && lvalue
->symtree
->n
.sym
->attr
.data
)
3134 gfc_error ("NULL appears on right-hand side in assignment at %L",
3140 /* This is possibly a typo: x = f() instead of x => f(). */
3141 if (gfc_option
.warn_surprising
3142 && rvalue
->expr_type
== EXPR_FUNCTION
3143 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3144 gfc_warning ("POINTER valued function appears on right-hand side of "
3145 "assignment at %L", &rvalue
->where
);
3147 /* Check size of array assignments. */
3148 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3149 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3152 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3153 && lvalue
->symtree
->n
.sym
->attr
.data
3154 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3155 "initialize non-integer variable '%s'",
3156 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3159 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3160 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3161 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3162 &rvalue
->where
) == FAILURE
)
3165 /* Handle the case of a BOZ literal on the RHS. */
3166 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3169 if (gfc_option
.warn_surprising
)
3170 gfc_warning ("BOZ literal at %L is bitwise transferred "
3171 "non-integer symbol '%s'", &rvalue
->where
,
3172 lvalue
->symtree
->n
.sym
->name
);
3173 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3175 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3177 if (rc
== ARITH_UNDERFLOW
)
3178 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3179 ". This check can be disabled with the option "
3180 "-fno-range-check", &rvalue
->where
);
3181 else if (rc
== ARITH_OVERFLOW
)
3182 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3183 ". This check can be disabled with the option "
3184 "-fno-range-check", &rvalue
->where
);
3185 else if (rc
== ARITH_NAN
)
3186 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3187 ". This check can be disabled with the option "
3188 "-fno-range-check", &rvalue
->where
);
3193 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3194 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3195 will warn anyway, so there is no need to to so here. */
3197 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3198 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3200 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3202 /* As a special bonus, don't warn about REAL rvalues which are not
3203 changed by the conversion if -Wconversion is specified. */
3204 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3206 /* Calculate the difference between the constant and the rounded
3207 value and check it against zero. */
3209 gfc_set_model_kind (lvalue
->ts
.kind
);
3211 gfc_set_model_kind (rvalue
->ts
.kind
);
3214 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3215 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3217 if (!mpfr_zero_p (diff
))
3218 gfc_warning ("Change of value in conversion from "
3219 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3220 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3226 gfc_warning ("Possible change of value in conversion from %s "
3227 "to %s at %L",gfc_typename (&rvalue
->ts
),
3228 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3231 else if (gfc_option
.warn_conversion_extra
3232 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3234 gfc_warning ("Conversion from %s to %s at %L",
3235 gfc_typename (&rvalue
->ts
),
3236 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3240 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3243 /* Only DATA Statements come here. */
3246 /* Numeric can be converted to any other numeric. And Hollerith can be
3247 converted to any other type. */
3248 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3249 || rvalue
->ts
.type
== BT_HOLLERITH
)
3252 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3255 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3256 "conversion of %s to %s", &lvalue
->where
,
3257 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3262 /* Assignment is the only case where character variables of different
3263 kind values can be converted into one another. */
3264 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3266 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3267 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3272 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3276 /* Check that a pointer assignment is OK. We first check lvalue, and
3277 we only check rvalue if it's not an assignment to NULL() or a
3278 NULLIFY statement. */
3281 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3283 symbol_attribute attr
;
3285 bool is_pure
, is_implicit_pure
, rank_remap
;
3288 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3289 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3291 gfc_error ("Pointer assignment target is not a POINTER at %L",
3296 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3297 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3298 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3300 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3301 "l-value since it is a procedure",
3302 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3306 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3309 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3311 if (ref
->type
== REF_COMPONENT
)
3312 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3314 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3318 if (ref
->u
.ar
.type
== AR_FULL
)
3321 if (ref
->u
.ar
.type
!= AR_SECTION
)
3323 gfc_error ("Expected bounds specification for '%s' at %L",
3324 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3328 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3329 "specification for '%s' in pointer assignment "
3330 "at %L", lvalue
->symtree
->n
.sym
->name
,
3331 &lvalue
->where
) == FAILURE
)
3334 /* When bounds are given, all lbounds are necessary and either all
3335 or none of the upper bounds; no strides are allowed. If the
3336 upper bounds are present, we may do rank remapping. */
3337 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3339 if (!ref
->u
.ar
.start
[dim
]
3340 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3342 gfc_error ("Lower bound has to be present at %L",
3346 if (ref
->u
.ar
.stride
[dim
])
3348 gfc_error ("Stride must not be present at %L",
3354 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3357 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3358 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3360 gfc_error ("Either all or none of the upper bounds"
3361 " must be specified at %L", &lvalue
->where
);
3369 is_pure
= gfc_pure (NULL
);
3370 is_implicit_pure
= gfc_implicit_pure (NULL
);
3372 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3373 kind, etc for lvalue and rvalue must match, and rvalue must be a
3374 pure variable if we're in a pure function. */
3375 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3378 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3379 if (lvalue
->expr_type
== EXPR_VARIABLE
3380 && gfc_is_coindexed (lvalue
))
3383 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3384 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3386 gfc_error ("Pointer object at %L shall not have a coindex",
3392 /* Checks on rvalue for procedure pointer assignments. */
3397 gfc_component
*comp
;
3400 attr
= gfc_expr_attr (rvalue
);
3401 if (!((rvalue
->expr_type
== EXPR_NULL
)
3402 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3403 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3404 || (rvalue
->expr_type
== EXPR_VARIABLE
3405 && attr
.flavor
== FL_PROCEDURE
)))
3407 gfc_error ("Invalid procedure pointer assignment at %L",
3413 gfc_error ("Abstract interface '%s' is invalid "
3414 "in procedure pointer assignment at %L",
3415 rvalue
->symtree
->name
, &rvalue
->where
);
3418 /* Check for C727. */
3419 if (attr
.flavor
== FL_PROCEDURE
)
3421 if (attr
.proc
== PROC_ST_FUNCTION
)
3423 gfc_error ("Statement function '%s' is invalid "
3424 "in procedure pointer assignment at %L",
3425 rvalue
->symtree
->name
, &rvalue
->where
);
3428 if (attr
.proc
== PROC_INTERNAL
&&
3429 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3430 "invalid in procedure pointer assignment at %L",
3431 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3435 /* Ensure that the calling convention is the same. As other attributes
3436 such as DLLEXPORT may differ, one explicitly only tests for the
3437 calling conventions. */
3438 if (rvalue
->expr_type
== EXPR_VARIABLE
3439 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3440 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3442 symbol_attribute calls
;
3445 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3446 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3447 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3449 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3450 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3452 gfc_error ("Mismatch in the procedure pointer assignment "
3453 "at %L: mismatch in the calling convention",
3459 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3460 s1
= comp
->ts
.interface
;
3462 s1
= lvalue
->symtree
->n
.sym
;
3464 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3466 s2
= comp
->ts
.interface
;
3469 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3471 s2
= rvalue
->symtree
->n
.sym
->result
;
3472 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3476 s2
= rvalue
->symtree
->n
.sym
;
3477 name
= rvalue
->symtree
->n
.sym
->name
;
3480 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3483 gfc_error ("Interface mismatch in procedure pointer assignment "
3484 "at %L: %s", &rvalue
->where
, err
);
3491 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3493 gfc_error ("Different types in pointer assignment at %L; attempted "
3494 "assignment of %s to %s", &lvalue
->where
,
3495 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3499 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3501 gfc_error ("Different kind type parameters in pointer "
3502 "assignment at %L", &lvalue
->where
);
3506 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3508 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3512 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3513 /* Make sure the vtab is present. */
3514 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3516 /* Check rank remapping. */
3521 /* If this can be determined, check that the target must be at least as
3522 large as the pointer assigned to it is. */
3523 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3524 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3525 && mpz_cmp (rsize
, lsize
) < 0)
3527 gfc_error ("Rank remapping target is smaller than size of the"
3528 " pointer (%ld < %ld) at %L",
3529 mpz_get_si (rsize
), mpz_get_si (lsize
),
3534 /* The target must be either rank one or it must be simply contiguous
3535 and F2008 must be allowed. */
3536 if (rvalue
->rank
!= 1)
3538 if (!gfc_is_simply_contiguous (rvalue
, true))
3540 gfc_error ("Rank remapping target must be rank 1 or"
3541 " simply contiguous at %L", &rvalue
->where
);
3544 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Rank remapping"
3545 " target is not rank 1 at %L", &rvalue
->where
)
3551 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3552 if (rvalue
->expr_type
== EXPR_NULL
)
3555 if (lvalue
->ts
.type
== BT_CHARACTER
)
3557 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3562 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3563 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3565 attr
= gfc_expr_attr (rvalue
);
3567 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3569 gfc_error ("Target expression in pointer assignment "
3570 "at %L must deliver a pointer result",
3575 if (!attr
.target
&& !attr
.pointer
)
3577 gfc_error ("Pointer assignment target is neither TARGET "
3578 "nor POINTER at %L", &rvalue
->where
);
3582 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3584 gfc_error ("Bad target in pointer assignment in PURE "
3585 "procedure at %L", &rvalue
->where
);
3588 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3589 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3592 if (gfc_has_vector_index (rvalue
))
3594 gfc_error ("Pointer assignment with vector subscript "
3595 "on rhs at %L", &rvalue
->where
);
3599 if (attr
.is_protected
&& attr
.use_assoc
3600 && !(attr
.pointer
|| attr
.proc_pointer
))
3602 gfc_error ("Pointer assignment target has PROTECTED "
3603 "attribute at %L", &rvalue
->where
);
3607 /* F2008, C725. For PURE also C1283. */
3608 if (rvalue
->expr_type
== EXPR_VARIABLE
3609 && gfc_is_coindexed (rvalue
))
3612 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3613 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3615 gfc_error ("Data target at %L shall not have a coindex",
3625 /* Relative of gfc_check_assign() except that the lvalue is a single
3626 symbol. Used for initialization assignments. */
3629 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3634 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3636 lvalue
.expr_type
= EXPR_VARIABLE
;
3637 lvalue
.ts
= sym
->ts
;
3639 lvalue
.rank
= sym
->as
->rank
;
3640 lvalue
.symtree
= XCNEW (gfc_symtree
);
3641 lvalue
.symtree
->n
.sym
= sym
;
3642 lvalue
.where
= sym
->declared_at
;
3644 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3645 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
3646 && rvalue
->expr_type
== EXPR_NULL
))
3647 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3649 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3651 free (lvalue
.symtree
);
3656 if (sym
->attr
.pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3658 /* F08:C461. Additional checks for pointer initialization. */
3659 symbol_attribute attr
;
3660 attr
= gfc_expr_attr (rvalue
);
3661 if (attr
.allocatable
)
3663 gfc_error ("Pointer initialization target at %C "
3664 "must not be ALLOCATABLE ");
3667 if (!attr
.target
|| attr
.pointer
)
3669 gfc_error ("Pointer initialization target at %C "
3670 "must have the TARGET attribute");
3675 gfc_error ("Pointer initialization target at %C "
3676 "must have the SAVE attribute");
3681 if (sym
->attr
.proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3683 /* F08:C1220. Additional checks for procedure pointer initialization. */
3684 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3685 if (attr
.proc_pointer
)
3687 gfc_error ("Procedure pointer initialization target at %L "
3688 "may not be a procedure pointer", &rvalue
->where
);
3697 /* Check for default initializer; sym->value is not enough
3698 as it is also set for EXPR_NULL of allocatables. */
3701 gfc_has_default_initializer (gfc_symbol
*der
)
3705 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3706 for (c
= der
->components
; c
; c
= c
->next
)
3707 if (c
->ts
.type
== BT_DERIVED
)
3709 if (!c
->attr
.pointer
3710 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3722 /* Get an expression for a default initializer. */
3725 gfc_default_initializer (gfc_typespec
*ts
)
3728 gfc_component
*comp
;
3730 /* See if we have a default initializer in this, but not in nested
3731 types (otherwise we could use gfc_has_default_initializer()). */
3732 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3733 if (comp
->initializer
|| comp
->attr
.allocatable
3734 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3740 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3741 &ts
->u
.derived
->declared_at
);
3744 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3746 gfc_constructor
*ctor
= gfc_constructor_get();
3748 if (comp
->initializer
)
3749 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3751 if (comp
->attr
.allocatable
3752 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3754 ctor
->expr
= gfc_get_expr ();
3755 ctor
->expr
->expr_type
= EXPR_NULL
;
3756 ctor
->expr
->ts
= comp
->ts
;
3759 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3766 /* Given a symbol, create an expression node with that symbol as a
3767 variable. If the symbol is array valued, setup a reference of the
3771 gfc_get_variable_expr (gfc_symtree
*var
)
3775 e
= gfc_get_expr ();
3776 e
->expr_type
= EXPR_VARIABLE
;
3778 e
->ts
= var
->n
.sym
->ts
;
3780 if (var
->n
.sym
->as
!= NULL
)
3782 e
->rank
= var
->n
.sym
->as
->rank
;
3783 e
->ref
= gfc_get_ref ();
3784 e
->ref
->type
= REF_ARRAY
;
3785 e
->ref
->u
.ar
.type
= AR_FULL
;
3793 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3796 lval
= gfc_get_expr ();
3797 lval
->expr_type
= EXPR_VARIABLE
;
3798 lval
->where
= sym
->declared_at
;
3800 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3802 /* It will always be a full array. */
3803 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
3806 lval
->ref
= gfc_get_ref ();
3807 lval
->ref
->type
= REF_ARRAY
;
3808 lval
->ref
->u
.ar
.type
= AR_FULL
;
3809 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
3810 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
3811 lval
->ref
->u
.ar
.as
= sym
->as
;
3818 /* Returns the array_spec of a full array expression. A NULL is
3819 returned otherwise. */
3821 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3826 if (expr
->rank
== 0)
3829 /* Follow any component references. */
3830 if (expr
->expr_type
== EXPR_VARIABLE
3831 || expr
->expr_type
== EXPR_CONSTANT
)
3833 as
= expr
->symtree
->n
.sym
->as
;
3834 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3839 as
= ref
->u
.c
.component
->as
;
3847 switch (ref
->u
.ar
.type
)
3870 /* General expression traversal function. */
3873 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3874 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3879 gfc_actual_arglist
*args
;
3886 if ((*func
) (expr
, sym
, &f
))
3889 if (expr
->ts
.type
== BT_CHARACTER
3891 && expr
->ts
.u
.cl
->length
3892 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3893 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3896 switch (expr
->expr_type
)
3901 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3903 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3911 case EXPR_SUBSTRING
:
3914 case EXPR_STRUCTURE
:
3916 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3917 c
; c
= gfc_constructor_next (c
))
3919 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3923 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3925 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3927 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3929 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3936 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3938 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3954 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3956 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3958 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3960 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3966 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3968 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3973 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3974 && ref
->u
.c
.component
->ts
.u
.cl
3975 && ref
->u
.c
.component
->ts
.u
.cl
->length
3976 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
3978 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
3982 if (ref
->u
.c
.component
->as
)
3983 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
3984 + ref
->u
.c
.component
->as
->corank
; i
++)
3986 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3989 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4003 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4006 expr_set_symbols_referenced (gfc_expr
*expr
,
4007 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4008 int *f ATTRIBUTE_UNUSED
)
4010 if (expr
->expr_type
!= EXPR_VARIABLE
)
4012 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4017 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4019 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4023 /* Determine if an expression is a procedure pointer component. If yes, the
4024 argument 'comp' will point to the component (provided that 'comp' was
4028 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
4033 if (!expr
|| !expr
->ref
)
4040 if (ref
->type
== REF_COMPONENT
)
4042 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
4044 *comp
= ref
->u
.c
.component
;
4051 /* Walk an expression tree and check each variable encountered for being typed.
4052 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4053 mode as is a basic arithmetic expression using those; this is for things in
4056 INTEGER :: arr(n), n
4057 INTEGER :: arr(n + 1), n
4059 The namespace is needed for IMPLICIT typing. */
4061 static gfc_namespace
* check_typed_ns
;
4064 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4065 int* f ATTRIBUTE_UNUSED
)
4069 if (e
->expr_type
!= EXPR_VARIABLE
)
4072 gcc_assert (e
->symtree
);
4073 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4076 return (t
== FAILURE
);
4080 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4084 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4088 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4089 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4091 if (e
->expr_type
== EXPR_OP
)
4093 gfc_try t
= SUCCESS
;
4095 gcc_assert (e
->value
.op
.op1
);
4096 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4098 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4099 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4105 /* Otherwise, walk the expression and do it strictly. */
4106 check_typed_ns
= ns
;
4107 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4109 return error_found
? FAILURE
: SUCCESS
;
4112 /* Walk an expression tree and replace all symbols with a corresponding symbol
4113 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4114 statements. The boolean return value is required by gfc_traverse_expr. */
4117 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4119 if ((expr
->expr_type
== EXPR_VARIABLE
4120 || (expr
->expr_type
== EXPR_FUNCTION
4121 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4122 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
4125 gfc_namespace
*ns
= sym
->formal_ns
;
4126 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4127 the symtree rather than create a new one (and probably fail later). */
4128 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4129 expr
->symtree
->n
.sym
->name
);
4131 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4132 expr
->symtree
= stree
;
4138 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
4140 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
4143 /* The following is analogous to 'replace_symbol', and needed for copying
4144 interfaces for procedure pointer components. The argument 'sym' must formally
4145 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4146 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4147 component in whose formal_ns the arguments have to be). */
4150 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4152 gfc_component
*comp
;
4153 comp
= (gfc_component
*)sym
;
4154 if ((expr
->expr_type
== EXPR_VARIABLE
4155 || (expr
->expr_type
== EXPR_FUNCTION
4156 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4157 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4160 gfc_namespace
*ns
= comp
->formal_ns
;
4161 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4162 the symtree rather than create a new one (and probably fail later). */
4163 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4164 expr
->symtree
->n
.sym
->name
);
4166 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4167 expr
->symtree
= stree
;
4173 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4175 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4180 gfc_ref_this_image (gfc_ref
*ref
)
4184 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4186 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4187 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4195 gfc_is_coindexed (gfc_expr
*e
)
4199 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4200 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4201 return !gfc_ref_this_image (ref
);
4207 /* Coarrays are variables with a corank but not being coindexed. However, also
4208 the following is a coarray: A subobject of a coarray is a coarray if it does
4209 not have any cosubscripts, vector subscripts, allocatable component
4210 selection, or pointer component selection. (F2008, 2.4.7) */
4213 gfc_is_coarray (gfc_expr
*e
)
4217 gfc_component
*comp
;
4222 if (e
->expr_type
!= EXPR_VARIABLE
)
4226 sym
= e
->symtree
->n
.sym
;
4228 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4229 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4231 coarray
= sym
->attr
.codimension
;
4233 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4237 comp
= ref
->u
.c
.component
;
4238 if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4241 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
)
4242 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4244 coarray
= comp
->attr
.codimension
;
4252 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4258 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4259 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4270 return coarray
&& !coindexed
;
4275 gfc_get_corank (gfc_expr
*e
)
4279 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4280 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4282 if (ref
->type
== REF_ARRAY
)
4283 corank
= ref
->u
.ar
.as
->corank
;
4284 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4290 /* Check whether the expression has an ultimate allocatable component.
4291 Being itself allocatable does not count. */
4293 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4295 gfc_ref
*ref
, *last
= NULL
;
4297 if (e
->expr_type
!= EXPR_VARIABLE
)
4300 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4301 if (ref
->type
== REF_COMPONENT
)
4304 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4305 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4306 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4307 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4311 if (e
->ts
.type
== BT_CLASS
)
4312 return CLASS_DATA (e
)->attr
.alloc_comp
;
4313 else if (e
->ts
.type
== BT_DERIVED
)
4314 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4320 /* Check whether the expression has an pointer component.
4321 Being itself a pointer does not count. */
4323 gfc_has_ultimate_pointer (gfc_expr
*e
)
4325 gfc_ref
*ref
, *last
= NULL
;
4327 if (e
->expr_type
!= EXPR_VARIABLE
)
4330 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4331 if (ref
->type
== REF_COMPONENT
)
4334 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4335 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4336 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4337 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4341 if (e
->ts
.type
== BT_CLASS
)
4342 return CLASS_DATA (e
)->attr
.pointer_comp
;
4343 else if (e
->ts
.type
== BT_DERIVED
)
4344 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4350 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4351 Note: A scalar is not regarded as "simply contiguous" by the standard.
4352 if bool is not strict, some futher checks are done - for instance,
4353 a "(::1)" is accepted. */
4356 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4360 gfc_array_ref
*ar
= NULL
;
4361 gfc_ref
*ref
, *part_ref
= NULL
;
4363 if (expr
->expr_type
== EXPR_FUNCTION
)
4364 return expr
->value
.function
.esym
4365 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4366 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4369 if (expr
->rank
== 0)
4372 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4375 return false; /* Array shall be last part-ref. */
4377 if (ref
->type
== REF_COMPONENT
)
4379 else if (ref
->type
== REF_SUBSTRING
)
4381 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4385 if ((part_ref
&& !part_ref
->u
.c
.component
->attr
.contiguous
4386 && part_ref
->u
.c
.component
->attr
.pointer
)
4387 || (!part_ref
&& !expr
->symtree
->n
.sym
->attr
.contiguous
4388 && (expr
->symtree
->n
.sym
->attr
.pointer
4389 || expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)))
4392 if (!ar
|| ar
->type
== AR_FULL
)
4395 gcc_assert (ar
->type
== AR_SECTION
);
4397 /* Check for simply contiguous array */
4399 for (i
= 0; i
< ar
->dimen
; i
++)
4401 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4404 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4410 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4413 /* If the previous section was not contiguous, that's an error,
4414 unless we have effective only one element and checking is not
4416 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4417 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4418 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4419 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4420 ar
->end
[i
]->value
.integer
) != 0))
4423 /* Following the standard, "(::1)" or - if known at compile time -
4424 "(lbound:ubound)" are not simply contigous; if strict
4425 is false, they are regarded as simply contiguous. */
4426 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4427 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4428 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4432 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4433 || !ar
->as
->lower
[i
]
4434 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4435 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4436 ar
->as
->lower
[i
]->value
.integer
) != 0))
4440 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4441 || !ar
->as
->upper
[i
]
4442 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4443 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4444 ar
->as
->upper
[i
]->value
.integer
) != 0))
4452 /* Build call to an intrinsic procedure. The number of arguments has to be
4453 passed (rather than ending the list with a NULL value) because we may
4454 want to add arguments but with a NULL-expression. */
4457 gfc_build_intrinsic_call (const char* name
, locus where
, unsigned numarg
, ...)
4460 gfc_actual_arglist
* atail
;
4461 gfc_intrinsic_sym
* isym
;
4465 isym
= gfc_find_function (name
);
4468 result
= gfc_get_expr ();
4469 result
->expr_type
= EXPR_FUNCTION
;
4470 result
->ts
= isym
->ts
;
4471 result
->where
= where
;
4472 result
->value
.function
.name
= name
;
4473 result
->value
.function
.isym
= isym
;
4475 va_start (ap
, numarg
);
4477 for (i
= 0; i
< numarg
; ++i
)
4481 atail
->next
= gfc_get_actual_arglist ();
4482 atail
= atail
->next
;
4485 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4487 atail
->expr
= va_arg (ap
, gfc_expr
*);
4495 /* Check if an expression may appear in a variable definition context
4496 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4497 This is called from the various places when resolving
4498 the pieces that make up such a context.
4500 Optionally, a possible error message can be suppressed if context is NULL
4501 and just the return status (SUCCESS / FAILURE) be requested. */
4504 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4505 const char* context
)
4507 gfc_symbol
* sym
= NULL
;
4509 bool check_intentin
;
4511 symbol_attribute attr
;
4514 if (e
->expr_type
== EXPR_VARIABLE
)
4516 gcc_assert (e
->symtree
);
4517 sym
= e
->symtree
->n
.sym
;
4519 else if (e
->expr_type
== EXPR_FUNCTION
)
4521 gcc_assert (e
->symtree
);
4522 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4525 attr
= gfc_expr_attr (e
);
4526 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4528 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4531 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4532 " context (%s) at %L", context
, &e
->where
);
4536 else if (e
->expr_type
!= EXPR_VARIABLE
)
4539 gfc_error ("Non-variable expression in variable definition context (%s)"
4540 " at %L", context
, &e
->where
);
4544 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4547 gfc_error ("Named constant '%s' in variable definition context (%s)"
4548 " at %L", sym
->name
, context
, &e
->where
);
4551 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4552 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4553 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4556 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4557 " a variable", sym
->name
, context
, &e
->where
);
4561 /* Find out whether the expr is a pointer; this also means following
4562 component references to the last one. */
4563 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4564 if (pointer
&& !is_pointer
)
4567 gfc_error ("Non-POINTER in pointer association context (%s)"
4568 " at %L", context
, &e
->where
);
4575 || (e
->ts
.type
== BT_DERIVED
4576 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4577 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4580 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4581 context
, &e
->where
);
4585 /* INTENT(IN) dummy argument. Check this, unless the object itself is
4586 the component of sub-component of a pointer. Obviously,
4587 procedure pointers are of no interest here. */
4588 check_intentin
= true;
4589 ptr_component
= sym
->attr
.pointer
;
4590 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4592 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4593 check_intentin
= false;
4594 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4595 ptr_component
= true;
4597 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4599 if (pointer
&& is_pointer
)
4602 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4603 " association context (%s) at %L",
4604 sym
->name
, context
, &e
->where
);
4607 if (!pointer
&& !is_pointer
)
4610 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4611 " definition context (%s) at %L",
4612 sym
->name
, context
, &e
->where
);
4617 /* PROTECTED and use-associated. */
4618 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4620 if (pointer
&& is_pointer
)
4623 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4624 " pointer association context (%s) at %L",
4625 sym
->name
, context
, &e
->where
);
4628 if (!pointer
&& !is_pointer
)
4631 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4632 " variable definition context (%s) at %L",
4633 sym
->name
, context
, &e
->where
);
4638 /* Variable not assignable from a PURE procedure but appears in
4639 variable definition context. */
4640 if (!pointer
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4643 gfc_error ("Variable '%s' can not appear in a variable definition"
4644 " context (%s) at %L in PURE procedure",
4645 sym
->name
, context
, &e
->where
);
4649 if (!pointer
&& gfc_implicit_pure (NULL
) && gfc_impure_variable (sym
))
4650 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4652 /* Check variable definition context for associate-names. */
4653 if (!pointer
&& sym
->assoc
)
4656 gfc_association_list
* assoc
;
4658 gcc_assert (sym
->assoc
->target
);
4660 /* If this is a SELECT TYPE temporary (the association is used internally
4661 for SELECT TYPE), silently go over to the target. */
4662 if (sym
->attr
.select_type_temporary
)
4664 gfc_expr
* t
= sym
->assoc
->target
;
4666 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4667 name
= t
->symtree
->name
;
4669 if (t
->symtree
->n
.sym
->assoc
)
4670 assoc
= t
->symtree
->n
.sym
->assoc
;
4679 gcc_assert (name
&& assoc
);
4681 /* Is association to a valid variable? */
4682 if (!assoc
->variable
)
4686 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4687 gfc_error ("'%s' at %L associated to vector-indexed target can"
4688 " not be used in a variable definition context (%s)",
4689 name
, &e
->where
, context
);
4691 gfc_error ("'%s' at %L associated to expression can"
4692 " not be used in a variable definition context (%s)",
4693 name
, &e
->where
, context
);
4698 /* Target must be allowed to appear in a variable definition context. */
4699 if (gfc_check_vardef_context (assoc
->target
, pointer
, false, NULL
)
4703 gfc_error ("Associate-name '%s' can not appear in a variable"
4704 " definition context (%s) at %L because its target"
4705 " at %L can not, either",
4706 name
, context
, &e
->where
,
4707 &assoc
->target
->where
);