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/>. */
25 #include "coretypes.h"
29 #include "target-memory.h" /* for gfc_convert_boz */
30 #include "constructor.h"
33 /* The following set of functions provide access to gfc_expr* of
34 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
36 There are two functions available elsewhere that provide
37 slightly different flavours of variables. Namely:
38 expr.c (gfc_get_variable_expr)
39 symbol.c (gfc_lval_expr_from_sym)
40 TODO: Merge these functions, if possible. */
42 /* Get a new expression node. */
50 gfc_clear_ts (&e
->ts
);
58 /* Get a new expression node that is an array constructor
59 of given type and kind. */
62 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
67 e
->expr_type
= EXPR_ARRAY
;
68 e
->value
.constructor
= NULL
;
81 /* Get a new expression node that is the NULL expression. */
84 gfc_get_null_expr (locus
*where
)
89 e
->expr_type
= EXPR_NULL
;
90 e
->ts
.type
= BT_UNKNOWN
;
99 /* Get a new expression node that is an operator expression node. */
102 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
103 gfc_expr
*op1
, gfc_expr
*op2
)
108 e
->expr_type
= EXPR_OP
;
110 e
->value
.op
.op1
= op1
;
111 e
->value
.op
.op2
= op2
;
120 /* Get a new expression node that is an structure constructor
121 of given type and kind. */
124 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
129 e
->expr_type
= EXPR_STRUCTURE
;
130 e
->value
.constructor
= NULL
;
141 /* Get a new expression node that is an constant of given type and kind. */
144 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
149 gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
153 e
->expr_type
= EXPR_CONSTANT
;
161 mpz_init (e
->value
.integer
);
165 gfc_set_model_kind (kind
);
166 mpfr_init (e
->value
.real
);
170 gfc_set_model_kind (kind
);
171 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
182 /* Get a new expression node that is an string constant.
183 If no string is passed, a string of len is allocated,
184 blanked and null-terminated. */
187 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, int len
)
194 dest
= gfc_get_wide_string (len
+ 1);
195 gfc_wide_memset (dest
, ' ', len
);
199 dest
= gfc_char_to_widechar (src
);
201 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
202 where
? where
: &gfc_current_locus
);
203 e
->value
.character
.string
= dest
;
204 e
->value
.character
.length
= len
;
210 /* Get a new expression node that is an integer constant. */
213 gfc_get_int_expr (int kind
, locus
*where
, int value
)
216 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
217 where
? where
: &gfc_current_locus
);
219 mpz_set_si (p
->value
.integer
, value
);
225 /* Get a new expression node that is a logical constant. */
228 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
231 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
232 where
? where
: &gfc_current_locus
);
234 p
->value
.logical
= value
;
241 gfc_get_iokind_expr (locus
*where
, io_kind k
)
245 /* Set the types to something compatible with iokind. This is needed to
246 get through gfc_free_expr later since iokind really has no Basic Type,
250 e
->expr_type
= EXPR_CONSTANT
;
251 e
->ts
.type
= BT_LOGICAL
;
259 /* Given an expression pointer, return a copy of the expression. This
260 subroutine is recursive. */
263 gfc_copy_expr (gfc_expr
*p
)
275 switch (q
->expr_type
)
278 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
279 q
->value
.character
.string
= s
;
280 memcpy (s
, p
->value
.character
.string
,
281 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
285 /* Copy target representation, if it exists. */
286 if (p
->representation
.string
)
288 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
289 q
->representation
.string
= c
;
290 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
293 /* Copy the values of any pointer components of p->value. */
297 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
301 gfc_set_model_kind (q
->ts
.kind
);
302 mpfr_init (q
->value
.real
);
303 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
307 gfc_set_model_kind (q
->ts
.kind
);
308 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
309 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
313 if (p
->representation
.string
)
314 q
->value
.character
.string
315 = gfc_char_to_widechar (q
->representation
.string
);
318 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
319 q
->value
.character
.string
= s
;
321 /* This is the case for the C_NULL_CHAR named constant. */
322 if (p
->value
.character
.length
== 0
323 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
326 /* Need to set the length to 1 to make sure the NUL
327 terminator is copied. */
328 q
->value
.character
.length
= 1;
331 memcpy (s
, p
->value
.character
.string
,
332 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
341 break; /* Already done. */
345 /* Should never be reached. */
347 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
354 switch (q
->value
.op
.op
)
357 case INTRINSIC_PARENTHESES
:
358 case INTRINSIC_UPLUS
:
359 case INTRINSIC_UMINUS
:
360 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
363 default: /* Binary operators. */
364 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
365 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
372 q
->value
.function
.actual
=
373 gfc_copy_actual_arglist (p
->value
.function
.actual
);
378 q
->value
.compcall
.actual
=
379 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
380 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
385 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
393 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
395 q
->ref
= gfc_copy_ref (p
->ref
);
402 gfc_clear_shape (mpz_t
*shape
, int rank
)
406 for (i
= 0; i
< rank
; i
++)
407 mpz_clear (shape
[i
]);
412 gfc_free_shape (mpz_t
**shape
, int rank
)
417 gfc_clear_shape (*shape
, rank
);
423 /* Workhorse function for gfc_free_expr() that frees everything
424 beneath an expression node, but not the node itself. This is
425 useful when we want to simplify a node and replace it with
426 something else or the expression node belongs to another structure. */
429 free_expr0 (gfc_expr
*e
)
431 switch (e
->expr_type
)
434 /* Free any parts of the value that need freeing. */
438 mpz_clear (e
->value
.integer
);
442 mpfr_clear (e
->value
.real
);
446 free (e
->value
.character
.string
);
450 mpc_clear (e
->value
.complex);
457 /* Free the representation. */
458 free (e
->representation
.string
);
463 if (e
->value
.op
.op1
!= NULL
)
464 gfc_free_expr (e
->value
.op
.op1
);
465 if (e
->value
.op
.op2
!= NULL
)
466 gfc_free_expr (e
->value
.op
.op2
);
470 gfc_free_actual_arglist (e
->value
.function
.actual
);
475 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
483 gfc_constructor_free (e
->value
.constructor
);
487 free (e
->value
.character
.string
);
494 gfc_internal_error ("free_expr0(): Bad expr type");
497 /* Free a shape array. */
498 gfc_free_shape (&e
->shape
, e
->rank
);
500 gfc_free_ref_list (e
->ref
);
502 memset (e
, '\0', sizeof (gfc_expr
));
506 /* Free an expression node and everything beneath it. */
509 gfc_free_expr (gfc_expr
*e
)
518 /* Free an argument list and everything below it. */
521 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
523 gfc_actual_arglist
*a2
;
528 gfc_free_expr (a1
->expr
);
535 /* Copy an arglist structure and all of the arguments. */
538 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
540 gfc_actual_arglist
*head
, *tail
, *new_arg
;
544 for (; p
; p
= p
->next
)
546 new_arg
= gfc_get_actual_arglist ();
549 new_arg
->expr
= gfc_copy_expr (p
->expr
);
550 new_arg
->next
= NULL
;
555 tail
->next
= new_arg
;
564 /* Free a list of reference structures. */
567 gfc_free_ref_list (gfc_ref
*p
)
579 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
581 gfc_free_expr (p
->u
.ar
.start
[i
]);
582 gfc_free_expr (p
->u
.ar
.end
[i
]);
583 gfc_free_expr (p
->u
.ar
.stride
[i
]);
589 gfc_free_expr (p
->u
.ss
.start
);
590 gfc_free_expr (p
->u
.ss
.end
);
602 /* Graft the *src expression onto the *dest subexpression. */
605 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
613 /* Try to extract an integer constant from the passed expression node.
614 Returns an error message or NULL if the result is set. It is
615 tempting to generate an error and return SUCCESS or FAILURE, but
616 failure is OK for some callers. */
619 gfc_extract_int (gfc_expr
*expr
, int *result
)
621 if (expr
->expr_type
!= EXPR_CONSTANT
)
622 return _("Constant expression required at %C");
624 if (expr
->ts
.type
!= BT_INTEGER
)
625 return _("Integer expression required at %C");
627 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
628 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
630 return _("Integer value too large in expression at %C");
633 *result
= (int) mpz_get_si (expr
->value
.integer
);
639 /* Recursively copy a list of reference structures. */
642 gfc_copy_ref (gfc_ref
*src
)
650 dest
= gfc_get_ref ();
651 dest
->type
= src
->type
;
656 ar
= gfc_copy_array_ref (&src
->u
.ar
);
662 dest
->u
.c
= src
->u
.c
;
666 dest
->u
.ss
= src
->u
.ss
;
667 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
668 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
672 dest
->next
= gfc_copy_ref (src
->next
);
678 /* Detect whether an expression has any vector index array references. */
681 gfc_has_vector_index (gfc_expr
*e
)
685 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
686 if (ref
->type
== REF_ARRAY
)
687 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
688 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
694 /* Copy a shape array. */
697 gfc_copy_shape (mpz_t
*shape
, int rank
)
705 new_shape
= gfc_get_shape (rank
);
707 for (n
= 0; n
< rank
; n
++)
708 mpz_init_set (new_shape
[n
], shape
[n
]);
714 /* Copy a shape array excluding dimension N, where N is an integer
715 constant expression. Dimensions are numbered in Fortran style --
718 So, if the original shape array contains R elements
719 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
720 the result contains R-1 elements:
721 { s1 ... sN-1 sN+1 ... sR-1}
723 If anything goes wrong -- N is not a constant, its value is out
724 of range -- or anything else, just returns NULL. */
727 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
729 mpz_t
*new_shape
, *s
;
735 || dim
->expr_type
!= EXPR_CONSTANT
736 || dim
->ts
.type
!= BT_INTEGER
)
739 n
= mpz_get_si (dim
->value
.integer
);
740 n
--; /* Convert to zero based index. */
741 if (n
< 0 || n
>= rank
)
744 s
= new_shape
= gfc_get_shape (rank
- 1);
746 for (i
= 0; i
< rank
; i
++)
750 mpz_init_set (*s
, shape
[i
]);
758 /* Return the maximum kind of two expressions. In general, higher
759 kind numbers mean more precision for numeric types. */
762 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
764 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
768 /* Returns nonzero if the type is numeric, zero otherwise. */
771 numeric_type (bt type
)
773 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
777 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
780 gfc_numeric_ts (gfc_typespec
*ts
)
782 return numeric_type (ts
->type
);
786 /* Return an expression node with an optional argument list attached.
787 A variable number of gfc_expr pointers are strung together in an
788 argument list with a NULL pointer terminating the list. */
791 gfc_build_conversion (gfc_expr
*e
)
796 p
->expr_type
= EXPR_FUNCTION
;
798 p
->value
.function
.actual
= NULL
;
800 p
->value
.function
.actual
= gfc_get_actual_arglist ();
801 p
->value
.function
.actual
->expr
= e
;
807 /* Given an expression node with some sort of numeric binary
808 expression, insert type conversions required to make the operands
809 have the same type. Conversion warnings are disabled if wconversion
812 The exception is that the operands of an exponential don't have to
813 have the same type. If possible, the base is promoted to the type
814 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
815 1.0**2 stays as it is. */
818 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
822 op1
= e
->value
.op
.op1
;
823 op2
= e
->value
.op
.op2
;
825 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
827 gfc_clear_ts (&e
->ts
);
831 /* Kind conversions of same type. */
832 if (op1
->ts
.type
== op2
->ts
.type
)
834 if (op1
->ts
.kind
== op2
->ts
.kind
)
836 /* No type conversions. */
841 if (op1
->ts
.kind
> op2
->ts
.kind
)
842 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
844 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
850 /* Integer combined with real or complex. */
851 if (op2
->ts
.type
== BT_INTEGER
)
855 /* Special case for ** operator. */
856 if (e
->value
.op
.op
== INTRINSIC_POWER
)
859 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
863 if (op1
->ts
.type
== BT_INTEGER
)
866 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
870 /* Real combined with complex. */
871 e
->ts
.type
= BT_COMPLEX
;
872 if (op1
->ts
.kind
> op2
->ts
.kind
)
873 e
->ts
.kind
= op1
->ts
.kind
;
875 e
->ts
.kind
= op2
->ts
.kind
;
876 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
877 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
878 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
879 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
886 /* Function to determine if an expression is constant or not. This
887 function expects that the expression has already been simplified. */
890 gfc_is_constant_expr (gfc_expr
*e
)
893 gfc_actual_arglist
*arg
;
899 switch (e
->expr_type
)
902 return (gfc_is_constant_expr (e
->value
.op
.op1
)
903 && (e
->value
.op
.op2
== NULL
904 || gfc_is_constant_expr (e
->value
.op
.op2
)));
912 gcc_assert (e
->symtree
|| e
->value
.function
.esym
913 || e
->value
.function
.isym
);
915 /* Call to intrinsic with at least one argument. */
916 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
918 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
919 if (!gfc_is_constant_expr (arg
->expr
))
923 /* Specification functions are constant. */
924 /* F95, 7.1.6.2; F2003, 7.1.7 */
927 sym
= e
->symtree
->n
.sym
;
928 if (e
->value
.function
.esym
)
929 sym
= e
->value
.function
.esym
;
932 && sym
->attr
.function
934 && !sym
->attr
.intrinsic
935 && !sym
->attr
.recursive
936 && sym
->attr
.proc
!= PROC_INTERNAL
937 && sym
->attr
.proc
!= PROC_ST_FUNCTION
938 && sym
->attr
.proc
!= PROC_UNKNOWN
939 && sym
->formal
== NULL
)
942 if (e
->value
.function
.isym
943 && (e
->value
.function
.isym
->elemental
944 || e
->value
.function
.isym
->pure
945 || e
->value
.function
.isym
->inquiry
946 || e
->value
.function
.isym
->transformational
))
956 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
957 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
961 c
= gfc_constructor_first (e
->value
.constructor
);
962 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
963 return gfc_constant_ac (e
);
965 for (; c
; c
= gfc_constructor_next (c
))
966 if (!gfc_is_constant_expr (c
->expr
))
973 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
979 /* Is true if an array reference is followed by a component or substring
982 is_subref_array (gfc_expr
* e
)
987 if (e
->expr_type
!= EXPR_VARIABLE
)
990 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
994 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
996 if (ref
->type
== REF_ARRAY
997 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1001 && ref
->type
!= REF_ARRAY
)
1008 /* Try to collapse intrinsic expressions. */
1011 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1013 gfc_intrinsic_op op
;
1014 gfc_expr
*op1
, *op2
, *result
;
1016 if (p
->value
.op
.op
== INTRINSIC_USER
)
1019 op1
= p
->value
.op
.op1
;
1020 op2
= p
->value
.op
.op2
;
1021 op
= p
->value
.op
.op
;
1023 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1025 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1028 if (!gfc_is_constant_expr (op1
)
1029 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1033 p
->value
.op
.op1
= NULL
;
1034 p
->value
.op
.op2
= NULL
;
1038 case INTRINSIC_PARENTHESES
:
1039 result
= gfc_parentheses (op1
);
1042 case INTRINSIC_UPLUS
:
1043 result
= gfc_uplus (op1
);
1046 case INTRINSIC_UMINUS
:
1047 result
= gfc_uminus (op1
);
1050 case INTRINSIC_PLUS
:
1051 result
= gfc_add (op1
, op2
);
1054 case INTRINSIC_MINUS
:
1055 result
= gfc_subtract (op1
, op2
);
1058 case INTRINSIC_TIMES
:
1059 result
= gfc_multiply (op1
, op2
);
1062 case INTRINSIC_DIVIDE
:
1063 result
= gfc_divide (op1
, op2
);
1066 case INTRINSIC_POWER
:
1067 result
= gfc_power (op1
, op2
);
1070 case INTRINSIC_CONCAT
:
1071 result
= gfc_concat (op1
, op2
);
1075 case INTRINSIC_EQ_OS
:
1076 result
= gfc_eq (op1
, op2
, op
);
1080 case INTRINSIC_NE_OS
:
1081 result
= gfc_ne (op1
, op2
, op
);
1085 case INTRINSIC_GT_OS
:
1086 result
= gfc_gt (op1
, op2
, op
);
1090 case INTRINSIC_GE_OS
:
1091 result
= gfc_ge (op1
, op2
, op
);
1095 case INTRINSIC_LT_OS
:
1096 result
= gfc_lt (op1
, op2
, op
);
1100 case INTRINSIC_LE_OS
:
1101 result
= gfc_le (op1
, op2
, op
);
1105 result
= gfc_not (op1
);
1109 result
= gfc_and (op1
, op2
);
1113 result
= gfc_or (op1
, op2
);
1117 result
= gfc_eqv (op1
, op2
);
1120 case INTRINSIC_NEQV
:
1121 result
= gfc_neqv (op1
, op2
);
1125 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1130 gfc_free_expr (op1
);
1131 gfc_free_expr (op2
);
1135 result
->rank
= p
->rank
;
1136 result
->where
= p
->where
;
1137 gfc_replace_expr (p
, result
);
1143 /* Subroutine to simplify constructor expressions. Mutually recursive
1144 with gfc_simplify_expr(). */
1147 simplify_constructor (gfc_constructor_base base
, int type
)
1152 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1155 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1156 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1157 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1162 /* Try and simplify a copy. Replace the original if successful
1163 but keep going through the constructor at all costs. Not
1164 doing so can make a dog's dinner of complicated things. */
1165 p
= gfc_copy_expr (c
->expr
);
1167 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1173 gfc_replace_expr (c
->expr
, p
);
1181 /* Pull a single array element out of an array constructor. */
1184 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1185 gfc_constructor
**rval
)
1187 unsigned long nelemen
;
1193 gfc_constructor
*cons
;
1200 mpz_init_set_ui (offset
, 0);
1203 mpz_init_set_ui (span
, 1);
1204 for (i
= 0; i
< ar
->dimen
; i
++)
1206 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1207 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1214 e
= gfc_copy_expr (ar
->start
[i
]);
1215 if (e
->expr_type
!= EXPR_CONSTANT
)
1221 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1222 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1224 /* Check the bounds. */
1225 if ((ar
->as
->upper
[i
]
1226 && mpz_cmp (e
->value
.integer
,
1227 ar
->as
->upper
[i
]->value
.integer
) > 0)
1228 || (mpz_cmp (e
->value
.integer
,
1229 ar
->as
->lower
[i
]->value
.integer
) < 0))
1231 gfc_error ("Index in dimension %d is out of bounds "
1232 "at %L", i
+ 1, &ar
->c_where
[i
]);
1238 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1239 mpz_mul (delta
, delta
, span
);
1240 mpz_add (offset
, offset
, delta
);
1242 mpz_set_ui (tmp
, 1);
1243 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1244 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1245 mpz_mul (span
, span
, tmp
);
1248 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1249 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1270 /* Find a component of a structure constructor. */
1272 static gfc_constructor
*
1273 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1275 gfc_component
*comp
;
1276 gfc_component
*pick
;
1277 gfc_constructor
*c
= gfc_constructor_first (base
);
1279 comp
= ref
->u
.c
.sym
->components
;
1280 pick
= ref
->u
.c
.component
;
1281 while (comp
!= pick
)
1284 c
= gfc_constructor_next (c
);
1291 /* Replace an expression with the contents of a constructor, removing
1292 the subobject reference in the process. */
1295 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1305 e
= gfc_copy_expr (p
);
1306 e
->ref
= p
->ref
->next
;
1307 p
->ref
->next
= NULL
;
1308 gfc_replace_expr (p
, e
);
1312 /* Pull an array section out of an array constructor. */
1315 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1322 long unsigned one
= 1;
1324 mpz_t start
[GFC_MAX_DIMENSIONS
];
1325 mpz_t end
[GFC_MAX_DIMENSIONS
];
1326 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1327 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1328 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1333 gfc_constructor_base base
;
1334 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1344 base
= expr
->value
.constructor
;
1345 expr
->value
.constructor
= NULL
;
1347 rank
= ref
->u
.ar
.as
->rank
;
1349 if (expr
->shape
== NULL
)
1350 expr
->shape
= gfc_get_shape (rank
);
1352 mpz_init_set_ui (delta_mpz
, one
);
1353 mpz_init_set_ui (nelts
, one
);
1356 /* Do the initialization now, so that we can cleanup without
1357 keeping track of where we were. */
1358 for (d
= 0; d
< rank
; d
++)
1360 mpz_init (delta
[d
]);
1361 mpz_init (start
[d
]);
1364 mpz_init (stride
[d
]);
1368 /* Build the counters to clock through the array reference. */
1370 for (d
= 0; d
< rank
; d
++)
1372 /* Make this stretch of code easier on the eye! */
1373 begin
= ref
->u
.ar
.start
[d
];
1374 finish
= ref
->u
.ar
.end
[d
];
1375 step
= ref
->u
.ar
.stride
[d
];
1376 lower
= ref
->u
.ar
.as
->lower
[d
];
1377 upper
= ref
->u
.ar
.as
->upper
[d
];
1379 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1381 gfc_constructor
*ci
;
1384 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1390 gcc_assert (begin
->rank
== 1);
1391 /* Zero-sized arrays have no shape and no elements, stop early. */
1394 mpz_init_set_ui (nelts
, 0);
1398 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1399 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1400 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1401 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1404 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1406 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1407 || mpz_cmp (ci
->expr
->value
.integer
,
1408 lower
->value
.integer
) < 0)
1410 gfc_error ("index in dimension %d is out of bounds "
1411 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1419 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1420 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1421 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1427 /* Obtain the stride. */
1429 mpz_set (stride
[d
], step
->value
.integer
);
1431 mpz_set_ui (stride
[d
], one
);
1433 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1434 mpz_set_ui (stride
[d
], one
);
1436 /* Obtain the start value for the index. */
1438 mpz_set (start
[d
], begin
->value
.integer
);
1440 mpz_set (start
[d
], lower
->value
.integer
);
1442 mpz_set (ctr
[d
], start
[d
]);
1444 /* Obtain the end value for the index. */
1446 mpz_set (end
[d
], finish
->value
.integer
);
1448 mpz_set (end
[d
], upper
->value
.integer
);
1450 /* Separate 'if' because elements sometimes arrive with
1452 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1453 mpz_set (end
[d
], begin
->value
.integer
);
1455 /* Check the bounds. */
1456 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1457 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1458 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1459 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1461 gfc_error ("index in dimension %d is out of bounds "
1462 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1467 /* Calculate the number of elements and the shape. */
1468 mpz_set (tmp_mpz
, stride
[d
]);
1469 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1470 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1471 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1472 mpz_mul (nelts
, nelts
, tmp_mpz
);
1474 /* An element reference reduces the rank of the expression; don't
1475 add anything to the shape array. */
1476 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1477 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1480 /* Calculate the 'stride' (=delta) for conversion of the
1481 counter values into the index along the constructor. */
1482 mpz_set (delta
[d
], delta_mpz
);
1483 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1484 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1485 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1489 cons
= gfc_constructor_first (base
);
1491 /* Now clock through the array reference, calculating the index in
1492 the source constructor and transferring the elements to the new
1494 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1496 if (ref
->u
.ar
.offset
)
1497 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1499 mpz_init_set_ui (ptr
, 0);
1502 for (d
= 0; d
< rank
; d
++)
1504 mpz_set (tmp_mpz
, ctr
[d
]);
1505 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1506 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1507 mpz_add (ptr
, ptr
, tmp_mpz
);
1509 if (!incr_ctr
) continue;
1511 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1513 gcc_assert(vecsub
[d
]);
1515 if (!gfc_constructor_next (vecsub
[d
]))
1516 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1519 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1522 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1526 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1528 if (mpz_cmp_ui (stride
[d
], 0) > 0
1529 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1530 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1531 mpz_set (ctr
[d
], start
[d
]);
1537 limit
= mpz_get_ui (ptr
);
1538 if (limit
>= gfc_option
.flag_max_array_constructor
)
1540 gfc_error ("The number of elements in the array constructor "
1541 "at %L requires an increase of the allowed %d "
1542 "upper limit. See -fmax-array-constructor "
1543 "option", &expr
->where
,
1544 gfc_option
.flag_max_array_constructor
);
1548 cons
= gfc_constructor_lookup (base
, limit
);
1550 gfc_constructor_append_expr (&expr
->value
.constructor
,
1551 gfc_copy_expr (cons
->expr
), NULL
);
1558 mpz_clear (delta_mpz
);
1559 mpz_clear (tmp_mpz
);
1561 for (d
= 0; d
< rank
; d
++)
1563 mpz_clear (delta
[d
]);
1564 mpz_clear (start
[d
]);
1567 mpz_clear (stride
[d
]);
1569 gfc_constructor_free (base
);
1573 /* Pull a substring out of an expression. */
1576 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1583 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1584 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1587 *newp
= gfc_copy_expr (p
);
1588 free ((*newp
)->value
.character
.string
);
1590 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1591 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1592 length
= end
- start
+ 1;
1594 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1595 (*newp
)->value
.character
.length
= length
;
1596 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1597 length
* sizeof (gfc_char_t
));
1604 /* Simplify a subobject reference of a constructor. This occurs when
1605 parameter variable values are substituted. */
1608 simplify_const_ref (gfc_expr
*p
)
1610 gfc_constructor
*cons
, *c
;
1616 switch (p
->ref
->type
)
1619 switch (p
->ref
->u
.ar
.type
)
1622 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1623 will generate this. */
1624 if (p
->expr_type
!= EXPR_ARRAY
)
1626 remove_subobject_ref (p
, NULL
);
1629 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1636 remove_subobject_ref (p
, cons
);
1640 if (find_array_section (p
, p
->ref
) == FAILURE
)
1642 p
->ref
->u
.ar
.type
= AR_FULL
;
1647 if (p
->ref
->next
!= NULL
1648 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1650 for (c
= gfc_constructor_first (p
->value
.constructor
);
1651 c
; c
= gfc_constructor_next (c
))
1653 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1654 if (simplify_const_ref (c
->expr
) == FAILURE
)
1658 if (p
->ts
.type
== BT_DERIVED
1660 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1662 /* There may have been component references. */
1663 p
->ts
= c
->expr
->ts
;
1667 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1669 if (p
->ts
.type
== BT_CHARACTER
1670 && last_ref
->type
== REF_SUBSTRING
)
1672 /* If this is a CHARACTER array and we possibly took
1673 a substring out of it, update the type-spec's
1674 character length according to the first element
1675 (as all should have the same length). */
1677 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1679 const gfc_expr
* first
= c
->expr
;
1680 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1681 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1682 string_len
= first
->value
.character
.length
;
1688 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1691 gfc_free_expr (p
->ts
.u
.cl
->length
);
1694 = gfc_get_int_expr (gfc_default_integer_kind
,
1698 gfc_free_ref_list (p
->ref
);
1709 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1710 remove_subobject_ref (p
, cons
);
1714 if (find_substring_ref (p
, &newp
) == FAILURE
)
1717 gfc_replace_expr (p
, newp
);
1718 gfc_free_ref_list (p
->ref
);
1728 /* Simplify a chain of references. */
1731 simplify_ref_chain (gfc_ref
*ref
, int type
)
1735 for (; ref
; ref
= ref
->next
)
1740 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1742 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1744 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1746 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1752 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1754 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1766 /* Try to substitute the value of a parameter variable. */
1769 simplify_parameter_variable (gfc_expr
*p
, int type
)
1774 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1780 /* Do not copy subobject refs for constant. */
1781 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1782 e
->ref
= gfc_copy_ref (p
->ref
);
1783 t
= gfc_simplify_expr (e
, type
);
1785 /* Only use the simplification if it eliminated all subobject references. */
1786 if (t
== SUCCESS
&& !e
->ref
)
1787 gfc_replace_expr (p
, e
);
1794 /* Given an expression, simplify it by collapsing constant
1795 expressions. Most simplification takes place when the expression
1796 tree is being constructed. If an intrinsic function is simplified
1797 at some point, we get called again to collapse the result against
1800 We work by recursively simplifying expression nodes, simplifying
1801 intrinsic functions where possible, which can lead to further
1802 constant collapsing. If an operator has constant operand(s), we
1803 rip the expression apart, and rebuild it, hoping that it becomes
1806 The expression type is defined for:
1807 0 Basic expression parsing
1808 1 Simplifying array constructors -- will substitute
1810 Returns FAILURE on error, SUCCESS otherwise.
1811 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1814 gfc_simplify_expr (gfc_expr
*p
, int type
)
1816 gfc_actual_arglist
*ap
;
1821 switch (p
->expr_type
)
1828 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1829 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1832 if (p
->value
.function
.isym
!= NULL
1833 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1838 case EXPR_SUBSTRING
:
1839 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1842 if (gfc_is_constant_expr (p
))
1848 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1850 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1851 start
--; /* Convert from one-based to zero-based. */
1854 end
= p
->value
.character
.length
;
1855 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1856 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1861 s
= gfc_get_wide_string (end
- start
+ 2);
1862 memcpy (s
, p
->value
.character
.string
+ start
,
1863 (end
- start
) * sizeof (gfc_char_t
));
1864 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1865 free (p
->value
.character
.string
);
1866 p
->value
.character
.string
= s
;
1867 p
->value
.character
.length
= end
- start
;
1868 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1869 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1871 p
->value
.character
.length
);
1872 gfc_free_ref_list (p
->ref
);
1874 p
->expr_type
= EXPR_CONSTANT
;
1879 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1884 /* Only substitute array parameter variables if we are in an
1885 initialization expression, or we want a subsection. */
1886 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1887 && (gfc_init_expr_flag
|| p
->ref
1888 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1890 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1897 gfc_simplify_iterator_var (p
);
1900 /* Simplify subcomponent references. */
1901 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1906 case EXPR_STRUCTURE
:
1908 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1911 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1914 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1915 && p
->ref
->u
.ar
.type
== AR_FULL
)
1916 gfc_expand_constructor (p
, false);
1918 if (simplify_const_ref (p
) == FAILURE
)
1933 /* Returns the type of an expression with the exception that iterator
1934 variables are automatically integers no matter what else they may
1940 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1947 /* Scalarize an expression for an elemental intrinsic call. */
1950 scalarize_intrinsic_call (gfc_expr
*e
)
1952 gfc_actual_arglist
*a
, *b
;
1953 gfc_constructor_base ctor
;
1954 gfc_constructor
*args
[5];
1955 gfc_constructor
*ci
, *new_ctor
;
1956 gfc_expr
*expr
, *old
;
1957 int n
, i
, rank
[5], array_arg
;
1959 /* Find which, if any, arguments are arrays. Assume that the old
1960 expression carries the type information and that the first arg
1961 that is an array expression carries all the shape information.*/
1963 a
= e
->value
.function
.actual
;
1964 for (; a
; a
= a
->next
)
1967 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1970 expr
= gfc_copy_expr (a
->expr
);
1977 old
= gfc_copy_expr (e
);
1979 gfc_constructor_free (expr
->value
.constructor
);
1980 expr
->value
.constructor
= NULL
;
1982 expr
->where
= old
->where
;
1983 expr
->expr_type
= EXPR_ARRAY
;
1985 /* Copy the array argument constructors into an array, with nulls
1988 a
= old
->value
.function
.actual
;
1989 for (; a
; a
= a
->next
)
1991 /* Check that this is OK for an initialization expression. */
1992 if (a
->expr
&& gfc_check_init_expr (a
->expr
) == FAILURE
)
1996 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1998 rank
[n
] = a
->expr
->rank
;
1999 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2000 args
[n
] = gfc_constructor_first (ctor
);
2002 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2005 rank
[n
] = a
->expr
->rank
;
2008 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2009 args
[n
] = gfc_constructor_first (ctor
);
2018 /* Using the array argument as the master, step through the array
2019 calling the function for each element and advancing the array
2020 constructors together. */
2021 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2023 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2024 gfc_copy_expr (old
), NULL
);
2026 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2028 b
= old
->value
.function
.actual
;
2029 for (i
= 0; i
< n
; i
++)
2032 new_ctor
->expr
->value
.function
.actual
2033 = a
= gfc_get_actual_arglist ();
2036 a
->next
= gfc_get_actual_arglist ();
2041 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2043 a
->expr
= gfc_copy_expr (b
->expr
);
2048 /* Simplify the function calls. If the simplification fails, the
2049 error will be flagged up down-stream or the library will deal
2051 gfc_simplify_expr (new_ctor
->expr
, 0);
2053 for (i
= 0; i
< n
; i
++)
2055 args
[i
] = gfc_constructor_next (args
[i
]);
2057 for (i
= 1; i
< n
; i
++)
2058 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2059 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2065 gfc_free_expr (old
);
2069 gfc_error_now ("elemental function arguments at %C are not compliant");
2072 gfc_free_expr (expr
);
2073 gfc_free_expr (old
);
2079 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2081 gfc_expr
*op1
= e
->value
.op
.op1
;
2082 gfc_expr
*op2
= e
->value
.op
.op2
;
2084 if ((*check_function
) (op1
) == FAILURE
)
2087 switch (e
->value
.op
.op
)
2089 case INTRINSIC_UPLUS
:
2090 case INTRINSIC_UMINUS
:
2091 if (!numeric_type (et0 (op1
)))
2096 case INTRINSIC_EQ_OS
:
2098 case INTRINSIC_NE_OS
:
2100 case INTRINSIC_GT_OS
:
2102 case INTRINSIC_GE_OS
:
2104 case INTRINSIC_LT_OS
:
2106 case INTRINSIC_LE_OS
:
2107 if ((*check_function
) (op2
) == FAILURE
)
2110 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2111 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2113 gfc_error ("Numeric or CHARACTER operands are required in "
2114 "expression at %L", &e
->where
);
2119 case INTRINSIC_PLUS
:
2120 case INTRINSIC_MINUS
:
2121 case INTRINSIC_TIMES
:
2122 case INTRINSIC_DIVIDE
:
2123 case INTRINSIC_POWER
:
2124 if ((*check_function
) (op2
) == FAILURE
)
2127 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2132 case INTRINSIC_CONCAT
:
2133 if ((*check_function
) (op2
) == FAILURE
)
2136 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2138 gfc_error ("Concatenation operator in expression at %L "
2139 "must have two CHARACTER operands", &op1
->where
);
2143 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2145 gfc_error ("Concat operator at %L must concatenate strings of the "
2146 "same kind", &e
->where
);
2153 if (et0 (op1
) != BT_LOGICAL
)
2155 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2156 "operand", &op1
->where
);
2165 case INTRINSIC_NEQV
:
2166 if ((*check_function
) (op2
) == FAILURE
)
2169 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2171 gfc_error ("LOGICAL operands are required in expression at %L",
2178 case INTRINSIC_PARENTHESES
:
2182 gfc_error ("Only intrinsic operators can be used in expression at %L",
2190 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2195 /* F2003, 7.1.7 (3): In init expression, allocatable components
2196 must not be data-initialized. */
2198 check_alloc_comp_init (gfc_expr
*e
)
2200 gfc_component
*comp
;
2201 gfc_constructor
*ctor
;
2203 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2204 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2206 for (comp
= e
->ts
.u
.derived
->components
,
2207 ctor
= gfc_constructor_first (e
->value
.constructor
);
2208 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2210 if (comp
->attr
.allocatable
2211 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2213 gfc_error("Invalid initialization expression for ALLOCATABLE "
2214 "component '%s' in structure constructor at %L",
2215 comp
->name
, &ctor
->expr
->where
);
2224 check_init_expr_arguments (gfc_expr
*e
)
2226 gfc_actual_arglist
*ap
;
2228 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2229 if (gfc_check_init_expr (ap
->expr
) == FAILURE
)
2235 static gfc_try
check_restricted (gfc_expr
*);
2237 /* F95, 7.1.6.1, Initialization expressions, (7)
2238 F2003, 7.1.7 Initialization expression, (8) */
2241 check_inquiry (gfc_expr
*e
, int not_restricted
)
2244 const char *const *functions
;
2246 static const char *const inquiry_func_f95
[] = {
2247 "lbound", "shape", "size", "ubound",
2248 "bit_size", "len", "kind",
2249 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2250 "precision", "radix", "range", "tiny",
2254 static const char *const inquiry_func_f2003
[] = {
2255 "lbound", "shape", "size", "ubound",
2256 "bit_size", "len", "kind",
2257 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2258 "precision", "radix", "range", "tiny",
2263 gfc_actual_arglist
*ap
;
2265 if (!e
->value
.function
.isym
2266 || !e
->value
.function
.isym
->inquiry
)
2269 /* An undeclared parameter will get us here (PR25018). */
2270 if (e
->symtree
== NULL
)
2273 name
= e
->symtree
->n
.sym
->name
;
2275 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2276 ? inquiry_func_f2003
: inquiry_func_f95
;
2278 for (i
= 0; functions
[i
]; i
++)
2279 if (strcmp (functions
[i
], name
) == 0)
2282 if (functions
[i
] == NULL
)
2285 /* At this point we have an inquiry function with a variable argument. The
2286 type of the variable might be undefined, but we need it now, because the
2287 arguments of these functions are not allowed to be undefined. */
2289 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2294 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2296 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2297 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2301 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2304 /* Assumed character length will not reduce to a constant expression
2305 with LEN, as required by the standard. */
2306 if (i
== 5 && not_restricted
2307 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2308 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2309 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2311 gfc_error ("Assumed or deferred character length variable '%s' "
2312 " in constant expression at %L",
2313 ap
->expr
->symtree
->n
.sym
->name
,
2317 else if (not_restricted
&& gfc_check_init_expr (ap
->expr
) == FAILURE
)
2320 if (not_restricted
== 0
2321 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2322 && check_restricted (ap
->expr
) == FAILURE
)
2325 if (not_restricted
== 0
2326 && ap
->expr
->expr_type
== EXPR_VARIABLE
2327 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2328 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2336 /* F95, 7.1.6.1, Initialization expressions, (5)
2337 F2003, 7.1.7 Initialization expression, (5) */
2340 check_transformational (gfc_expr
*e
)
2342 static const char * const trans_func_f95
[] = {
2343 "repeat", "reshape", "selected_int_kind",
2344 "selected_real_kind", "transfer", "trim", NULL
2347 static const char * const trans_func_f2003
[] = {
2348 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2349 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2350 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2351 "trim", "unpack", NULL
2356 const char *const *functions
;
2358 if (!e
->value
.function
.isym
2359 || !e
->value
.function
.isym
->transformational
)
2362 name
= e
->symtree
->n
.sym
->name
;
2364 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2365 ? trans_func_f2003
: trans_func_f95
;
2367 /* NULL() is dealt with below. */
2368 if (strcmp ("null", name
) == 0)
2371 for (i
= 0; functions
[i
]; i
++)
2372 if (strcmp (functions
[i
], name
) == 0)
2375 if (functions
[i
] == NULL
)
2377 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2378 "in an initialization expression", name
, &e
->where
);
2382 return check_init_expr_arguments (e
);
2386 /* F95, 7.1.6.1, Initialization expressions, (6)
2387 F2003, 7.1.7 Initialization expression, (6) */
2390 check_null (gfc_expr
*e
)
2392 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2395 return check_init_expr_arguments (e
);
2400 check_elemental (gfc_expr
*e
)
2402 if (!e
->value
.function
.isym
2403 || !e
->value
.function
.isym
->elemental
)
2406 if (e
->ts
.type
!= BT_INTEGER
2407 && e
->ts
.type
!= BT_CHARACTER
2408 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2409 "nonstandard initialization expression at %L",
2410 &e
->where
) == FAILURE
)
2413 return check_init_expr_arguments (e
);
2418 check_conversion (gfc_expr
*e
)
2420 if (!e
->value
.function
.isym
2421 || !e
->value
.function
.isym
->conversion
)
2424 return check_init_expr_arguments (e
);
2428 /* Verify that an expression is an initialization expression. A side
2429 effect is that the expression tree is reduced to a single constant
2430 node if all goes well. This would normally happen when the
2431 expression is constructed but function references are assumed to be
2432 intrinsics in the context of initialization expressions. If
2433 FAILURE is returned an error message has been generated. */
2436 gfc_check_init_expr (gfc_expr
*e
)
2444 switch (e
->expr_type
)
2447 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2449 t
= gfc_simplify_expr (e
, 0);
2457 gfc_intrinsic_sym
* isym
;
2460 sym
= e
->symtree
->n
.sym
;
2461 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2462 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2464 gfc_error ("Function '%s' in initialization expression at %L "
2465 "must be an intrinsic function",
2466 e
->symtree
->n
.sym
->name
, &e
->where
);
2470 if ((m
= check_conversion (e
)) == MATCH_NO
2471 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2472 && (m
= check_null (e
)) == MATCH_NO
2473 && (m
= check_transformational (e
)) == MATCH_NO
2474 && (m
= check_elemental (e
)) == MATCH_NO
)
2476 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2477 "in an initialization expression",
2478 e
->symtree
->n
.sym
->name
, &e
->where
);
2482 if (m
== MATCH_ERROR
)
2485 /* Try to scalarize an elemental intrinsic function that has an
2487 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2488 if (isym
&& isym
->elemental
2489 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2494 t
= gfc_simplify_expr (e
, 0);
2501 if (gfc_check_iter_variable (e
) == SUCCESS
)
2504 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2506 /* A PARAMETER shall not be used to define itself, i.e.
2507 REAL, PARAMETER :: x = transfer(0, x)
2509 if (!e
->symtree
->n
.sym
->value
)
2511 gfc_error("PARAMETER '%s' is used at %L before its definition "
2512 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2516 t
= simplify_parameter_variable (e
, 0);
2521 if (gfc_in_match_data ())
2526 if (e
->symtree
->n
.sym
->as
)
2528 switch (e
->symtree
->n
.sym
->as
->type
)
2530 case AS_ASSUMED_SIZE
:
2531 gfc_error ("Assumed size array '%s' at %L is not permitted "
2532 "in an initialization expression",
2533 e
->symtree
->n
.sym
->name
, &e
->where
);
2536 case AS_ASSUMED_SHAPE
:
2537 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2538 "in an initialization expression",
2539 e
->symtree
->n
.sym
->name
, &e
->where
);
2543 gfc_error ("Deferred array '%s' at %L is not permitted "
2544 "in an initialization expression",
2545 e
->symtree
->n
.sym
->name
, &e
->where
);
2549 gfc_error ("Array '%s' at %L is a variable, which does "
2550 "not reduce to a constant expression",
2551 e
->symtree
->n
.sym
->name
, &e
->where
);
2559 gfc_error ("Parameter '%s' at %L has not been declared or is "
2560 "a variable, which does not reduce to a constant "
2561 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2570 case EXPR_SUBSTRING
:
2571 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2575 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2577 t
= gfc_simplify_expr (e
, 0);
2581 case EXPR_STRUCTURE
:
2582 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2586 t
= check_alloc_comp_init (e
);
2590 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2597 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2601 t
= gfc_expand_constructor (e
, true);
2605 t
= gfc_check_constructor_type (e
);
2609 gfc_internal_error ("check_init_expr(): Unknown expression type");
2615 /* Reduces a general expression to an initialization expression (a constant).
2616 This used to be part of gfc_match_init_expr.
2617 Note that this function doesn't free the given expression on FAILURE. */
2620 gfc_reduce_init_expr (gfc_expr
*expr
)
2624 gfc_init_expr_flag
= true;
2625 t
= gfc_resolve_expr (expr
);
2627 t
= gfc_check_init_expr (expr
);
2628 gfc_init_expr_flag
= false;
2633 if (expr
->expr_type
== EXPR_ARRAY
)
2635 if (gfc_check_constructor_type (expr
) == FAILURE
)
2637 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2645 /* Match an initialization expression. We work by first matching an
2646 expression, then reducing it to a constant. */
2649 gfc_match_init_expr (gfc_expr
**result
)
2657 gfc_init_expr_flag
= true;
2659 m
= gfc_match_expr (&expr
);
2662 gfc_init_expr_flag
= false;
2666 t
= gfc_reduce_init_expr (expr
);
2669 gfc_free_expr (expr
);
2670 gfc_init_expr_flag
= false;
2675 gfc_init_expr_flag
= false;
2681 /* Given an actual argument list, test to see that each argument is a
2682 restricted expression and optionally if the expression type is
2683 integer or character. */
2686 restricted_args (gfc_actual_arglist
*a
)
2688 for (; a
; a
= a
->next
)
2690 if (check_restricted (a
->expr
) == FAILURE
)
2698 /************* Restricted/specification expressions *************/
2701 /* Make sure a non-intrinsic function is a specification function. */
2704 external_spec_function (gfc_expr
*e
)
2708 f
= e
->value
.function
.esym
;
2710 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2712 gfc_error ("Specification function '%s' at %L cannot be a statement "
2713 "function", f
->name
, &e
->where
);
2717 if (f
->attr
.proc
== PROC_INTERNAL
)
2719 gfc_error ("Specification function '%s' at %L cannot be an internal "
2720 "function", f
->name
, &e
->where
);
2724 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2726 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2731 if (f
->attr
.recursive
)
2733 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2734 f
->name
, &e
->where
);
2738 return restricted_args (e
->value
.function
.actual
);
2742 /* Check to see that a function reference to an intrinsic is a
2743 restricted expression. */
2746 restricted_intrinsic (gfc_expr
*e
)
2748 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2749 if (check_inquiry (e
, 0) == MATCH_YES
)
2752 return restricted_args (e
->value
.function
.actual
);
2756 /* Check the expressions of an actual arglist. Used by check_restricted. */
2759 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2761 for (; arg
; arg
= arg
->next
)
2762 if (checker (arg
->expr
) == FAILURE
)
2769 /* Check the subscription expressions of a reference chain with a checking
2770 function; used by check_restricted. */
2773 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2783 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2785 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2787 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2789 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2795 /* Nothing needed, just proceed to next reference. */
2799 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2801 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2810 return check_references (ref
->next
, checker
);
2814 /* Verify that an expression is a restricted expression. Like its
2815 cousin check_init_expr(), an error message is generated if we
2819 check_restricted (gfc_expr
*e
)
2827 switch (e
->expr_type
)
2830 t
= check_intrinsic_op (e
, check_restricted
);
2832 t
= gfc_simplify_expr (e
, 0);
2837 if (e
->value
.function
.esym
)
2839 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2841 t
= external_spec_function (e
);
2845 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2848 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2851 t
= restricted_intrinsic (e
);
2856 sym
= e
->symtree
->n
.sym
;
2859 /* If a dummy argument appears in a context that is valid for a
2860 restricted expression in an elemental procedure, it will have
2861 already been simplified away once we get here. Therefore we
2862 don't need to jump through hoops to distinguish valid from
2864 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2865 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2867 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2868 sym
->name
, &e
->where
);
2872 if (sym
->attr
.optional
)
2874 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2875 sym
->name
, &e
->where
);
2879 if (sym
->attr
.intent
== INTENT_OUT
)
2881 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2882 sym
->name
, &e
->where
);
2886 /* Check reference chain if any. */
2887 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2890 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2891 processed in resolve.c(resolve_formal_arglist). This is done so
2892 that host associated dummy array indices are accepted (PR23446).
2893 This mechanism also does the same for the specification expressions
2894 of array-valued functions. */
2896 || sym
->attr
.in_common
2897 || sym
->attr
.use_assoc
2899 || sym
->attr
.implied_index
2900 || sym
->attr
.flavor
== FL_PARAMETER
2901 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2902 || (sym
->ns
&& gfc_current_ns
->parent
2903 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2904 || (sym
->ns
->proc_name
!= NULL
2905 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2906 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2912 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2913 sym
->name
, &e
->where
);
2914 /* Prevent a repetition of the error. */
2923 case EXPR_SUBSTRING
:
2924 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2928 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2930 t
= gfc_simplify_expr (e
, 0);
2934 case EXPR_STRUCTURE
:
2935 t
= gfc_check_constructor (e
, check_restricted
);
2939 t
= gfc_check_constructor (e
, check_restricted
);
2943 gfc_internal_error ("check_restricted(): Unknown expression type");
2950 /* Check to see that an expression is a specification expression. If
2951 we return FAILURE, an error has been generated. */
2954 gfc_specification_expr (gfc_expr
*e
)
2956 gfc_component
*comp
;
2961 if (e
->ts
.type
!= BT_INTEGER
)
2963 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2964 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2968 if (e
->expr_type
== EXPR_FUNCTION
2969 && !e
->value
.function
.isym
2970 && !e
->value
.function
.esym
2971 && !gfc_pure (e
->symtree
->n
.sym
)
2972 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2973 || !comp
->attr
.pure
))
2975 gfc_error ("Function '%s' at %L must be PURE",
2976 e
->symtree
->n
.sym
->name
, &e
->where
);
2977 /* Prevent repeat error messages. */
2978 e
->symtree
->n
.sym
->attr
.pure
= 1;
2984 gfc_error ("Expression at %L must be scalar", &e
->where
);
2988 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2991 return check_restricted (e
);
2995 /************** Expression conformance checks. *************/
2997 /* Given two expressions, make sure that the arrays are conformable. */
3000 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3002 int op1_flag
, op2_flag
, d
;
3003 mpz_t op1_size
, op2_size
;
3009 if (op1
->rank
== 0 || op2
->rank
== 0)
3012 va_start (argp
, optype_msgid
);
3013 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3016 if (op1
->rank
!= op2
->rank
)
3018 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3019 op1
->rank
, op2
->rank
, &op1
->where
);
3025 for (d
= 0; d
< op1
->rank
; d
++)
3027 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3028 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3030 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3032 gfc_error ("Different shape for %s at %L on dimension %d "
3033 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3034 (int) mpz_get_si (op1_size
),
3035 (int) mpz_get_si (op2_size
));
3041 mpz_clear (op1_size
);
3043 mpz_clear (op2_size
);
3053 /* Given an assignable expression and an arbitrary expression, make
3054 sure that the assignment can take place. */
3057 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3063 sym
= lvalue
->symtree
->n
.sym
;
3065 /* See if this is the component or subcomponent of a pointer. */
3066 has_pointer
= sym
->attr
.pointer
;
3067 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3068 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3074 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3075 variable local to a function subprogram. Its existence begins when
3076 execution of the function is initiated and ends when execution of the
3077 function is terminated...
3078 Therefore, the left hand side is no longer a variable, when it is: */
3079 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3080 && !sym
->attr
.external
)
3085 /* (i) Use associated; */
3086 if (sym
->attr
.use_assoc
)
3089 /* (ii) The assignment is in the main program; or */
3090 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3093 /* (iii) A module or internal procedure... */
3094 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3095 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3096 && gfc_current_ns
->parent
3097 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3098 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3099 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3101 /* ... that is not a function... */
3102 if (!gfc_current_ns
->proc_name
->attr
.function
)
3105 /* ... or is not an entry and has a different name. */
3106 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3110 /* (iv) Host associated and not the function symbol or the
3111 parent result. This picks up sibling references, which
3112 cannot be entries. */
3113 if (!sym
->attr
.entry
3114 && sym
->ns
== gfc_current_ns
->parent
3115 && sym
!= gfc_current_ns
->proc_name
3116 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3121 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3126 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3128 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3129 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3133 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3135 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3140 if (rvalue
->expr_type
== EXPR_NULL
)
3142 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3143 && lvalue
->symtree
->n
.sym
->attr
.data
)
3147 gfc_error ("NULL appears on right-hand side in assignment at %L",
3153 /* This is possibly a typo: x = f() instead of x => f(). */
3154 if (gfc_option
.warn_surprising
3155 && rvalue
->expr_type
== EXPR_FUNCTION
3156 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3157 gfc_warning ("POINTER valued function appears on right-hand side of "
3158 "assignment at %L", &rvalue
->where
);
3160 /* Check size of array assignments. */
3161 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3162 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3165 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3166 && lvalue
->symtree
->n
.sym
->attr
.data
3167 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3168 "initialize non-integer variable '%s'",
3169 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3172 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3173 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3174 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3175 &rvalue
->where
) == FAILURE
)
3178 /* Handle the case of a BOZ literal on the RHS. */
3179 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3182 if (gfc_option
.warn_surprising
)
3183 gfc_warning ("BOZ literal at %L is bitwise transferred "
3184 "non-integer symbol '%s'", &rvalue
->where
,
3185 lvalue
->symtree
->n
.sym
->name
);
3186 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3188 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3190 if (rc
== ARITH_UNDERFLOW
)
3191 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3192 ". This check can be disabled with the option "
3193 "-fno-range-check", &rvalue
->where
);
3194 else if (rc
== ARITH_OVERFLOW
)
3195 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3196 ". This check can be disabled with the option "
3197 "-fno-range-check", &rvalue
->where
);
3198 else if (rc
== ARITH_NAN
)
3199 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3200 ". This check can be disabled with the option "
3201 "-fno-range-check", &rvalue
->where
);
3206 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3207 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3208 will warn anyway, so there is no need to to so here. */
3210 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3211 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3213 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3215 /* As a special bonus, don't warn about REAL rvalues which are not
3216 changed by the conversion if -Wconversion is specified. */
3217 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3219 /* Calculate the difference between the constant and the rounded
3220 value and check it against zero. */
3222 gfc_set_model_kind (lvalue
->ts
.kind
);
3224 gfc_set_model_kind (rvalue
->ts
.kind
);
3227 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3228 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3230 if (!mpfr_zero_p (diff
))
3231 gfc_warning ("Change of value in conversion from "
3232 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3233 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3239 gfc_warning ("Possible change of value in conversion from %s "
3240 "to %s at %L",gfc_typename (&rvalue
->ts
),
3241 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3244 else if (gfc_option
.warn_conversion_extra
3245 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3247 gfc_warning ("Conversion from %s to %s at %L",
3248 gfc_typename (&rvalue
->ts
),
3249 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3253 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3256 /* Only DATA Statements come here. */
3259 /* Numeric can be converted to any other numeric. And Hollerith can be
3260 converted to any other type. */
3261 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3262 || rvalue
->ts
.type
== BT_HOLLERITH
)
3265 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3268 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3269 "conversion of %s to %s", &lvalue
->where
,
3270 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3275 /* Assignment is the only case where character variables of different
3276 kind values can be converted into one another. */
3277 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3279 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3280 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3285 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3289 /* Check that a pointer assignment is OK. We first check lvalue, and
3290 we only check rvalue if it's not an assignment to NULL() or a
3291 NULLIFY statement. */
3294 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3296 symbol_attribute attr
;
3298 bool is_pure
, is_implicit_pure
, rank_remap
;
3301 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3302 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3304 gfc_error ("Pointer assignment target is not a POINTER at %L",
3309 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3310 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3311 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3313 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3314 "l-value since it is a procedure",
3315 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3319 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3322 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3324 if (ref
->type
== REF_COMPONENT
)
3325 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3327 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3331 if (ref
->u
.ar
.type
== AR_FULL
)
3334 if (ref
->u
.ar
.type
!= AR_SECTION
)
3336 gfc_error ("Expected bounds specification for '%s' at %L",
3337 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3341 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3342 "specification for '%s' in pointer assignment "
3343 "at %L", lvalue
->symtree
->n
.sym
->name
,
3344 &lvalue
->where
) == FAILURE
)
3347 /* When bounds are given, all lbounds are necessary and either all
3348 or none of the upper bounds; no strides are allowed. If the
3349 upper bounds are present, we may do rank remapping. */
3350 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3352 if (!ref
->u
.ar
.start
[dim
]
3353 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3355 gfc_error ("Lower bound has to be present at %L",
3359 if (ref
->u
.ar
.stride
[dim
])
3361 gfc_error ("Stride must not be present at %L",
3367 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3370 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3371 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3373 gfc_error ("Either all or none of the upper bounds"
3374 " must be specified at %L", &lvalue
->where
);
3382 is_pure
= gfc_pure (NULL
);
3383 is_implicit_pure
= gfc_implicit_pure (NULL
);
3385 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3386 kind, etc for lvalue and rvalue must match, and rvalue must be a
3387 pure variable if we're in a pure function. */
3388 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3391 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3392 if (lvalue
->expr_type
== EXPR_VARIABLE
3393 && gfc_is_coindexed (lvalue
))
3396 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3397 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3399 gfc_error ("Pointer object at %L shall not have a coindex",
3405 /* Checks on rvalue for procedure pointer assignments. */
3410 gfc_component
*comp
;
3413 attr
= gfc_expr_attr (rvalue
);
3414 if (!((rvalue
->expr_type
== EXPR_NULL
)
3415 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3416 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3417 || (rvalue
->expr_type
== EXPR_VARIABLE
3418 && attr
.flavor
== FL_PROCEDURE
)))
3420 gfc_error ("Invalid procedure pointer assignment at %L",
3426 gfc_error ("Abstract interface '%s' is invalid "
3427 "in procedure pointer assignment at %L",
3428 rvalue
->symtree
->name
, &rvalue
->where
);
3431 /* Check for F08:C729. */
3432 if (attr
.flavor
== FL_PROCEDURE
)
3434 if (attr
.proc
== PROC_ST_FUNCTION
)
3436 gfc_error ("Statement function '%s' is invalid "
3437 "in procedure pointer assignment at %L",
3438 rvalue
->symtree
->name
, &rvalue
->where
);
3441 if (attr
.proc
== PROC_INTERNAL
&&
3442 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3443 "invalid in procedure pointer assignment at %L",
3444 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3447 /* Check for F08:C730. */
3448 if (attr
.elemental
&& !attr
.intrinsic
)
3450 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3451 "in procedure pointer assigment at %L",
3452 rvalue
->symtree
->name
, &rvalue
->where
);
3456 /* Ensure that the calling convention is the same. As other attributes
3457 such as DLLEXPORT may differ, one explicitly only tests for the
3458 calling conventions. */
3459 if (rvalue
->expr_type
== EXPR_VARIABLE
3460 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3461 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3463 symbol_attribute calls
;
3466 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3467 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3468 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3470 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3471 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3473 gfc_error ("Mismatch in the procedure pointer assignment "
3474 "at %L: mismatch in the calling convention",
3480 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3481 s1
= comp
->ts
.interface
;
3483 s1
= lvalue
->symtree
->n
.sym
;
3485 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3487 s2
= comp
->ts
.interface
;
3490 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3492 s2
= rvalue
->symtree
->n
.sym
->result
;
3493 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3497 s2
= rvalue
->symtree
->n
.sym
;
3498 name
= rvalue
->symtree
->n
.sym
->name
;
3501 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3502 err
, sizeof(err
), NULL
, NULL
))
3504 gfc_error ("Interface mismatch in procedure pointer assignment "
3505 "at %L: %s", &rvalue
->where
, err
);
3512 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3514 gfc_error ("Different types in pointer assignment at %L; attempted "
3515 "assignment of %s to %s", &lvalue
->where
,
3516 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3520 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3522 gfc_error ("Different kind type parameters in pointer "
3523 "assignment at %L", &lvalue
->where
);
3527 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3529 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3533 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3534 /* Make sure the vtab is present. */
3535 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3537 /* Check rank remapping. */
3542 /* If this can be determined, check that the target must be at least as
3543 large as the pointer assigned to it is. */
3544 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3545 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3546 && mpz_cmp (rsize
, lsize
) < 0)
3548 gfc_error ("Rank remapping target is smaller than size of the"
3549 " pointer (%ld < %ld) at %L",
3550 mpz_get_si (rsize
), mpz_get_si (lsize
),
3555 /* The target must be either rank one or it must be simply contiguous
3556 and F2008 must be allowed. */
3557 if (rvalue
->rank
!= 1)
3559 if (!gfc_is_simply_contiguous (rvalue
, true))
3561 gfc_error ("Rank remapping target must be rank 1 or"
3562 " simply contiguous at %L", &rvalue
->where
);
3565 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Rank remapping"
3566 " target is not rank 1 at %L", &rvalue
->where
)
3572 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3573 if (rvalue
->expr_type
== EXPR_NULL
)
3576 if (lvalue
->ts
.type
== BT_CHARACTER
)
3578 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3583 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3584 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3586 attr
= gfc_expr_attr (rvalue
);
3588 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3590 gfc_error ("Target expression in pointer assignment "
3591 "at %L must deliver a pointer result",
3596 if (!attr
.target
&& !attr
.pointer
)
3598 gfc_error ("Pointer assignment target is neither TARGET "
3599 "nor POINTER at %L", &rvalue
->where
);
3603 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3605 gfc_error ("Bad target in pointer assignment in PURE "
3606 "procedure at %L", &rvalue
->where
);
3609 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3610 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3613 if (gfc_has_vector_index (rvalue
))
3615 gfc_error ("Pointer assignment with vector subscript "
3616 "on rhs at %L", &rvalue
->where
);
3620 if (attr
.is_protected
&& attr
.use_assoc
3621 && !(attr
.pointer
|| attr
.proc_pointer
))
3623 gfc_error ("Pointer assignment target has PROTECTED "
3624 "attribute at %L", &rvalue
->where
);
3628 /* F2008, C725. For PURE also C1283. */
3629 if (rvalue
->expr_type
== EXPR_VARIABLE
3630 && gfc_is_coindexed (rvalue
))
3633 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3634 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3636 gfc_error ("Data target at %L shall not have a coindex",
3646 /* Relative of gfc_check_assign() except that the lvalue is a single
3647 symbol. Used for initialization assignments. */
3650 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3655 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3657 lvalue
.expr_type
= EXPR_VARIABLE
;
3658 lvalue
.ts
= sym
->ts
;
3660 lvalue
.rank
= sym
->as
->rank
;
3661 lvalue
.symtree
= XCNEW (gfc_symtree
);
3662 lvalue
.symtree
->n
.sym
= sym
;
3663 lvalue
.where
= sym
->declared_at
;
3665 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3666 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
3667 && rvalue
->expr_type
== EXPR_NULL
))
3668 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3670 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3672 free (lvalue
.symtree
);
3677 if (sym
->attr
.pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3679 /* F08:C461. Additional checks for pointer initialization. */
3680 symbol_attribute attr
;
3681 attr
= gfc_expr_attr (rvalue
);
3682 if (attr
.allocatable
)
3684 gfc_error ("Pointer initialization target at %C "
3685 "must not be ALLOCATABLE ");
3688 if (!attr
.target
|| attr
.pointer
)
3690 gfc_error ("Pointer initialization target at %C "
3691 "must have the TARGET attribute");
3696 gfc_error ("Pointer initialization target at %C "
3697 "must have the SAVE attribute");
3702 if (sym
->attr
.proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3704 /* F08:C1220. Additional checks for procedure pointer initialization. */
3705 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3706 if (attr
.proc_pointer
)
3708 gfc_error ("Procedure pointer initialization target at %L "
3709 "may not be a procedure pointer", &rvalue
->where
);
3718 /* Check for default initializer; sym->value is not enough
3719 as it is also set for EXPR_NULL of allocatables. */
3722 gfc_has_default_initializer (gfc_symbol
*der
)
3726 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3727 for (c
= der
->components
; c
; c
= c
->next
)
3728 if (c
->ts
.type
== BT_DERIVED
)
3730 if (!c
->attr
.pointer
3731 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3733 if (c
->attr
.pointer
&& c
->initializer
)
3746 /* Get an expression for a default initializer. */
3749 gfc_default_initializer (gfc_typespec
*ts
)
3752 gfc_component
*comp
;
3754 /* See if we have a default initializer in this, but not in nested
3755 types (otherwise we could use gfc_has_default_initializer()). */
3756 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3757 if (comp
->initializer
|| comp
->attr
.allocatable
3758 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3764 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3765 &ts
->u
.derived
->declared_at
);
3768 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3770 gfc_constructor
*ctor
= gfc_constructor_get();
3772 if (comp
->initializer
)
3774 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3775 if ((comp
->ts
.type
!= comp
->initializer
->ts
.type
3776 || comp
->ts
.kind
!= comp
->initializer
->ts
.kind
)
3777 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
3778 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
3781 if (comp
->attr
.allocatable
3782 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3784 ctor
->expr
= gfc_get_expr ();
3785 ctor
->expr
->expr_type
= EXPR_NULL
;
3786 ctor
->expr
->ts
= comp
->ts
;
3789 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3796 /* Given a symbol, create an expression node with that symbol as a
3797 variable. If the symbol is array valued, setup a reference of the
3801 gfc_get_variable_expr (gfc_symtree
*var
)
3805 e
= gfc_get_expr ();
3806 e
->expr_type
= EXPR_VARIABLE
;
3808 e
->ts
= var
->n
.sym
->ts
;
3810 if ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
3811 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
3812 && CLASS_DATA (var
->n
.sym
)->as
))
3814 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
3815 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
3816 e
->ref
= gfc_get_ref ();
3817 e
->ref
->type
= REF_ARRAY
;
3818 e
->ref
->u
.ar
.type
= AR_FULL
;
3819 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
3820 ? CLASS_DATA (var
->n
.sym
)->as
3829 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3832 lval
= gfc_get_expr ();
3833 lval
->expr_type
= EXPR_VARIABLE
;
3834 lval
->where
= sym
->declared_at
;
3836 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3838 /* It will always be a full array. */
3839 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
3842 lval
->ref
= gfc_get_ref ();
3843 lval
->ref
->type
= REF_ARRAY
;
3844 lval
->ref
->u
.ar
.type
= AR_FULL
;
3845 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
3846 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
3847 lval
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
3848 ? CLASS_DATA (sym
)->as
: sym
->as
;
3855 /* Returns the array_spec of a full array expression. A NULL is
3856 returned otherwise. */
3858 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3863 if (expr
->rank
== 0)
3866 /* Follow any component references. */
3867 if (expr
->expr_type
== EXPR_VARIABLE
3868 || expr
->expr_type
== EXPR_CONSTANT
)
3870 as
= expr
->symtree
->n
.sym
->as
;
3871 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3876 as
= ref
->u
.c
.component
->as
;
3884 switch (ref
->u
.ar
.type
)
3907 /* General expression traversal function. */
3910 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3911 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3916 gfc_actual_arglist
*args
;
3923 if ((*func
) (expr
, sym
, &f
))
3926 if (expr
->ts
.type
== BT_CHARACTER
3928 && expr
->ts
.u
.cl
->length
3929 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3930 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3933 switch (expr
->expr_type
)
3938 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3940 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3948 case EXPR_SUBSTRING
:
3951 case EXPR_STRUCTURE
:
3953 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3954 c
; c
= gfc_constructor_next (c
))
3956 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3960 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3962 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3964 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3966 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3973 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3975 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3991 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3993 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3995 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3997 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4003 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4005 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4010 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4011 && ref
->u
.c
.component
->ts
.u
.cl
4012 && ref
->u
.c
.component
->ts
.u
.cl
->length
4013 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4015 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4019 if (ref
->u
.c
.component
->as
)
4020 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4021 + ref
->u
.c
.component
->as
->corank
; i
++)
4023 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4026 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4040 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4043 expr_set_symbols_referenced (gfc_expr
*expr
,
4044 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4045 int *f ATTRIBUTE_UNUSED
)
4047 if (expr
->expr_type
!= EXPR_VARIABLE
)
4049 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4054 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4056 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4060 /* Determine if an expression is a procedure pointer component. If yes, the
4061 argument 'comp' will point to the component (provided that 'comp' was
4065 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
4070 if (!expr
|| !expr
->ref
)
4077 if (ref
->type
== REF_COMPONENT
)
4079 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
4081 *comp
= ref
->u
.c
.component
;
4088 /* Walk an expression tree and check each variable encountered for being typed.
4089 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4090 mode as is a basic arithmetic expression using those; this is for things in
4093 INTEGER :: arr(n), n
4094 INTEGER :: arr(n + 1), n
4096 The namespace is needed for IMPLICIT typing. */
4098 static gfc_namespace
* check_typed_ns
;
4101 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4102 int* f ATTRIBUTE_UNUSED
)
4106 if (e
->expr_type
!= EXPR_VARIABLE
)
4109 gcc_assert (e
->symtree
);
4110 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4113 return (t
== FAILURE
);
4117 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4121 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4125 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4126 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4128 if (e
->expr_type
== EXPR_OP
)
4130 gfc_try t
= SUCCESS
;
4132 gcc_assert (e
->value
.op
.op1
);
4133 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4135 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4136 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4142 /* Otherwise, walk the expression and do it strictly. */
4143 check_typed_ns
= ns
;
4144 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4146 return error_found
? FAILURE
: SUCCESS
;
4150 /* Walk an expression tree and replace all dummy symbols by the corresponding
4151 symbol in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4152 statements. The boolean return value is required by gfc_traverse_expr. */
4155 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4157 if ((expr
->expr_type
== EXPR_VARIABLE
4158 || (expr
->expr_type
== EXPR_FUNCTION
4159 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4160 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
4161 && expr
->symtree
->n
.sym
->attr
.dummy
)
4163 gfc_symtree
*root
= sym
->formal_ns
? sym
->formal_ns
->sym_root
4164 : gfc_current_ns
->sym_root
;
4165 gfc_symtree
*stree
= gfc_find_symtree (root
, expr
->symtree
->n
.sym
->name
);
4167 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4168 expr
->symtree
= stree
;
4174 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
4176 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
4180 /* The following is analogous to 'replace_symbol', and needed for copying
4181 interfaces for procedure pointer components. The argument 'sym' must formally
4182 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4183 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4184 component in whose formal_ns the arguments have to be). */
4187 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4189 gfc_component
*comp
;
4190 comp
= (gfc_component
*)sym
;
4191 if ((expr
->expr_type
== EXPR_VARIABLE
4192 || (expr
->expr_type
== EXPR_FUNCTION
4193 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4194 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4197 gfc_namespace
*ns
= comp
->formal_ns
;
4198 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4199 the symtree rather than create a new one (and probably fail later). */
4200 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4201 expr
->symtree
->n
.sym
->name
);
4203 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4204 expr
->symtree
= stree
;
4210 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4212 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4217 gfc_ref_this_image (gfc_ref
*ref
)
4221 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4223 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4224 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4232 gfc_is_coindexed (gfc_expr
*e
)
4236 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4237 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4238 return !gfc_ref_this_image (ref
);
4244 /* Coarrays are variables with a corank but not being coindexed. However, also
4245 the following is a coarray: A subobject of a coarray is a coarray if it does
4246 not have any cosubscripts, vector subscripts, allocatable component
4247 selection, or pointer component selection. (F2008, 2.4.7) */
4250 gfc_is_coarray (gfc_expr
*e
)
4254 gfc_component
*comp
;
4259 if (e
->expr_type
!= EXPR_VARIABLE
)
4263 sym
= e
->symtree
->n
.sym
;
4265 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4266 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4268 coarray
= sym
->attr
.codimension
;
4270 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4274 comp
= ref
->u
.c
.component
;
4275 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4276 && (CLASS_DATA (comp
)->attr
.class_pointer
4277 || CLASS_DATA (comp
)->attr
.allocatable
))
4280 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4282 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4285 coarray
= comp
->attr
.codimension
;
4293 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4299 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4300 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4311 return coarray
&& !coindexed
;
4316 gfc_get_corank (gfc_expr
*e
)
4321 if (!gfc_is_coarray (e
))
4324 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4325 corank
= e
->ts
.u
.derived
->components
->as
4326 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4328 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4330 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4332 if (ref
->type
== REF_ARRAY
)
4333 corank
= ref
->u
.ar
.as
->corank
;
4334 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4341 /* Check whether the expression has an ultimate allocatable component.
4342 Being itself allocatable does not count. */
4344 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4346 gfc_ref
*ref
, *last
= NULL
;
4348 if (e
->expr_type
!= EXPR_VARIABLE
)
4351 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4352 if (ref
->type
== REF_COMPONENT
)
4355 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4356 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4357 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4358 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4362 if (e
->ts
.type
== BT_CLASS
)
4363 return CLASS_DATA (e
)->attr
.alloc_comp
;
4364 else if (e
->ts
.type
== BT_DERIVED
)
4365 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4371 /* Check whether the expression has an pointer component.
4372 Being itself a pointer does not count. */
4374 gfc_has_ultimate_pointer (gfc_expr
*e
)
4376 gfc_ref
*ref
, *last
= NULL
;
4378 if (e
->expr_type
!= EXPR_VARIABLE
)
4381 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4382 if (ref
->type
== REF_COMPONENT
)
4385 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4386 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4387 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4388 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4392 if (e
->ts
.type
== BT_CLASS
)
4393 return CLASS_DATA (e
)->attr
.pointer_comp
;
4394 else if (e
->ts
.type
== BT_DERIVED
)
4395 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4401 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4402 Note: A scalar is not regarded as "simply contiguous" by the standard.
4403 if bool is not strict, some further checks are done - for instance,
4404 a "(::1)" is accepted. */
4407 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4411 gfc_array_ref
*ar
= NULL
;
4412 gfc_ref
*ref
, *part_ref
= NULL
;
4415 if (expr
->expr_type
== EXPR_FUNCTION
)
4416 return expr
->value
.function
.esym
4417 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4418 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4421 if (expr
->rank
== 0)
4424 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4427 return false; /* Array shall be last part-ref. */
4429 if (ref
->type
== REF_COMPONENT
)
4431 else if (ref
->type
== REF_SUBSTRING
)
4433 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4437 sym
= expr
->symtree
->n
.sym
;
4438 if (expr
->ts
.type
!= BT_CLASS
4440 && !part_ref
->u
.c
.component
->attr
.contiguous
4441 && part_ref
->u
.c
.component
->attr
.pointer
)
4443 && !sym
->attr
.contiguous
4444 && (sym
->attr
.pointer
4445 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
4448 if (!ar
|| ar
->type
== AR_FULL
)
4451 gcc_assert (ar
->type
== AR_SECTION
);
4453 /* Check for simply contiguous array */
4455 for (i
= 0; i
< ar
->dimen
; i
++)
4457 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4460 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4466 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4469 /* If the previous section was not contiguous, that's an error,
4470 unless we have effective only one element and checking is not
4472 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4473 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4474 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4475 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4476 ar
->end
[i
]->value
.integer
) != 0))
4479 /* Following the standard, "(::1)" or - if known at compile time -
4480 "(lbound:ubound)" are not simply contiguous; if strict
4481 is false, they are regarded as simply contiguous. */
4482 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4483 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4484 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4488 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4489 || !ar
->as
->lower
[i
]
4490 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4491 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4492 ar
->as
->lower
[i
]->value
.integer
) != 0))
4496 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4497 || !ar
->as
->upper
[i
]
4498 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4499 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4500 ar
->as
->upper
[i
]->value
.integer
) != 0))
4508 /* Build call to an intrinsic procedure. The number of arguments has to be
4509 passed (rather than ending the list with a NULL value) because we may
4510 want to add arguments but with a NULL-expression. */
4513 gfc_build_intrinsic_call (const char* name
, locus where
, unsigned numarg
, ...)
4516 gfc_actual_arglist
* atail
;
4517 gfc_intrinsic_sym
* isym
;
4521 isym
= gfc_find_function (name
);
4524 result
= gfc_get_expr ();
4525 result
->expr_type
= EXPR_FUNCTION
;
4526 result
->ts
= isym
->ts
;
4527 result
->where
= where
;
4528 result
->value
.function
.name
= name
;
4529 result
->value
.function
.isym
= isym
;
4531 result
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4532 gcc_assert (result
->symtree
4533 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
4534 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
4536 va_start (ap
, numarg
);
4538 for (i
= 0; i
< numarg
; ++i
)
4542 atail
->next
= gfc_get_actual_arglist ();
4543 atail
= atail
->next
;
4546 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4548 atail
->expr
= va_arg (ap
, gfc_expr
*);
4556 /* Check if an expression may appear in a variable definition context
4557 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4558 This is called from the various places when resolving
4559 the pieces that make up such a context.
4561 Optionally, a possible error message can be suppressed if context is NULL
4562 and just the return status (SUCCESS / FAILURE) be requested. */
4565 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4566 const char* context
)
4568 gfc_symbol
* sym
= NULL
;
4570 bool check_intentin
;
4572 symbol_attribute attr
;
4575 if (e
->expr_type
== EXPR_VARIABLE
)
4577 gcc_assert (e
->symtree
);
4578 sym
= e
->symtree
->n
.sym
;
4580 else if (e
->expr_type
== EXPR_FUNCTION
)
4582 gcc_assert (e
->symtree
);
4583 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4586 attr
= gfc_expr_attr (e
);
4587 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4589 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4592 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4593 " context (%s) at %L", context
, &e
->where
);
4597 else if (e
->expr_type
!= EXPR_VARIABLE
)
4600 gfc_error ("Non-variable expression in variable definition context (%s)"
4601 " at %L", context
, &e
->where
);
4605 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4608 gfc_error ("Named constant '%s' in variable definition context (%s)"
4609 " at %L", sym
->name
, context
, &e
->where
);
4612 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4613 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4614 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4617 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4618 " a variable", sym
->name
, context
, &e
->where
);
4622 /* Find out whether the expr is a pointer; this also means following
4623 component references to the last one. */
4624 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4625 if (pointer
&& !is_pointer
)
4628 gfc_error ("Non-POINTER in pointer association context (%s)"
4629 " at %L", context
, &e
->where
);
4636 || (e
->ts
.type
== BT_DERIVED
4637 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4638 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4641 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4642 context
, &e
->where
);
4646 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
4647 component of sub-component of a pointer; we need to distinguish
4648 assignment to a pointer component from pointer-assignment to a pointer
4649 component. Note that (normal) assignment to procedure pointers is not
4651 check_intentin
= true;
4652 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4653 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4654 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4656 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4657 check_intentin
= false;
4658 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4660 ptr_component
= true;
4662 check_intentin
= false;
4665 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4667 if (pointer
&& is_pointer
)
4670 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4671 " association context (%s) at %L",
4672 sym
->name
, context
, &e
->where
);
4675 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
4678 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4679 " definition context (%s) at %L",
4680 sym
->name
, context
, &e
->where
);
4685 /* PROTECTED and use-associated. */
4686 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4688 if (pointer
&& is_pointer
)
4691 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4692 " pointer association context (%s) at %L",
4693 sym
->name
, context
, &e
->where
);
4696 if (!pointer
&& !is_pointer
)
4699 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4700 " variable definition context (%s) at %L",
4701 sym
->name
, context
, &e
->where
);
4706 /* Variable not assignable from a PURE procedure but appears in
4707 variable definition context. */
4708 if (!pointer
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4711 gfc_error ("Variable '%s' can not appear in a variable definition"
4712 " context (%s) at %L in PURE procedure",
4713 sym
->name
, context
, &e
->where
);
4717 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
4718 && gfc_impure_variable (sym
))
4723 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4725 sym
= ns
->proc_name
;
4728 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4730 sym
->attr
.implicit_pure
= 0;
4735 /* Check variable definition context for associate-names. */
4736 if (!pointer
&& sym
->assoc
)
4739 gfc_association_list
* assoc
;
4741 gcc_assert (sym
->assoc
->target
);
4743 /* If this is a SELECT TYPE temporary (the association is used internally
4744 for SELECT TYPE), silently go over to the target. */
4745 if (sym
->attr
.select_type_temporary
)
4747 gfc_expr
* t
= sym
->assoc
->target
;
4749 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4750 name
= t
->symtree
->name
;
4752 if (t
->symtree
->n
.sym
->assoc
)
4753 assoc
= t
->symtree
->n
.sym
->assoc
;
4762 gcc_assert (name
&& assoc
);
4764 /* Is association to a valid variable? */
4765 if (!assoc
->variable
)
4769 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4770 gfc_error ("'%s' at %L associated to vector-indexed target can"
4771 " not be used in a variable definition context (%s)",
4772 name
, &e
->where
, context
);
4774 gfc_error ("'%s' at %L associated to expression can"
4775 " not be used in a variable definition context (%s)",
4776 name
, &e
->where
, context
);
4781 /* Target must be allowed to appear in a variable definition context. */
4782 if (gfc_check_vardef_context (assoc
->target
, pointer
, false, NULL
)
4786 gfc_error ("Associate-name '%s' can not appear in a variable"
4787 " definition context (%s) at %L because its target"
4788 " at %L can not, either",
4789 name
, context
, &e
->where
,
4790 &assoc
->target
->where
);