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
));
340 break; /* Already done. */
344 /* Should never be reached. */
346 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
353 switch (q
->value
.op
.op
)
356 case INTRINSIC_PARENTHESES
:
357 case INTRINSIC_UPLUS
:
358 case INTRINSIC_UMINUS
:
359 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
362 default: /* Binary operators. */
363 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
364 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
371 q
->value
.function
.actual
=
372 gfc_copy_actual_arglist (p
->value
.function
.actual
);
377 q
->value
.compcall
.actual
=
378 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
379 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
384 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
392 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
394 q
->ref
= gfc_copy_ref (p
->ref
);
401 gfc_clear_shape (mpz_t
*shape
, int rank
)
405 for (i
= 0; i
< rank
; i
++)
406 mpz_clear (shape
[i
]);
411 gfc_free_shape (mpz_t
**shape
, int rank
)
416 gfc_clear_shape (*shape
, rank
);
422 /* Workhorse function for gfc_free_expr() that frees everything
423 beneath an expression node, but not the node itself. This is
424 useful when we want to simplify a node and replace it with
425 something else or the expression node belongs to another structure. */
428 free_expr0 (gfc_expr
*e
)
430 switch (e
->expr_type
)
433 /* Free any parts of the value that need freeing. */
437 mpz_clear (e
->value
.integer
);
441 mpfr_clear (e
->value
.real
);
445 free (e
->value
.character
.string
);
449 mpc_clear (e
->value
.complex);
456 /* Free the representation. */
457 free (e
->representation
.string
);
462 if (e
->value
.op
.op1
!= NULL
)
463 gfc_free_expr (e
->value
.op
.op1
);
464 if (e
->value
.op
.op2
!= NULL
)
465 gfc_free_expr (e
->value
.op
.op2
);
469 gfc_free_actual_arglist (e
->value
.function
.actual
);
474 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
482 gfc_constructor_free (e
->value
.constructor
);
486 free (e
->value
.character
.string
);
493 gfc_internal_error ("free_expr0(): Bad expr type");
496 /* Free a shape array. */
497 gfc_free_shape (&e
->shape
, e
->rank
);
499 gfc_free_ref_list (e
->ref
);
501 memset (e
, '\0', sizeof (gfc_expr
));
505 /* Free an expression node and everything beneath it. */
508 gfc_free_expr (gfc_expr
*e
)
517 /* Free an argument list and everything below it. */
520 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
522 gfc_actual_arglist
*a2
;
527 gfc_free_expr (a1
->expr
);
534 /* Copy an arglist structure and all of the arguments. */
537 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
539 gfc_actual_arglist
*head
, *tail
, *new_arg
;
543 for (; p
; p
= p
->next
)
545 new_arg
= gfc_get_actual_arglist ();
548 new_arg
->expr
= gfc_copy_expr (p
->expr
);
549 new_arg
->next
= NULL
;
554 tail
->next
= new_arg
;
563 /* Free a list of reference structures. */
566 gfc_free_ref_list (gfc_ref
*p
)
578 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
580 gfc_free_expr (p
->u
.ar
.start
[i
]);
581 gfc_free_expr (p
->u
.ar
.end
[i
]);
582 gfc_free_expr (p
->u
.ar
.stride
[i
]);
588 gfc_free_expr (p
->u
.ss
.start
);
589 gfc_free_expr (p
->u
.ss
.end
);
601 /* Graft the *src expression onto the *dest subexpression. */
604 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
612 /* Try to extract an integer constant from the passed expression node.
613 Returns an error message or NULL if the result is set. It is
614 tempting to generate an error and return SUCCESS or FAILURE, but
615 failure is OK for some callers. */
618 gfc_extract_int (gfc_expr
*expr
, int *result
)
620 if (expr
->expr_type
!= EXPR_CONSTANT
)
621 return _("Constant expression required at %C");
623 if (expr
->ts
.type
!= BT_INTEGER
)
624 return _("Integer expression required at %C");
626 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
627 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
629 return _("Integer value too large in expression at %C");
632 *result
= (int) mpz_get_si (expr
->value
.integer
);
638 /* Recursively copy a list of reference structures. */
641 gfc_copy_ref (gfc_ref
*src
)
649 dest
= gfc_get_ref ();
650 dest
->type
= src
->type
;
655 ar
= gfc_copy_array_ref (&src
->u
.ar
);
661 dest
->u
.c
= src
->u
.c
;
665 dest
->u
.ss
= src
->u
.ss
;
666 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
667 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
671 dest
->next
= gfc_copy_ref (src
->next
);
677 /* Detect whether an expression has any vector index array references. */
680 gfc_has_vector_index (gfc_expr
*e
)
684 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
685 if (ref
->type
== REF_ARRAY
)
686 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
687 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
693 /* Copy a shape array. */
696 gfc_copy_shape (mpz_t
*shape
, int rank
)
704 new_shape
= gfc_get_shape (rank
);
706 for (n
= 0; n
< rank
; n
++)
707 mpz_init_set (new_shape
[n
], shape
[n
]);
713 /* Copy a shape array excluding dimension N, where N is an integer
714 constant expression. Dimensions are numbered in fortran style --
717 So, if the original shape array contains R elements
718 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
719 the result contains R-1 elements:
720 { s1 ... sN-1 sN+1 ... sR-1}
722 If anything goes wrong -- N is not a constant, its value is out
723 of range -- or anything else, just returns NULL. */
726 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
728 mpz_t
*new_shape
, *s
;
734 || dim
->expr_type
!= EXPR_CONSTANT
735 || dim
->ts
.type
!= BT_INTEGER
)
738 n
= mpz_get_si (dim
->value
.integer
);
739 n
--; /* Convert to zero based index. */
740 if (n
< 0 || n
>= rank
)
743 s
= new_shape
= gfc_get_shape (rank
- 1);
745 for (i
= 0; i
< rank
; i
++)
749 mpz_init_set (*s
, shape
[i
]);
757 /* Return the maximum kind of two expressions. In general, higher
758 kind numbers mean more precision for numeric types. */
761 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
763 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
767 /* Returns nonzero if the type is numeric, zero otherwise. */
770 numeric_type (bt type
)
772 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
776 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
779 gfc_numeric_ts (gfc_typespec
*ts
)
781 return numeric_type (ts
->type
);
785 /* Return an expression node with an optional argument list attached.
786 A variable number of gfc_expr pointers are strung together in an
787 argument list with a NULL pointer terminating the list. */
790 gfc_build_conversion (gfc_expr
*e
)
795 p
->expr_type
= EXPR_FUNCTION
;
797 p
->value
.function
.actual
= NULL
;
799 p
->value
.function
.actual
= gfc_get_actual_arglist ();
800 p
->value
.function
.actual
->expr
= e
;
806 /* Given an expression node with some sort of numeric binary
807 expression, insert type conversions required to make the operands
808 have the same type. Conversion warnings are disabled if wconversion
811 The exception is that the operands of an exponential don't have to
812 have the same type. If possible, the base is promoted to the type
813 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
814 1.0**2 stays as it is. */
817 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
821 op1
= e
->value
.op
.op1
;
822 op2
= e
->value
.op
.op2
;
824 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
826 gfc_clear_ts (&e
->ts
);
830 /* Kind conversions of same type. */
831 if (op1
->ts
.type
== op2
->ts
.type
)
833 if (op1
->ts
.kind
== op2
->ts
.kind
)
835 /* No type conversions. */
840 if (op1
->ts
.kind
> op2
->ts
.kind
)
841 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
843 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
849 /* Integer combined with real or complex. */
850 if (op2
->ts
.type
== BT_INTEGER
)
854 /* Special case for ** operator. */
855 if (e
->value
.op
.op
== INTRINSIC_POWER
)
858 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
862 if (op1
->ts
.type
== BT_INTEGER
)
865 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
869 /* Real combined with complex. */
870 e
->ts
.type
= BT_COMPLEX
;
871 if (op1
->ts
.kind
> op2
->ts
.kind
)
872 e
->ts
.kind
= op1
->ts
.kind
;
874 e
->ts
.kind
= op2
->ts
.kind
;
875 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
876 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
877 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
878 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
885 /* Function to determine if an expression is constant or not. This
886 function expects that the expression has already been simplified. */
889 gfc_is_constant_expr (gfc_expr
*e
)
892 gfc_actual_arglist
*arg
;
898 switch (e
->expr_type
)
901 return (gfc_is_constant_expr (e
->value
.op
.op1
)
902 && (e
->value
.op
.op2
== NULL
903 || gfc_is_constant_expr (e
->value
.op
.op2
)));
911 gcc_assert (e
->symtree
|| e
->value
.function
.esym
912 || e
->value
.function
.isym
);
914 /* Call to intrinsic with at least one argument. */
915 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
917 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
918 if (!gfc_is_constant_expr (arg
->expr
))
922 /* Specification functions are constant. */
923 /* F95, 7.1.6.2; F2003, 7.1.7 */
926 sym
= e
->symtree
->n
.sym
;
927 if (e
->value
.function
.esym
)
928 sym
= e
->value
.function
.esym
;
931 && sym
->attr
.function
933 && !sym
->attr
.intrinsic
934 && !sym
->attr
.recursive
935 && sym
->attr
.proc
!= PROC_INTERNAL
936 && sym
->attr
.proc
!= PROC_ST_FUNCTION
937 && sym
->attr
.proc
!= PROC_UNKNOWN
938 && sym
->formal
== NULL
)
941 if (e
->value
.function
.isym
942 && (e
->value
.function
.isym
->elemental
943 || e
->value
.function
.isym
->pure
944 || e
->value
.function
.isym
->inquiry
945 || e
->value
.function
.isym
->transformational
))
955 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
956 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
960 c
= gfc_constructor_first (e
->value
.constructor
);
961 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
962 return gfc_constant_ac (e
);
964 for (; c
; c
= gfc_constructor_next (c
))
965 if (!gfc_is_constant_expr (c
->expr
))
972 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
978 /* Is true if an array reference is followed by a component or substring
981 is_subref_array (gfc_expr
* e
)
986 if (e
->expr_type
!= EXPR_VARIABLE
)
989 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
993 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
995 if (ref
->type
== REF_ARRAY
996 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1000 && ref
->type
!= REF_ARRAY
)
1007 /* Try to collapse intrinsic expressions. */
1010 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1012 gfc_intrinsic_op op
;
1013 gfc_expr
*op1
, *op2
, *result
;
1015 if (p
->value
.op
.op
== INTRINSIC_USER
)
1018 op1
= p
->value
.op
.op1
;
1019 op2
= p
->value
.op
.op2
;
1020 op
= p
->value
.op
.op
;
1022 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1024 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1027 if (!gfc_is_constant_expr (op1
)
1028 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1032 p
->value
.op
.op1
= NULL
;
1033 p
->value
.op
.op2
= NULL
;
1037 case INTRINSIC_PARENTHESES
:
1038 result
= gfc_parentheses (op1
);
1041 case INTRINSIC_UPLUS
:
1042 result
= gfc_uplus (op1
);
1045 case INTRINSIC_UMINUS
:
1046 result
= gfc_uminus (op1
);
1049 case INTRINSIC_PLUS
:
1050 result
= gfc_add (op1
, op2
);
1053 case INTRINSIC_MINUS
:
1054 result
= gfc_subtract (op1
, op2
);
1057 case INTRINSIC_TIMES
:
1058 result
= gfc_multiply (op1
, op2
);
1061 case INTRINSIC_DIVIDE
:
1062 result
= gfc_divide (op1
, op2
);
1065 case INTRINSIC_POWER
:
1066 result
= gfc_power (op1
, op2
);
1069 case INTRINSIC_CONCAT
:
1070 result
= gfc_concat (op1
, op2
);
1074 case INTRINSIC_EQ_OS
:
1075 result
= gfc_eq (op1
, op2
, op
);
1079 case INTRINSIC_NE_OS
:
1080 result
= gfc_ne (op1
, op2
, op
);
1084 case INTRINSIC_GT_OS
:
1085 result
= gfc_gt (op1
, op2
, op
);
1089 case INTRINSIC_GE_OS
:
1090 result
= gfc_ge (op1
, op2
, op
);
1094 case INTRINSIC_LT_OS
:
1095 result
= gfc_lt (op1
, op2
, op
);
1099 case INTRINSIC_LE_OS
:
1100 result
= gfc_le (op1
, op2
, op
);
1104 result
= gfc_not (op1
);
1108 result
= gfc_and (op1
, op2
);
1112 result
= gfc_or (op1
, op2
);
1116 result
= gfc_eqv (op1
, op2
);
1119 case INTRINSIC_NEQV
:
1120 result
= gfc_neqv (op1
, op2
);
1124 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1129 gfc_free_expr (op1
);
1130 gfc_free_expr (op2
);
1134 result
->rank
= p
->rank
;
1135 result
->where
= p
->where
;
1136 gfc_replace_expr (p
, result
);
1142 /* Subroutine to simplify constructor expressions. Mutually recursive
1143 with gfc_simplify_expr(). */
1146 simplify_constructor (gfc_constructor_base base
, int type
)
1151 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1154 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1155 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1156 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1161 /* Try and simplify a copy. Replace the original if successful
1162 but keep going through the constructor at all costs. Not
1163 doing so can make a dog's dinner of complicated things. */
1164 p
= gfc_copy_expr (c
->expr
);
1166 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1172 gfc_replace_expr (c
->expr
, p
);
1180 /* Pull a single array element out of an array constructor. */
1183 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1184 gfc_constructor
**rval
)
1186 unsigned long nelemen
;
1192 gfc_constructor
*cons
;
1199 mpz_init_set_ui (offset
, 0);
1202 mpz_init_set_ui (span
, 1);
1203 for (i
= 0; i
< ar
->dimen
; i
++)
1205 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1206 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1213 e
= gfc_copy_expr (ar
->start
[i
]);
1214 if (e
->expr_type
!= EXPR_CONSTANT
)
1220 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1221 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1223 /* Check the bounds. */
1224 if ((ar
->as
->upper
[i
]
1225 && mpz_cmp (e
->value
.integer
,
1226 ar
->as
->upper
[i
]->value
.integer
) > 0)
1227 || (mpz_cmp (e
->value
.integer
,
1228 ar
->as
->lower
[i
]->value
.integer
) < 0))
1230 gfc_error ("Index in dimension %d is out of bounds "
1231 "at %L", i
+ 1, &ar
->c_where
[i
]);
1237 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1238 mpz_mul (delta
, delta
, span
);
1239 mpz_add (offset
, offset
, delta
);
1241 mpz_set_ui (tmp
, 1);
1242 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1243 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1244 mpz_mul (span
, span
, tmp
);
1247 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1248 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1269 /* Find a component of a structure constructor. */
1271 static gfc_constructor
*
1272 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1274 gfc_component
*comp
;
1275 gfc_component
*pick
;
1276 gfc_constructor
*c
= gfc_constructor_first (base
);
1278 comp
= ref
->u
.c
.sym
->components
;
1279 pick
= ref
->u
.c
.component
;
1280 while (comp
!= pick
)
1283 c
= gfc_constructor_next (c
);
1290 /* Replace an expression with the contents of a constructor, removing
1291 the subobject reference in the process. */
1294 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1304 e
= gfc_copy_expr (p
);
1305 e
->ref
= p
->ref
->next
;
1306 p
->ref
->next
= NULL
;
1307 gfc_replace_expr (p
, e
);
1311 /* Pull an array section out of an array constructor. */
1314 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1321 long unsigned one
= 1;
1323 mpz_t start
[GFC_MAX_DIMENSIONS
];
1324 mpz_t end
[GFC_MAX_DIMENSIONS
];
1325 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1326 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1327 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1332 gfc_constructor_base base
;
1333 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1343 base
= expr
->value
.constructor
;
1344 expr
->value
.constructor
= NULL
;
1346 rank
= ref
->u
.ar
.as
->rank
;
1348 if (expr
->shape
== NULL
)
1349 expr
->shape
= gfc_get_shape (rank
);
1351 mpz_init_set_ui (delta_mpz
, one
);
1352 mpz_init_set_ui (nelts
, one
);
1355 /* Do the initialization now, so that we can cleanup without
1356 keeping track of where we were. */
1357 for (d
= 0; d
< rank
; d
++)
1359 mpz_init (delta
[d
]);
1360 mpz_init (start
[d
]);
1363 mpz_init (stride
[d
]);
1367 /* Build the counters to clock through the array reference. */
1369 for (d
= 0; d
< rank
; d
++)
1371 /* Make this stretch of code easier on the eye! */
1372 begin
= ref
->u
.ar
.start
[d
];
1373 finish
= ref
->u
.ar
.end
[d
];
1374 step
= ref
->u
.ar
.stride
[d
];
1375 lower
= ref
->u
.ar
.as
->lower
[d
];
1376 upper
= ref
->u
.ar
.as
->upper
[d
];
1378 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1380 gfc_constructor
*ci
;
1383 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1389 gcc_assert (begin
->rank
== 1);
1390 /* Zero-sized arrays have no shape and no elements, stop early. */
1393 mpz_init_set_ui (nelts
, 0);
1397 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1398 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1399 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1400 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1403 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1405 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1406 || mpz_cmp (ci
->expr
->value
.integer
,
1407 lower
->value
.integer
) < 0)
1409 gfc_error ("index in dimension %d is out of bounds "
1410 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1418 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1419 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1420 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1426 /* Obtain the stride. */
1428 mpz_set (stride
[d
], step
->value
.integer
);
1430 mpz_set_ui (stride
[d
], one
);
1432 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1433 mpz_set_ui (stride
[d
], one
);
1435 /* Obtain the start value for the index. */
1437 mpz_set (start
[d
], begin
->value
.integer
);
1439 mpz_set (start
[d
], lower
->value
.integer
);
1441 mpz_set (ctr
[d
], start
[d
]);
1443 /* Obtain the end value for the index. */
1445 mpz_set (end
[d
], finish
->value
.integer
);
1447 mpz_set (end
[d
], upper
->value
.integer
);
1449 /* Separate 'if' because elements sometimes arrive with
1451 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1452 mpz_set (end
[d
], begin
->value
.integer
);
1454 /* Check the bounds. */
1455 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1456 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1457 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1458 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1460 gfc_error ("index in dimension %d is out of bounds "
1461 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1466 /* Calculate the number of elements and the shape. */
1467 mpz_set (tmp_mpz
, stride
[d
]);
1468 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1469 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1470 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1471 mpz_mul (nelts
, nelts
, tmp_mpz
);
1473 /* An element reference reduces the rank of the expression; don't
1474 add anything to the shape array. */
1475 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1476 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1479 /* Calculate the 'stride' (=delta) for conversion of the
1480 counter values into the index along the constructor. */
1481 mpz_set (delta
[d
], delta_mpz
);
1482 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1483 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1484 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1488 cons
= gfc_constructor_first (base
);
1490 /* Now clock through the array reference, calculating the index in
1491 the source constructor and transferring the elements to the new
1493 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1495 if (ref
->u
.ar
.offset
)
1496 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1498 mpz_init_set_ui (ptr
, 0);
1501 for (d
= 0; d
< rank
; d
++)
1503 mpz_set (tmp_mpz
, ctr
[d
]);
1504 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1505 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1506 mpz_add (ptr
, ptr
, tmp_mpz
);
1508 if (!incr_ctr
) continue;
1510 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1512 gcc_assert(vecsub
[d
]);
1514 if (!gfc_constructor_next (vecsub
[d
]))
1515 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1518 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1521 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1525 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1527 if (mpz_cmp_ui (stride
[d
], 0) > 0
1528 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1529 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1530 mpz_set (ctr
[d
], start
[d
]);
1536 limit
= mpz_get_ui (ptr
);
1537 if (limit
>= gfc_option
.flag_max_array_constructor
)
1539 gfc_error ("The number of elements in the array constructor "
1540 "at %L requires an increase of the allowed %d "
1541 "upper limit. See -fmax-array-constructor "
1542 "option", &expr
->where
,
1543 gfc_option
.flag_max_array_constructor
);
1547 cons
= gfc_constructor_lookup (base
, limit
);
1549 gfc_constructor_append_expr (&expr
->value
.constructor
,
1550 gfc_copy_expr (cons
->expr
), NULL
);
1557 mpz_clear (delta_mpz
);
1558 mpz_clear (tmp_mpz
);
1560 for (d
= 0; d
< rank
; d
++)
1562 mpz_clear (delta
[d
]);
1563 mpz_clear (start
[d
]);
1566 mpz_clear (stride
[d
]);
1568 gfc_constructor_free (base
);
1572 /* Pull a substring out of an expression. */
1575 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1582 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1583 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1586 *newp
= gfc_copy_expr (p
);
1587 free ((*newp
)->value
.character
.string
);
1589 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1590 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1591 length
= end
- start
+ 1;
1593 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1594 (*newp
)->value
.character
.length
= length
;
1595 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1596 length
* sizeof (gfc_char_t
));
1603 /* Simplify a subobject reference of a constructor. This occurs when
1604 parameter variable values are substituted. */
1607 simplify_const_ref (gfc_expr
*p
)
1609 gfc_constructor
*cons
, *c
;
1615 switch (p
->ref
->type
)
1618 switch (p
->ref
->u
.ar
.type
)
1621 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1622 will generate this. */
1623 if (p
->expr_type
!= EXPR_ARRAY
)
1625 remove_subobject_ref (p
, NULL
);
1628 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1635 remove_subobject_ref (p
, cons
);
1639 if (find_array_section (p
, p
->ref
) == FAILURE
)
1641 p
->ref
->u
.ar
.type
= AR_FULL
;
1646 if (p
->ref
->next
!= NULL
1647 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1649 for (c
= gfc_constructor_first (p
->value
.constructor
);
1650 c
; c
= gfc_constructor_next (c
))
1652 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1653 if (simplify_const_ref (c
->expr
) == FAILURE
)
1657 if (p
->ts
.type
== BT_DERIVED
1659 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1661 /* There may have been component references. */
1662 p
->ts
= c
->expr
->ts
;
1666 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1668 if (p
->ts
.type
== BT_CHARACTER
1669 && last_ref
->type
== REF_SUBSTRING
)
1671 /* If this is a CHARACTER array and we possibly took
1672 a substring out of it, update the type-spec's
1673 character length according to the first element
1674 (as all should have the same length). */
1676 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1678 const gfc_expr
* first
= c
->expr
;
1679 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1680 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1681 string_len
= first
->value
.character
.length
;
1687 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1690 gfc_free_expr (p
->ts
.u
.cl
->length
);
1693 = gfc_get_int_expr (gfc_default_integer_kind
,
1697 gfc_free_ref_list (p
->ref
);
1708 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1709 remove_subobject_ref (p
, cons
);
1713 if (find_substring_ref (p
, &newp
) == FAILURE
)
1716 gfc_replace_expr (p
, newp
);
1717 gfc_free_ref_list (p
->ref
);
1727 /* Simplify a chain of references. */
1730 simplify_ref_chain (gfc_ref
*ref
, int type
)
1734 for (; ref
; ref
= ref
->next
)
1739 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1741 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1743 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1745 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1751 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1753 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1765 /* Try to substitute the value of a parameter variable. */
1768 simplify_parameter_variable (gfc_expr
*p
, int type
)
1773 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1779 /* Do not copy subobject refs for constant. */
1780 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1781 e
->ref
= gfc_copy_ref (p
->ref
);
1782 t
= gfc_simplify_expr (e
, type
);
1784 /* Only use the simplification if it eliminated all subobject references. */
1785 if (t
== SUCCESS
&& !e
->ref
)
1786 gfc_replace_expr (p
, e
);
1793 /* Given an expression, simplify it by collapsing constant
1794 expressions. Most simplification takes place when the expression
1795 tree is being constructed. If an intrinsic function is simplified
1796 at some point, we get called again to collapse the result against
1799 We work by recursively simplifying expression nodes, simplifying
1800 intrinsic functions where possible, which can lead to further
1801 constant collapsing. If an operator has constant operand(s), we
1802 rip the expression apart, and rebuild it, hoping that it becomes
1805 The expression type is defined for:
1806 0 Basic expression parsing
1807 1 Simplifying array constructors -- will substitute
1809 Returns FAILURE on error, SUCCESS otherwise.
1810 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1813 gfc_simplify_expr (gfc_expr
*p
, int type
)
1815 gfc_actual_arglist
*ap
;
1820 switch (p
->expr_type
)
1827 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1828 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1831 if (p
->value
.function
.isym
!= NULL
1832 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1837 case EXPR_SUBSTRING
:
1838 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1841 if (gfc_is_constant_expr (p
))
1847 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1849 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1850 start
--; /* Convert from one-based to zero-based. */
1853 end
= p
->value
.character
.length
;
1854 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1855 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1860 s
= gfc_get_wide_string (end
- start
+ 2);
1861 memcpy (s
, p
->value
.character
.string
+ start
,
1862 (end
- start
) * sizeof (gfc_char_t
));
1863 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1864 free (p
->value
.character
.string
);
1865 p
->value
.character
.string
= s
;
1866 p
->value
.character
.length
= end
- start
;
1867 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1868 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1870 p
->value
.character
.length
);
1871 gfc_free_ref_list (p
->ref
);
1873 p
->expr_type
= EXPR_CONSTANT
;
1878 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1883 /* Only substitute array parameter variables if we are in an
1884 initialization expression, or we want a subsection. */
1885 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1886 && (gfc_init_expr_flag
|| p
->ref
1887 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1889 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1896 gfc_simplify_iterator_var (p
);
1899 /* Simplify subcomponent references. */
1900 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1905 case EXPR_STRUCTURE
:
1907 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1910 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1913 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1914 && p
->ref
->u
.ar
.type
== AR_FULL
)
1915 gfc_expand_constructor (p
, false);
1917 if (simplify_const_ref (p
) == FAILURE
)
1932 /* Returns the type of an expression with the exception that iterator
1933 variables are automatically integers no matter what else they may
1939 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1946 /* Check an intrinsic arithmetic operation to see if it is consistent
1947 with some type of expression. */
1949 static gfc_try
check_init_expr (gfc_expr
*);
1952 /* Scalarize an expression for an elemental intrinsic call. */
1955 scalarize_intrinsic_call (gfc_expr
*e
)
1957 gfc_actual_arglist
*a
, *b
;
1958 gfc_constructor_base ctor
;
1959 gfc_constructor
*args
[5];
1960 gfc_constructor
*ci
, *new_ctor
;
1961 gfc_expr
*expr
, *old
;
1962 int n
, i
, rank
[5], array_arg
;
1964 /* Find which, if any, arguments are arrays. Assume that the old
1965 expression carries the type information and that the first arg
1966 that is an array expression carries all the shape information.*/
1968 a
= e
->value
.function
.actual
;
1969 for (; a
; a
= a
->next
)
1972 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1975 expr
= gfc_copy_expr (a
->expr
);
1982 old
= gfc_copy_expr (e
);
1984 gfc_constructor_free (expr
->value
.constructor
);
1985 expr
->value
.constructor
= NULL
;
1987 expr
->where
= old
->where
;
1988 expr
->expr_type
= EXPR_ARRAY
;
1990 /* Copy the array argument constructors into an array, with nulls
1993 a
= old
->value
.function
.actual
;
1994 for (; a
; a
= a
->next
)
1996 /* Check that this is OK for an initialization expression. */
1997 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
2001 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2003 rank
[n
] = a
->expr
->rank
;
2004 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2005 args
[n
] = gfc_constructor_first (ctor
);
2007 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2010 rank
[n
] = a
->expr
->rank
;
2013 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2014 args
[n
] = gfc_constructor_first (ctor
);
2023 /* Using the array argument as the master, step through the array
2024 calling the function for each element and advancing the array
2025 constructors together. */
2026 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2028 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2029 gfc_copy_expr (old
), NULL
);
2031 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2033 b
= old
->value
.function
.actual
;
2034 for (i
= 0; i
< n
; i
++)
2037 new_ctor
->expr
->value
.function
.actual
2038 = a
= gfc_get_actual_arglist ();
2041 a
->next
= gfc_get_actual_arglist ();
2046 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2048 a
->expr
= gfc_copy_expr (b
->expr
);
2053 /* Simplify the function calls. If the simplification fails, the
2054 error will be flagged up down-stream or the library will deal
2056 gfc_simplify_expr (new_ctor
->expr
, 0);
2058 for (i
= 0; i
< n
; i
++)
2060 args
[i
] = gfc_constructor_next (args
[i
]);
2062 for (i
= 1; i
< n
; i
++)
2063 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2064 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2070 gfc_free_expr (old
);
2074 gfc_error_now ("elemental function arguments at %C are not compliant");
2077 gfc_free_expr (expr
);
2078 gfc_free_expr (old
);
2084 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2086 gfc_expr
*op1
= e
->value
.op
.op1
;
2087 gfc_expr
*op2
= e
->value
.op
.op2
;
2089 if ((*check_function
) (op1
) == FAILURE
)
2092 switch (e
->value
.op
.op
)
2094 case INTRINSIC_UPLUS
:
2095 case INTRINSIC_UMINUS
:
2096 if (!numeric_type (et0 (op1
)))
2101 case INTRINSIC_EQ_OS
:
2103 case INTRINSIC_NE_OS
:
2105 case INTRINSIC_GT_OS
:
2107 case INTRINSIC_GE_OS
:
2109 case INTRINSIC_LT_OS
:
2111 case INTRINSIC_LE_OS
:
2112 if ((*check_function
) (op2
) == FAILURE
)
2115 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2116 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2118 gfc_error ("Numeric or CHARACTER operands are required in "
2119 "expression at %L", &e
->where
);
2124 case INTRINSIC_PLUS
:
2125 case INTRINSIC_MINUS
:
2126 case INTRINSIC_TIMES
:
2127 case INTRINSIC_DIVIDE
:
2128 case INTRINSIC_POWER
:
2129 if ((*check_function
) (op2
) == FAILURE
)
2132 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2137 case INTRINSIC_CONCAT
:
2138 if ((*check_function
) (op2
) == FAILURE
)
2141 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2143 gfc_error ("Concatenation operator in expression at %L "
2144 "must have two CHARACTER operands", &op1
->where
);
2148 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2150 gfc_error ("Concat operator at %L must concatenate strings of the "
2151 "same kind", &e
->where
);
2158 if (et0 (op1
) != BT_LOGICAL
)
2160 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2161 "operand", &op1
->where
);
2170 case INTRINSIC_NEQV
:
2171 if ((*check_function
) (op2
) == FAILURE
)
2174 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2176 gfc_error ("LOGICAL operands are required in expression at %L",
2183 case INTRINSIC_PARENTHESES
:
2187 gfc_error ("Only intrinsic operators can be used in expression at %L",
2195 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2200 /* F2003, 7.1.7 (3): In init expression, allocatable components
2201 must not be data-initialized. */
2203 check_alloc_comp_init (gfc_expr
*e
)
2205 gfc_component
*comp
;
2206 gfc_constructor
*ctor
;
2208 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2209 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2211 for (comp
= e
->ts
.u
.derived
->components
,
2212 ctor
= gfc_constructor_first (e
->value
.constructor
);
2213 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2215 if (comp
->attr
.allocatable
2216 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2218 gfc_error("Invalid initialization expression for ALLOCATABLE "
2219 "component '%s' in structure constructor at %L",
2220 comp
->name
, &ctor
->expr
->where
);
2229 check_init_expr_arguments (gfc_expr
*e
)
2231 gfc_actual_arglist
*ap
;
2233 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2234 if (check_init_expr (ap
->expr
) == FAILURE
)
2240 static gfc_try
check_restricted (gfc_expr
*);
2242 /* F95, 7.1.6.1, Initialization expressions, (7)
2243 F2003, 7.1.7 Initialization expression, (8) */
2246 check_inquiry (gfc_expr
*e
, int not_restricted
)
2249 const char *const *functions
;
2251 static const char *const inquiry_func_f95
[] = {
2252 "lbound", "shape", "size", "ubound",
2253 "bit_size", "len", "kind",
2254 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2255 "precision", "radix", "range", "tiny",
2259 static const char *const inquiry_func_f2003
[] = {
2260 "lbound", "shape", "size", "ubound",
2261 "bit_size", "len", "kind",
2262 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2263 "precision", "radix", "range", "tiny",
2268 gfc_actual_arglist
*ap
;
2270 if (!e
->value
.function
.isym
2271 || !e
->value
.function
.isym
->inquiry
)
2274 /* An undeclared parameter will get us here (PR25018). */
2275 if (e
->symtree
== NULL
)
2278 name
= e
->symtree
->n
.sym
->name
;
2280 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2281 ? inquiry_func_f2003
: inquiry_func_f95
;
2283 for (i
= 0; functions
[i
]; i
++)
2284 if (strcmp (functions
[i
], name
) == 0)
2287 if (functions
[i
] == NULL
)
2290 /* At this point we have an inquiry function with a variable argument. The
2291 type of the variable might be undefined, but we need it now, because the
2292 arguments of these functions are not allowed to be undefined. */
2294 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2299 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2301 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2302 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2306 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2309 /* Assumed character length will not reduce to a constant expression
2310 with LEN, as required by the standard. */
2311 if (i
== 5 && not_restricted
2312 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2313 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2314 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2316 gfc_error ("Assumed or deferred character length variable '%s' "
2317 " in constant expression at %L",
2318 ap
->expr
->symtree
->n
.sym
->name
,
2322 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2325 if (not_restricted
== 0
2326 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2327 && check_restricted (ap
->expr
) == FAILURE
)
2330 if (not_restricted
== 0
2331 && ap
->expr
->expr_type
== EXPR_VARIABLE
2332 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2333 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2341 /* F95, 7.1.6.1, Initialization expressions, (5)
2342 F2003, 7.1.7 Initialization expression, (5) */
2345 check_transformational (gfc_expr
*e
)
2347 static const char * const trans_func_f95
[] = {
2348 "repeat", "reshape", "selected_int_kind",
2349 "selected_real_kind", "transfer", "trim", NULL
2352 static const char * const trans_func_f2003
[] = {
2353 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2354 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2355 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2356 "trim", "unpack", NULL
2361 const char *const *functions
;
2363 if (!e
->value
.function
.isym
2364 || !e
->value
.function
.isym
->transformational
)
2367 name
= e
->symtree
->n
.sym
->name
;
2369 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2370 ? trans_func_f2003
: trans_func_f95
;
2372 /* NULL() is dealt with below. */
2373 if (strcmp ("null", name
) == 0)
2376 for (i
= 0; functions
[i
]; i
++)
2377 if (strcmp (functions
[i
], name
) == 0)
2380 if (functions
[i
] == NULL
)
2382 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2383 "in an initialization expression", name
, &e
->where
);
2387 return check_init_expr_arguments (e
);
2391 /* F95, 7.1.6.1, Initialization expressions, (6)
2392 F2003, 7.1.7 Initialization expression, (6) */
2395 check_null (gfc_expr
*e
)
2397 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2400 return check_init_expr_arguments (e
);
2405 check_elemental (gfc_expr
*e
)
2407 if (!e
->value
.function
.isym
2408 || !e
->value
.function
.isym
->elemental
)
2411 if (e
->ts
.type
!= BT_INTEGER
2412 && e
->ts
.type
!= BT_CHARACTER
2413 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2414 "nonstandard initialization expression at %L",
2415 &e
->where
) == FAILURE
)
2418 return check_init_expr_arguments (e
);
2423 check_conversion (gfc_expr
*e
)
2425 if (!e
->value
.function
.isym
2426 || !e
->value
.function
.isym
->conversion
)
2429 return check_init_expr_arguments (e
);
2433 /* Verify that an expression is an initialization expression. A side
2434 effect is that the expression tree is reduced to a single constant
2435 node if all goes well. This would normally happen when the
2436 expression is constructed but function references are assumed to be
2437 intrinsics in the context of initialization expressions. If
2438 FAILURE is returned an error message has been generated. */
2441 check_init_expr (gfc_expr
*e
)
2449 switch (e
->expr_type
)
2452 t
= check_intrinsic_op (e
, check_init_expr
);
2454 t
= gfc_simplify_expr (e
, 0);
2462 gfc_intrinsic_sym
* isym
;
2465 sym
= e
->symtree
->n
.sym
;
2466 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2467 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2469 gfc_error ("Function '%s' in initialization expression at %L "
2470 "must be an intrinsic function",
2471 e
->symtree
->n
.sym
->name
, &e
->where
);
2475 if ((m
= check_conversion (e
)) == MATCH_NO
2476 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2477 && (m
= check_null (e
)) == MATCH_NO
2478 && (m
= check_transformational (e
)) == MATCH_NO
2479 && (m
= check_elemental (e
)) == MATCH_NO
)
2481 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2482 "in an initialization expression",
2483 e
->symtree
->n
.sym
->name
, &e
->where
);
2487 if (m
== MATCH_ERROR
)
2490 /* Try to scalarize an elemental intrinsic function that has an
2492 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2493 if (isym
&& isym
->elemental
2494 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2499 t
= gfc_simplify_expr (e
, 0);
2506 if (gfc_check_iter_variable (e
) == SUCCESS
)
2509 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2511 /* A PARAMETER shall not be used to define itself, i.e.
2512 REAL, PARAMETER :: x = transfer(0, x)
2514 if (!e
->symtree
->n
.sym
->value
)
2516 gfc_error("PARAMETER '%s' is used at %L before its definition "
2517 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2521 t
= simplify_parameter_variable (e
, 0);
2526 if (gfc_in_match_data ())
2531 if (e
->symtree
->n
.sym
->as
)
2533 switch (e
->symtree
->n
.sym
->as
->type
)
2535 case AS_ASSUMED_SIZE
:
2536 gfc_error ("Assumed size array '%s' at %L is not permitted "
2537 "in an initialization expression",
2538 e
->symtree
->n
.sym
->name
, &e
->where
);
2541 case AS_ASSUMED_SHAPE
:
2542 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2543 "in an initialization expression",
2544 e
->symtree
->n
.sym
->name
, &e
->where
);
2548 gfc_error ("Deferred array '%s' at %L is not permitted "
2549 "in an initialization expression",
2550 e
->symtree
->n
.sym
->name
, &e
->where
);
2554 gfc_error ("Array '%s' at %L is a variable, which does "
2555 "not reduce to a constant expression",
2556 e
->symtree
->n
.sym
->name
, &e
->where
);
2564 gfc_error ("Parameter '%s' at %L has not been declared or is "
2565 "a variable, which does not reduce to a constant "
2566 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2575 case EXPR_SUBSTRING
:
2576 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2580 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2582 t
= gfc_simplify_expr (e
, 0);
2586 case EXPR_STRUCTURE
:
2587 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2591 t
= check_alloc_comp_init (e
);
2595 t
= gfc_check_constructor (e
, check_init_expr
);
2602 t
= gfc_check_constructor (e
, check_init_expr
);
2606 t
= gfc_expand_constructor (e
, true);
2610 t
= gfc_check_constructor_type (e
);
2614 gfc_internal_error ("check_init_expr(): Unknown expression type");
2620 /* Reduces a general expression to an initialization expression (a constant).
2621 This used to be part of gfc_match_init_expr.
2622 Note that this function doesn't free the given expression on FAILURE. */
2625 gfc_reduce_init_expr (gfc_expr
*expr
)
2629 gfc_init_expr_flag
= true;
2630 t
= gfc_resolve_expr (expr
);
2632 t
= check_init_expr (expr
);
2633 gfc_init_expr_flag
= false;
2638 if (expr
->expr_type
== EXPR_ARRAY
)
2640 if (gfc_check_constructor_type (expr
) == FAILURE
)
2642 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2650 /* Match an initialization expression. We work by first matching an
2651 expression, then reducing it to a constant. */
2654 gfc_match_init_expr (gfc_expr
**result
)
2662 gfc_init_expr_flag
= true;
2664 m
= gfc_match_expr (&expr
);
2667 gfc_init_expr_flag
= false;
2671 t
= gfc_reduce_init_expr (expr
);
2674 gfc_free_expr (expr
);
2675 gfc_init_expr_flag
= false;
2680 gfc_init_expr_flag
= false;
2686 /* Given an actual argument list, test to see that each argument is a
2687 restricted expression and optionally if the expression type is
2688 integer or character. */
2691 restricted_args (gfc_actual_arglist
*a
)
2693 for (; a
; a
= a
->next
)
2695 if (check_restricted (a
->expr
) == FAILURE
)
2703 /************* Restricted/specification expressions *************/
2706 /* Make sure a non-intrinsic function is a specification function. */
2709 external_spec_function (gfc_expr
*e
)
2713 f
= e
->value
.function
.esym
;
2715 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2717 gfc_error ("Specification function '%s' at %L cannot be a statement "
2718 "function", f
->name
, &e
->where
);
2722 if (f
->attr
.proc
== PROC_INTERNAL
)
2724 gfc_error ("Specification function '%s' at %L cannot be an internal "
2725 "function", f
->name
, &e
->where
);
2729 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2731 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2736 if (f
->attr
.recursive
)
2738 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2739 f
->name
, &e
->where
);
2743 return restricted_args (e
->value
.function
.actual
);
2747 /* Check to see that a function reference to an intrinsic is a
2748 restricted expression. */
2751 restricted_intrinsic (gfc_expr
*e
)
2753 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2754 if (check_inquiry (e
, 0) == MATCH_YES
)
2757 return restricted_args (e
->value
.function
.actual
);
2761 /* Check the expressions of an actual arglist. Used by check_restricted. */
2764 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2766 for (; arg
; arg
= arg
->next
)
2767 if (checker (arg
->expr
) == FAILURE
)
2774 /* Check the subscription expressions of a reference chain with a checking
2775 function; used by check_restricted. */
2778 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2788 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2790 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2792 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2794 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2800 /* Nothing needed, just proceed to next reference. */
2804 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2806 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2815 return check_references (ref
->next
, checker
);
2819 /* Verify that an expression is a restricted expression. Like its
2820 cousin check_init_expr(), an error message is generated if we
2824 check_restricted (gfc_expr
*e
)
2832 switch (e
->expr_type
)
2835 t
= check_intrinsic_op (e
, check_restricted
);
2837 t
= gfc_simplify_expr (e
, 0);
2842 if (e
->value
.function
.esym
)
2844 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2846 t
= external_spec_function (e
);
2850 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2853 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2856 t
= restricted_intrinsic (e
);
2861 sym
= e
->symtree
->n
.sym
;
2864 /* If a dummy argument appears in a context that is valid for a
2865 restricted expression in an elemental procedure, it will have
2866 already been simplified away once we get here. Therefore we
2867 don't need to jump through hoops to distinguish valid from
2869 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2870 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2872 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2873 sym
->name
, &e
->where
);
2877 if (sym
->attr
.optional
)
2879 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2880 sym
->name
, &e
->where
);
2884 if (sym
->attr
.intent
== INTENT_OUT
)
2886 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2887 sym
->name
, &e
->where
);
2891 /* Check reference chain if any. */
2892 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2895 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2896 processed in resolve.c(resolve_formal_arglist). This is done so
2897 that host associated dummy array indices are accepted (PR23446).
2898 This mechanism also does the same for the specification expressions
2899 of array-valued functions. */
2901 || sym
->attr
.in_common
2902 || sym
->attr
.use_assoc
2904 || sym
->attr
.implied_index
2905 || sym
->attr
.flavor
== FL_PARAMETER
2906 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2907 || (sym
->ns
&& gfc_current_ns
->parent
2908 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2909 || (sym
->ns
->proc_name
!= NULL
2910 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2911 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2917 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2918 sym
->name
, &e
->where
);
2919 /* Prevent a repetition of the error. */
2928 case EXPR_SUBSTRING
:
2929 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2933 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2935 t
= gfc_simplify_expr (e
, 0);
2939 case EXPR_STRUCTURE
:
2940 t
= gfc_check_constructor (e
, check_restricted
);
2944 t
= gfc_check_constructor (e
, check_restricted
);
2948 gfc_internal_error ("check_restricted(): Unknown expression type");
2955 /* Check to see that an expression is a specification expression. If
2956 we return FAILURE, an error has been generated. */
2959 gfc_specification_expr (gfc_expr
*e
)
2961 gfc_component
*comp
;
2966 if (e
->ts
.type
!= BT_INTEGER
)
2968 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2969 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2973 if (e
->expr_type
== EXPR_FUNCTION
2974 && !e
->value
.function
.isym
2975 && !e
->value
.function
.esym
2976 && !gfc_pure (e
->symtree
->n
.sym
)
2977 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2978 || !comp
->attr
.pure
))
2980 gfc_error ("Function '%s' at %L must be PURE",
2981 e
->symtree
->n
.sym
->name
, &e
->where
);
2982 /* Prevent repeat error messages. */
2983 e
->symtree
->n
.sym
->attr
.pure
= 1;
2989 gfc_error ("Expression at %L must be scalar", &e
->where
);
2993 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2996 return check_restricted (e
);
3000 /************** Expression conformance checks. *************/
3002 /* Given two expressions, make sure that the arrays are conformable. */
3005 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3007 int op1_flag
, op2_flag
, d
;
3008 mpz_t op1_size
, op2_size
;
3014 if (op1
->rank
== 0 || op2
->rank
== 0)
3017 va_start (argp
, optype_msgid
);
3018 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3021 if (op1
->rank
!= op2
->rank
)
3023 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3024 op1
->rank
, op2
->rank
, &op1
->where
);
3030 for (d
= 0; d
< op1
->rank
; d
++)
3032 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3033 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3035 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3037 gfc_error ("Different shape for %s at %L on dimension %d "
3038 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3039 (int) mpz_get_si (op1_size
),
3040 (int) mpz_get_si (op2_size
));
3046 mpz_clear (op1_size
);
3048 mpz_clear (op2_size
);
3058 /* Given an assignable expression and an arbitrary expression, make
3059 sure that the assignment can take place. */
3062 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3068 sym
= lvalue
->symtree
->n
.sym
;
3070 /* See if this is the component or subcomponent of a pointer. */
3071 has_pointer
= sym
->attr
.pointer
;
3072 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3073 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3079 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3080 variable local to a function subprogram. Its existence begins when
3081 execution of the function is initiated and ends when execution of the
3082 function is terminated...
3083 Therefore, the left hand side is no longer a variable, when it is: */
3084 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3085 && !sym
->attr
.external
)
3090 /* (i) Use associated; */
3091 if (sym
->attr
.use_assoc
)
3094 /* (ii) The assignment is in the main program; or */
3095 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3098 /* (iii) A module or internal procedure... */
3099 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3100 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3101 && gfc_current_ns
->parent
3102 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3103 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3104 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3106 /* ... that is not a function... */
3107 if (!gfc_current_ns
->proc_name
->attr
.function
)
3110 /* ... or is not an entry and has a different name. */
3111 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3115 /* (iv) Host associated and not the function symbol or the
3116 parent result. This picks up sibling references, which
3117 cannot be entries. */
3118 if (!sym
->attr
.entry
3119 && sym
->ns
== gfc_current_ns
->parent
3120 && sym
!= gfc_current_ns
->proc_name
3121 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3126 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3131 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3133 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3134 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3138 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3140 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3145 if (rvalue
->expr_type
== EXPR_NULL
)
3147 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3148 && lvalue
->symtree
->n
.sym
->attr
.data
)
3152 gfc_error ("NULL appears on right-hand side in assignment at %L",
3158 /* This is possibly a typo: x = f() instead of x => f(). */
3159 if (gfc_option
.warn_surprising
3160 && rvalue
->expr_type
== EXPR_FUNCTION
3161 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3162 gfc_warning ("POINTER valued function appears on right-hand side of "
3163 "assignment at %L", &rvalue
->where
);
3165 /* Check size of array assignments. */
3166 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3167 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3170 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3171 && lvalue
->symtree
->n
.sym
->attr
.data
3172 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3173 "initialize non-integer variable '%s'",
3174 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3177 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3178 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3179 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3180 &rvalue
->where
) == FAILURE
)
3183 /* Handle the case of a BOZ literal on the RHS. */
3184 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3187 if (gfc_option
.warn_surprising
)
3188 gfc_warning ("BOZ literal at %L is bitwise transferred "
3189 "non-integer symbol '%s'", &rvalue
->where
,
3190 lvalue
->symtree
->n
.sym
->name
);
3191 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3193 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3195 if (rc
== ARITH_UNDERFLOW
)
3196 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3197 ". This check can be disabled with the option "
3198 "-fno-range-check", &rvalue
->where
);
3199 else if (rc
== ARITH_OVERFLOW
)
3200 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3201 ". This check can be disabled with the option "
3202 "-fno-range-check", &rvalue
->where
);
3203 else if (rc
== ARITH_NAN
)
3204 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3205 ". This check can be disabled with the option "
3206 "-fno-range-check", &rvalue
->where
);
3211 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3212 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3213 will warn anyway, so there is no need to to so here. */
3215 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3216 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3218 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3220 /* As a special bonus, don't warn about REAL rvalues which are not
3221 changed by the conversion if -Wconversion is specified. */
3222 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3224 /* Calculate the difference between the constant and the rounded
3225 value and check it against zero. */
3227 gfc_set_model_kind (lvalue
->ts
.kind
);
3229 gfc_set_model_kind (rvalue
->ts
.kind
);
3232 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3233 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3235 if (!mpfr_zero_p (diff
))
3236 gfc_warning ("Change of value in conversion from "
3237 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3238 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3244 gfc_warning ("Possible change of value in conversion from %s "
3245 "to %s at %L",gfc_typename (&rvalue
->ts
),
3246 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3249 else if (gfc_option
.warn_conversion_extra
3250 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3252 gfc_warning ("Conversion from %s to %s at %L",
3253 gfc_typename (&rvalue
->ts
),
3254 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3258 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3261 /* Only DATA Statements come here. */
3264 /* Numeric can be converted to any other numeric. And Hollerith can be
3265 converted to any other type. */
3266 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3267 || rvalue
->ts
.type
== BT_HOLLERITH
)
3270 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3273 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3274 "conversion of %s to %s", &lvalue
->where
,
3275 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3280 /* Assignment is the only case where character variables of different
3281 kind values can be converted into one another. */
3282 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3284 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3285 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3290 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3294 /* Check that a pointer assignment is OK. We first check lvalue, and
3295 we only check rvalue if it's not an assignment to NULL() or a
3296 NULLIFY statement. */
3299 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3301 symbol_attribute attr
;
3303 bool is_pure
, is_implicit_pure
, rank_remap
;
3306 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3307 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3309 gfc_error ("Pointer assignment target is not a POINTER at %L",
3314 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3315 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3316 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3318 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3319 "l-value since it is a procedure",
3320 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3324 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3327 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3329 if (ref
->type
== REF_COMPONENT
)
3330 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3332 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3336 if (ref
->u
.ar
.type
== AR_FULL
)
3339 if (ref
->u
.ar
.type
!= AR_SECTION
)
3341 gfc_error ("Expected bounds specification for '%s' at %L",
3342 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3346 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3347 "specification for '%s' in pointer assignment "
3348 "at %L", lvalue
->symtree
->n
.sym
->name
,
3349 &lvalue
->where
) == FAILURE
)
3352 /* When bounds are given, all lbounds are necessary and either all
3353 or none of the upper bounds; no strides are allowed. If the
3354 upper bounds are present, we may do rank remapping. */
3355 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3357 if (!ref
->u
.ar
.start
[dim
]
3358 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3360 gfc_error ("Lower bound has to be present at %L",
3364 if (ref
->u
.ar
.stride
[dim
])
3366 gfc_error ("Stride must not be present at %L",
3372 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3375 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3376 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3378 gfc_error ("Either all or none of the upper bounds"
3379 " must be specified at %L", &lvalue
->where
);
3387 is_pure
= gfc_pure (NULL
);
3388 is_implicit_pure
= gfc_implicit_pure (NULL
);
3390 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3391 kind, etc for lvalue and rvalue must match, and rvalue must be a
3392 pure variable if we're in a pure function. */
3393 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3396 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3397 if (lvalue
->expr_type
== EXPR_VARIABLE
3398 && gfc_is_coindexed (lvalue
))
3401 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3402 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3404 gfc_error ("Pointer object at %L shall not have a coindex",
3410 /* Checks on rvalue for procedure pointer assignments. */
3415 gfc_component
*comp
;
3418 attr
= gfc_expr_attr (rvalue
);
3419 if (!((rvalue
->expr_type
== EXPR_NULL
)
3420 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3421 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3422 || (rvalue
->expr_type
== EXPR_VARIABLE
3423 && attr
.flavor
== FL_PROCEDURE
)))
3425 gfc_error ("Invalid procedure pointer assignment at %L",
3431 gfc_error ("Abstract interface '%s' is invalid "
3432 "in procedure pointer assignment at %L",
3433 rvalue
->symtree
->name
, &rvalue
->where
);
3436 /* Check for F08:C729. */
3437 if (attr
.flavor
== FL_PROCEDURE
)
3439 if (attr
.proc
== PROC_ST_FUNCTION
)
3441 gfc_error ("Statement function '%s' is invalid "
3442 "in procedure pointer assignment at %L",
3443 rvalue
->symtree
->name
, &rvalue
->where
);
3446 if (attr
.proc
== PROC_INTERNAL
&&
3447 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3448 "invalid in procedure pointer assignment at %L",
3449 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3452 /* Check for F08:C730. */
3453 if (attr
.elemental
&& !attr
.intrinsic
)
3455 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3456 "in procedure pointer assigment at %L",
3457 rvalue
->symtree
->name
, &rvalue
->where
);
3461 /* Ensure that the calling convention is the same. As other attributes
3462 such as DLLEXPORT may differ, one explicitly only tests for the
3463 calling conventions. */
3464 if (rvalue
->expr_type
== EXPR_VARIABLE
3465 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3466 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3468 symbol_attribute calls
;
3471 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3472 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3473 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3475 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3476 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3478 gfc_error ("Mismatch in the procedure pointer assignment "
3479 "at %L: mismatch in the calling convention",
3485 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3486 s1
= comp
->ts
.interface
;
3488 s1
= lvalue
->symtree
->n
.sym
;
3490 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3492 s2
= comp
->ts
.interface
;
3495 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3497 s2
= rvalue
->symtree
->n
.sym
->result
;
3498 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3502 s2
= rvalue
->symtree
->n
.sym
;
3503 name
= rvalue
->symtree
->n
.sym
->name
;
3506 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3509 gfc_error ("Interface mismatch in procedure pointer assignment "
3510 "at %L: %s", &rvalue
->where
, err
);
3517 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3519 gfc_error ("Different types in pointer assignment at %L; attempted "
3520 "assignment of %s to %s", &lvalue
->where
,
3521 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3525 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3527 gfc_error ("Different kind type parameters in pointer "
3528 "assignment at %L", &lvalue
->where
);
3532 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3534 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3538 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3539 /* Make sure the vtab is present. */
3540 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3542 /* Check rank remapping. */
3547 /* If this can be determined, check that the target must be at least as
3548 large as the pointer assigned to it is. */
3549 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3550 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3551 && mpz_cmp (rsize
, lsize
) < 0)
3553 gfc_error ("Rank remapping target is smaller than size of the"
3554 " pointer (%ld < %ld) at %L",
3555 mpz_get_si (rsize
), mpz_get_si (lsize
),
3560 /* The target must be either rank one or it must be simply contiguous
3561 and F2008 must be allowed. */
3562 if (rvalue
->rank
!= 1)
3564 if (!gfc_is_simply_contiguous (rvalue
, true))
3566 gfc_error ("Rank remapping target must be rank 1 or"
3567 " simply contiguous at %L", &rvalue
->where
);
3570 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Rank remapping"
3571 " target is not rank 1 at %L", &rvalue
->where
)
3577 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3578 if (rvalue
->expr_type
== EXPR_NULL
)
3581 if (lvalue
->ts
.type
== BT_CHARACTER
)
3583 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3588 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3589 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3591 attr
= gfc_expr_attr (rvalue
);
3593 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3595 gfc_error ("Target expression in pointer assignment "
3596 "at %L must deliver a pointer result",
3601 if (!attr
.target
&& !attr
.pointer
)
3603 gfc_error ("Pointer assignment target is neither TARGET "
3604 "nor POINTER at %L", &rvalue
->where
);
3608 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3610 gfc_error ("Bad target in pointer assignment in PURE "
3611 "procedure at %L", &rvalue
->where
);
3614 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3615 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3618 if (gfc_has_vector_index (rvalue
))
3620 gfc_error ("Pointer assignment with vector subscript "
3621 "on rhs at %L", &rvalue
->where
);
3625 if (attr
.is_protected
&& attr
.use_assoc
3626 && !(attr
.pointer
|| attr
.proc_pointer
))
3628 gfc_error ("Pointer assignment target has PROTECTED "
3629 "attribute at %L", &rvalue
->where
);
3633 /* F2008, C725. For PURE also C1283. */
3634 if (rvalue
->expr_type
== EXPR_VARIABLE
3635 && gfc_is_coindexed (rvalue
))
3638 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3639 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3641 gfc_error ("Data target at %L shall not have a coindex",
3651 /* Relative of gfc_check_assign() except that the lvalue is a single
3652 symbol. Used for initialization assignments. */
3655 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3660 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3662 lvalue
.expr_type
= EXPR_VARIABLE
;
3663 lvalue
.ts
= sym
->ts
;
3665 lvalue
.rank
= sym
->as
->rank
;
3666 lvalue
.symtree
= XCNEW (gfc_symtree
);
3667 lvalue
.symtree
->n
.sym
= sym
;
3668 lvalue
.where
= sym
->declared_at
;
3670 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3671 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
3672 && rvalue
->expr_type
== EXPR_NULL
))
3673 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3675 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3677 free (lvalue
.symtree
);
3682 if (sym
->attr
.pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3684 /* F08:C461. Additional checks for pointer initialization. */
3685 symbol_attribute attr
;
3686 attr
= gfc_expr_attr (rvalue
);
3687 if (attr
.allocatable
)
3689 gfc_error ("Pointer initialization target at %C "
3690 "must not be ALLOCATABLE ");
3693 if (!attr
.target
|| attr
.pointer
)
3695 gfc_error ("Pointer initialization target at %C "
3696 "must have the TARGET attribute");
3701 gfc_error ("Pointer initialization target at %C "
3702 "must have the SAVE attribute");
3707 if (sym
->attr
.proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3709 /* F08:C1220. Additional checks for procedure pointer initialization. */
3710 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3711 if (attr
.proc_pointer
)
3713 gfc_error ("Procedure pointer initialization target at %L "
3714 "may not be a procedure pointer", &rvalue
->where
);
3723 /* Check for default initializer; sym->value is not enough
3724 as it is also set for EXPR_NULL of allocatables. */
3727 gfc_has_default_initializer (gfc_symbol
*der
)
3731 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3732 for (c
= der
->components
; c
; c
= c
->next
)
3733 if (c
->ts
.type
== BT_DERIVED
)
3735 if (!c
->attr
.pointer
3736 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3738 if (c
->attr
.pointer
&& c
->initializer
)
3751 /* Get an expression for a default initializer. */
3754 gfc_default_initializer (gfc_typespec
*ts
)
3757 gfc_component
*comp
;
3759 /* See if we have a default initializer in this, but not in nested
3760 types (otherwise we could use gfc_has_default_initializer()). */
3761 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3762 if (comp
->initializer
|| comp
->attr
.allocatable
3763 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3769 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3770 &ts
->u
.derived
->declared_at
);
3773 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3775 gfc_constructor
*ctor
= gfc_constructor_get();
3777 if (comp
->initializer
)
3779 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3780 if ((comp
->ts
.type
!= comp
->initializer
->ts
.type
3781 || comp
->ts
.kind
!= comp
->initializer
->ts
.kind
)
3782 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
3783 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
3786 if (comp
->attr
.allocatable
3787 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3789 ctor
->expr
= gfc_get_expr ();
3790 ctor
->expr
->expr_type
= EXPR_NULL
;
3791 ctor
->expr
->ts
= comp
->ts
;
3794 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3801 /* Given a symbol, create an expression node with that symbol as a
3802 variable. If the symbol is array valued, setup a reference of the
3806 gfc_get_variable_expr (gfc_symtree
*var
)
3810 e
= gfc_get_expr ();
3811 e
->expr_type
= EXPR_VARIABLE
;
3813 e
->ts
= var
->n
.sym
->ts
;
3815 if ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
3816 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
3817 && CLASS_DATA (var
->n
.sym
)->as
))
3819 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
3820 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
3821 e
->ref
= gfc_get_ref ();
3822 e
->ref
->type
= REF_ARRAY
;
3823 e
->ref
->u
.ar
.type
= AR_FULL
;
3831 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3834 lval
= gfc_get_expr ();
3835 lval
->expr_type
= EXPR_VARIABLE
;
3836 lval
->where
= sym
->declared_at
;
3838 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3840 /* It will always be a full array. */
3841 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
3844 lval
->ref
= gfc_get_ref ();
3845 lval
->ref
->type
= REF_ARRAY
;
3846 lval
->ref
->u
.ar
.type
= AR_FULL
;
3847 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
3848 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
3849 lval
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
3850 ? CLASS_DATA (sym
)->as
: sym
->as
;
3857 /* Returns the array_spec of a full array expression. A NULL is
3858 returned otherwise. */
3860 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3865 if (expr
->rank
== 0)
3868 /* Follow any component references. */
3869 if (expr
->expr_type
== EXPR_VARIABLE
3870 || expr
->expr_type
== EXPR_CONSTANT
)
3872 as
= expr
->symtree
->n
.sym
->as
;
3873 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3878 as
= ref
->u
.c
.component
->as
;
3886 switch (ref
->u
.ar
.type
)
3909 /* General expression traversal function. */
3912 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3913 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3918 gfc_actual_arglist
*args
;
3925 if ((*func
) (expr
, sym
, &f
))
3928 if (expr
->ts
.type
== BT_CHARACTER
3930 && expr
->ts
.u
.cl
->length
3931 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3932 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3935 switch (expr
->expr_type
)
3940 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3942 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3950 case EXPR_SUBSTRING
:
3953 case EXPR_STRUCTURE
:
3955 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3956 c
; c
= gfc_constructor_next (c
))
3958 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3962 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3964 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3966 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3968 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3975 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3977 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3993 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3995 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3997 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3999 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4005 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4007 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4012 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4013 && ref
->u
.c
.component
->ts
.u
.cl
4014 && ref
->u
.c
.component
->ts
.u
.cl
->length
4015 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4017 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4021 if (ref
->u
.c
.component
->as
)
4022 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4023 + ref
->u
.c
.component
->as
->corank
; i
++)
4025 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4028 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4042 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4045 expr_set_symbols_referenced (gfc_expr
*expr
,
4046 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4047 int *f ATTRIBUTE_UNUSED
)
4049 if (expr
->expr_type
!= EXPR_VARIABLE
)
4051 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4056 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4058 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4062 /* Determine if an expression is a procedure pointer component. If yes, the
4063 argument 'comp' will point to the component (provided that 'comp' was
4067 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
4072 if (!expr
|| !expr
->ref
)
4079 if (ref
->type
== REF_COMPONENT
)
4081 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
4083 *comp
= ref
->u
.c
.component
;
4090 /* Walk an expression tree and check each variable encountered for being typed.
4091 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4092 mode as is a basic arithmetic expression using those; this is for things in
4095 INTEGER :: arr(n), n
4096 INTEGER :: arr(n + 1), n
4098 The namespace is needed for IMPLICIT typing. */
4100 static gfc_namespace
* check_typed_ns
;
4103 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4104 int* f ATTRIBUTE_UNUSED
)
4108 if (e
->expr_type
!= EXPR_VARIABLE
)
4111 gcc_assert (e
->symtree
);
4112 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4115 return (t
== FAILURE
);
4119 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4123 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4127 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4128 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4130 if (e
->expr_type
== EXPR_OP
)
4132 gfc_try t
= SUCCESS
;
4134 gcc_assert (e
->value
.op
.op1
);
4135 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4137 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4138 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4144 /* Otherwise, walk the expression and do it strictly. */
4145 check_typed_ns
= ns
;
4146 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4148 return error_found
? FAILURE
: SUCCESS
;
4152 /* Walk an expression tree and replace all dummy symbols by the corresponding
4153 symbol in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4154 statements. The boolean return value is required by gfc_traverse_expr. */
4157 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4159 if ((expr
->expr_type
== EXPR_VARIABLE
4160 || (expr
->expr_type
== EXPR_FUNCTION
4161 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4162 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
4163 && expr
->symtree
->n
.sym
->attr
.dummy
)
4165 gfc_symtree
*root
= sym
->formal_ns
? sym
->formal_ns
->sym_root
4166 : gfc_current_ns
->sym_root
;
4167 gfc_symtree
*stree
= gfc_find_symtree (root
, expr
->symtree
->n
.sym
->name
);
4169 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4170 expr
->symtree
= stree
;
4176 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
4178 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
4182 /* The following is analogous to 'replace_symbol', and needed for copying
4183 interfaces for procedure pointer components. The argument 'sym' must formally
4184 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4185 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4186 component in whose formal_ns the arguments have to be). */
4189 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4191 gfc_component
*comp
;
4192 comp
= (gfc_component
*)sym
;
4193 if ((expr
->expr_type
== EXPR_VARIABLE
4194 || (expr
->expr_type
== EXPR_FUNCTION
4195 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4196 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4199 gfc_namespace
*ns
= comp
->formal_ns
;
4200 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4201 the symtree rather than create a new one (and probably fail later). */
4202 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4203 expr
->symtree
->n
.sym
->name
);
4205 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4206 expr
->symtree
= stree
;
4212 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4214 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4219 gfc_ref_this_image (gfc_ref
*ref
)
4223 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4225 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4226 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4234 gfc_is_coindexed (gfc_expr
*e
)
4238 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4239 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4240 return !gfc_ref_this_image (ref
);
4246 /* Coarrays are variables with a corank but not being coindexed. However, also
4247 the following is a coarray: A subobject of a coarray is a coarray if it does
4248 not have any cosubscripts, vector subscripts, allocatable component
4249 selection, or pointer component selection. (F2008, 2.4.7) */
4252 gfc_is_coarray (gfc_expr
*e
)
4256 gfc_component
*comp
;
4261 if (e
->expr_type
!= EXPR_VARIABLE
)
4265 sym
= e
->symtree
->n
.sym
;
4267 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4268 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4270 coarray
= sym
->attr
.codimension
;
4272 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4276 comp
= ref
->u
.c
.component
;
4277 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4278 && (CLASS_DATA (comp
)->attr
.class_pointer
4279 || CLASS_DATA (comp
)->attr
.allocatable
))
4282 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4284 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4287 coarray
= comp
->attr
.codimension
;
4295 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4301 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4302 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4313 return coarray
&& !coindexed
;
4318 gfc_get_corank (gfc_expr
*e
)
4323 if (!gfc_is_coarray (e
))
4326 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4327 corank
= e
->ts
.u
.derived
->components
->as
4328 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4330 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4332 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4334 if (ref
->type
== REF_ARRAY
)
4335 corank
= ref
->u
.ar
.as
->corank
;
4336 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4343 /* Check whether the expression has an ultimate allocatable component.
4344 Being itself allocatable does not count. */
4346 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4348 gfc_ref
*ref
, *last
= NULL
;
4350 if (e
->expr_type
!= EXPR_VARIABLE
)
4353 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4354 if (ref
->type
== REF_COMPONENT
)
4357 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4358 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4359 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4360 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4364 if (e
->ts
.type
== BT_CLASS
)
4365 return CLASS_DATA (e
)->attr
.alloc_comp
;
4366 else if (e
->ts
.type
== BT_DERIVED
)
4367 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4373 /* Check whether the expression has an pointer component.
4374 Being itself a pointer does not count. */
4376 gfc_has_ultimate_pointer (gfc_expr
*e
)
4378 gfc_ref
*ref
, *last
= NULL
;
4380 if (e
->expr_type
!= EXPR_VARIABLE
)
4383 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4384 if (ref
->type
== REF_COMPONENT
)
4387 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4388 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4389 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4390 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4394 if (e
->ts
.type
== BT_CLASS
)
4395 return CLASS_DATA (e
)->attr
.pointer_comp
;
4396 else if (e
->ts
.type
== BT_DERIVED
)
4397 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4403 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4404 Note: A scalar is not regarded as "simply contiguous" by the standard.
4405 if bool is not strict, some futher checks are done - for instance,
4406 a "(::1)" is accepted. */
4409 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4413 gfc_array_ref
*ar
= NULL
;
4414 gfc_ref
*ref
, *part_ref
= NULL
;
4417 if (expr
->expr_type
== EXPR_FUNCTION
)
4418 return expr
->value
.function
.esym
4419 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4420 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4423 if (expr
->rank
== 0)
4426 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4429 return false; /* Array shall be last part-ref. */
4431 if (ref
->type
== REF_COMPONENT
)
4433 else if (ref
->type
== REF_SUBSTRING
)
4435 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4439 sym
= expr
->symtree
->n
.sym
;
4440 if (expr
->ts
.type
!= BT_CLASS
4442 && !part_ref
->u
.c
.component
->attr
.contiguous
4443 && part_ref
->u
.c
.component
->attr
.pointer
)
4445 && !sym
->attr
.contiguous
4446 && (sym
->attr
.pointer
4447 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
4450 if (!ar
|| ar
->type
== AR_FULL
)
4453 gcc_assert (ar
->type
== AR_SECTION
);
4455 /* Check for simply contiguous array */
4457 for (i
= 0; i
< ar
->dimen
; i
++)
4459 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4462 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4468 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4471 /* If the previous section was not contiguous, that's an error,
4472 unless we have effective only one element and checking is not
4474 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4475 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4476 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4477 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4478 ar
->end
[i
]->value
.integer
) != 0))
4481 /* Following the standard, "(::1)" or - if known at compile time -
4482 "(lbound:ubound)" are not simply contigous; if strict
4483 is false, they are regarded as simply contiguous. */
4484 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4485 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4486 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4490 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4491 || !ar
->as
->lower
[i
]
4492 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4493 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4494 ar
->as
->lower
[i
]->value
.integer
) != 0))
4498 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4499 || !ar
->as
->upper
[i
]
4500 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4501 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4502 ar
->as
->upper
[i
]->value
.integer
) != 0))
4510 /* Build call to an intrinsic procedure. The number of arguments has to be
4511 passed (rather than ending the list with a NULL value) because we may
4512 want to add arguments but with a NULL-expression. */
4515 gfc_build_intrinsic_call (const char* name
, locus where
, unsigned numarg
, ...)
4518 gfc_actual_arglist
* atail
;
4519 gfc_intrinsic_sym
* isym
;
4523 isym
= gfc_find_function (name
);
4526 result
= gfc_get_expr ();
4527 result
->expr_type
= EXPR_FUNCTION
;
4528 result
->ts
= isym
->ts
;
4529 result
->where
= where
;
4530 result
->value
.function
.name
= name
;
4531 result
->value
.function
.isym
= isym
;
4533 result
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4534 gcc_assert (result
->symtree
4535 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
4536 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
4538 va_start (ap
, numarg
);
4540 for (i
= 0; i
< numarg
; ++i
)
4544 atail
->next
= gfc_get_actual_arglist ();
4545 atail
= atail
->next
;
4548 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4550 atail
->expr
= va_arg (ap
, gfc_expr
*);
4558 /* Check if an expression may appear in a variable definition context
4559 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4560 This is called from the various places when resolving
4561 the pieces that make up such a context.
4563 Optionally, a possible error message can be suppressed if context is NULL
4564 and just the return status (SUCCESS / FAILURE) be requested. */
4567 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4568 const char* context
)
4570 gfc_symbol
* sym
= NULL
;
4572 bool check_intentin
;
4574 symbol_attribute attr
;
4577 if (e
->expr_type
== EXPR_VARIABLE
)
4579 gcc_assert (e
->symtree
);
4580 sym
= e
->symtree
->n
.sym
;
4582 else if (e
->expr_type
== EXPR_FUNCTION
)
4584 gcc_assert (e
->symtree
);
4585 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4588 attr
= gfc_expr_attr (e
);
4589 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4591 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4594 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4595 " context (%s) at %L", context
, &e
->where
);
4599 else if (e
->expr_type
!= EXPR_VARIABLE
)
4602 gfc_error ("Non-variable expression in variable definition context (%s)"
4603 " at %L", context
, &e
->where
);
4607 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4610 gfc_error ("Named constant '%s' in variable definition context (%s)"
4611 " at %L", sym
->name
, context
, &e
->where
);
4614 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4615 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4616 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4619 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4620 " a variable", sym
->name
, context
, &e
->where
);
4624 /* Find out whether the expr is a pointer; this also means following
4625 component references to the last one. */
4626 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4627 if (pointer
&& !is_pointer
)
4630 gfc_error ("Non-POINTER in pointer association context (%s)"
4631 " at %L", context
, &e
->where
);
4638 || (e
->ts
.type
== BT_DERIVED
4639 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4640 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4643 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4644 context
, &e
->where
);
4648 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
4649 component of sub-component of a pointer; we need to distinguish
4650 assignment to a pointer component from pointer-assignment to a pointer
4651 component. Note that (normal) assignment to procedure pointers is not
4653 check_intentin
= true;
4654 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4655 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4656 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4658 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4659 check_intentin
= false;
4660 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4662 ptr_component
= true;
4664 check_intentin
= false;
4667 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4669 if (pointer
&& is_pointer
)
4672 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4673 " association context (%s) at %L",
4674 sym
->name
, context
, &e
->where
);
4677 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
4680 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4681 " definition context (%s) at %L",
4682 sym
->name
, context
, &e
->where
);
4687 /* PROTECTED and use-associated. */
4688 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4690 if (pointer
&& is_pointer
)
4693 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4694 " pointer association context (%s) at %L",
4695 sym
->name
, context
, &e
->where
);
4698 if (!pointer
&& !is_pointer
)
4701 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4702 " variable definition context (%s) at %L",
4703 sym
->name
, context
, &e
->where
);
4708 /* Variable not assignable from a PURE procedure but appears in
4709 variable definition context. */
4710 if (!pointer
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4713 gfc_error ("Variable '%s' can not appear in a variable definition"
4714 " context (%s) at %L in PURE procedure",
4715 sym
->name
, context
, &e
->where
);
4719 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
4720 && gfc_impure_variable (sym
))
4725 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4727 sym
= ns
->proc_name
;
4730 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4732 sym
->attr
.implicit_pure
= 0;
4737 /* Check variable definition context for associate-names. */
4738 if (!pointer
&& sym
->assoc
)
4741 gfc_association_list
* assoc
;
4743 gcc_assert (sym
->assoc
->target
);
4745 /* If this is a SELECT TYPE temporary (the association is used internally
4746 for SELECT TYPE), silently go over to the target. */
4747 if (sym
->attr
.select_type_temporary
)
4749 gfc_expr
* t
= sym
->assoc
->target
;
4751 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4752 name
= t
->symtree
->name
;
4754 if (t
->symtree
->n
.sym
->assoc
)
4755 assoc
= t
->symtree
->n
.sym
->assoc
;
4764 gcc_assert (name
&& assoc
);
4766 /* Is association to a valid variable? */
4767 if (!assoc
->variable
)
4771 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4772 gfc_error ("'%s' at %L associated to vector-indexed target can"
4773 " not be used in a variable definition context (%s)",
4774 name
, &e
->where
, context
);
4776 gfc_error ("'%s' at %L associated to expression can"
4777 " not be used in a variable definition context (%s)",
4778 name
, &e
->where
, context
);
4783 /* Target must be allowed to appear in a variable definition context. */
4784 if (gfc_check_vardef_context (assoc
->target
, pointer
, false, NULL
)
4788 gfc_error ("Associate-name '%s' can not appear in a variable"
4789 " definition context (%s) at %L because its target"
4790 " at %L can not, either",
4791 name
, context
, &e
->where
,
4792 &assoc
->target
->where
);