1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2021 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #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 "
154 e
->expr_type
= EXPR_CONSTANT
;
162 mpz_init (e
->value
.integer
);
166 gfc_set_model_kind (kind
);
167 mpfr_init (e
->value
.real
);
171 gfc_set_model_kind (kind
);
172 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
183 /* Get a new expression node that is an string constant.
184 If no string is passed, a string of len is allocated,
185 blanked and null-terminated. */
188 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, gfc_charlen_t len
)
195 dest
= gfc_get_wide_string (len
+ 1);
196 gfc_wide_memset (dest
, ' ', len
);
200 dest
= gfc_char_to_widechar (src
);
202 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
203 where
? where
: &gfc_current_locus
);
204 e
->value
.character
.string
= dest
;
205 e
->value
.character
.length
= len
;
211 /* Get a new expression node that is an integer constant. */
214 gfc_get_int_expr (int kind
, locus
*where
, HOST_WIDE_INT value
)
217 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
218 where
? where
: &gfc_current_locus
);
220 const wide_int w
= wi::shwi (value
, kind
* BITS_PER_UNIT
);
221 wi::to_mpz (w
, p
->value
.integer
, SIGNED
);
227 /* Get a new expression node that is a logical constant. */
230 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
233 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
234 where
? where
: &gfc_current_locus
);
236 p
->value
.logical
= value
;
243 gfc_get_iokind_expr (locus
*where
, io_kind k
)
247 /* Set the types to something compatible with iokind. This is needed to
248 get through gfc_free_expr later since iokind really has no Basic Type,
252 e
->expr_type
= EXPR_CONSTANT
;
253 e
->ts
.type
= BT_LOGICAL
;
261 /* Given an expression pointer, return a copy of the expression. This
262 subroutine is recursive. */
265 gfc_copy_expr (gfc_expr
*p
)
277 switch (q
->expr_type
)
280 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
281 q
->value
.character
.string
= s
;
282 memcpy (s
, p
->value
.character
.string
,
283 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
287 /* Copy target representation, if it exists. */
288 if (p
->representation
.string
)
290 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
291 q
->representation
.string
= c
;
292 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
295 /* Copy the values of any pointer components of p->value. */
299 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
303 gfc_set_model_kind (q
->ts
.kind
);
304 mpfr_init (q
->value
.real
);
305 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
309 gfc_set_model_kind (q
->ts
.kind
);
310 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
311 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
315 if (p
->representation
.string
)
316 q
->value
.character
.string
317 = gfc_char_to_widechar (q
->representation
.string
);
320 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
321 q
->value
.character
.string
= s
;
323 /* This is the case for the C_NULL_CHAR named constant. */
324 if (p
->value
.character
.length
== 0
325 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
328 /* Need to set the length to 1 to make sure the NUL
329 terminator is copied. */
330 q
->value
.character
.length
= 1;
333 memcpy (s
, p
->value
.character
.string
,
334 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
343 break; /* Already done. */
346 q
->boz
.len
= p
->boz
.len
;
347 q
->boz
.rdx
= p
->boz
.rdx
;
348 q
->boz
.str
= XCNEWVEC (char, q
->boz
.len
+ 1);
349 strncpy (q
->boz
.str
, p
->boz
.str
, p
->boz
.len
);
354 /* Should never be reached. */
356 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
363 switch (q
->value
.op
.op
)
366 case INTRINSIC_PARENTHESES
:
367 case INTRINSIC_UPLUS
:
368 case INTRINSIC_UMINUS
:
369 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
372 default: /* Binary operators. */
373 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
374 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
381 q
->value
.function
.actual
=
382 gfc_copy_actual_arglist (p
->value
.function
.actual
);
387 q
->value
.compcall
.actual
=
388 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
389 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
394 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
405 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
407 q
->ref
= gfc_copy_ref (p
->ref
);
410 q
->param_list
= gfc_copy_actual_arglist (p
->param_list
);
417 gfc_clear_shape (mpz_t
*shape
, int rank
)
421 for (i
= 0; i
< rank
; i
++)
422 mpz_clear (shape
[i
]);
427 gfc_free_shape (mpz_t
**shape
, int rank
)
432 gfc_clear_shape (*shape
, rank
);
438 /* Workhorse function for gfc_free_expr() that frees everything
439 beneath an expression node, but not the node itself. This is
440 useful when we want to simplify a node and replace it with
441 something else or the expression node belongs to another structure. */
444 free_expr0 (gfc_expr
*e
)
446 switch (e
->expr_type
)
449 /* Free any parts of the value that need freeing. */
453 mpz_clear (e
->value
.integer
);
457 mpfr_clear (e
->value
.real
);
461 free (e
->value
.character
.string
);
465 mpc_clear (e
->value
.complex);
472 /* Free the representation. */
473 free (e
->representation
.string
);
478 if (e
->value
.op
.op1
!= NULL
)
479 gfc_free_expr (e
->value
.op
.op1
);
480 if (e
->value
.op
.op2
!= NULL
)
481 gfc_free_expr (e
->value
.op
.op2
);
485 gfc_free_actual_arglist (e
->value
.function
.actual
);
490 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
498 gfc_constructor_free (e
->value
.constructor
);
502 free (e
->value
.character
.string
);
509 gfc_internal_error ("free_expr0(): Bad expr type");
512 /* Free a shape array. */
513 gfc_free_shape (&e
->shape
, e
->rank
);
515 gfc_free_ref_list (e
->ref
);
517 gfc_free_actual_arglist (e
->param_list
);
519 memset (e
, '\0', sizeof (gfc_expr
));
523 /* Free an expression node and everything beneath it. */
526 gfc_free_expr (gfc_expr
*e
)
535 /* Free an argument list and everything below it. */
538 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
540 gfc_actual_arglist
*a2
;
546 gfc_free_expr (a1
->expr
);
553 /* Copy an arglist structure and all of the arguments. */
556 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
558 gfc_actual_arglist
*head
, *tail
, *new_arg
;
562 for (; p
; p
= p
->next
)
564 new_arg
= gfc_get_actual_arglist ();
567 new_arg
->expr
= gfc_copy_expr (p
->expr
);
568 new_arg
->next
= NULL
;
573 tail
->next
= new_arg
;
582 /* Free a list of reference structures. */
585 gfc_free_ref_list (gfc_ref
*p
)
597 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
599 gfc_free_expr (p
->u
.ar
.start
[i
]);
600 gfc_free_expr (p
->u
.ar
.end
[i
]);
601 gfc_free_expr (p
->u
.ar
.stride
[i
]);
607 gfc_free_expr (p
->u
.ss
.start
);
608 gfc_free_expr (p
->u
.ss
.end
);
621 /* Graft the *src expression onto the *dest subexpression. */
624 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
632 /* Try to extract an integer constant from the passed expression node.
633 Return true if some error occurred, false on success. If REPORT_ERROR
634 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
635 for negative using gfc_error_now. */
638 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
642 /* A KIND component is a parameter too. The expression for it
643 is stored in the initializer and should be consistent with
645 if (gfc_expr_attr(expr
).pdt_kind
)
647 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
649 if (ref
->u
.c
.component
->attr
.pdt_kind
)
650 expr
= ref
->u
.c
.component
->initializer
;
654 if (expr
->expr_type
!= EXPR_CONSTANT
)
656 if (report_error
> 0)
657 gfc_error ("Constant expression required at %C");
658 else if (report_error
< 0)
659 gfc_error_now ("Constant expression required at %C");
663 if (expr
->ts
.type
!= BT_INTEGER
)
665 if (report_error
> 0)
666 gfc_error ("Integer expression required at %C");
667 else if (report_error
< 0)
668 gfc_error_now ("Integer expression required at %C");
672 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
673 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
675 if (report_error
> 0)
676 gfc_error ("Integer value too large in expression at %C");
677 else if (report_error
< 0)
678 gfc_error_now ("Integer value too large in expression at %C");
682 *result
= (int) mpz_get_si (expr
->value
.integer
);
688 /* Same as gfc_extract_int, but use a HWI. */
691 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
, int report_error
)
695 /* A KIND component is a parameter too. The expression for it is
696 stored in the initializer and should be consistent with the tests
698 if (gfc_expr_attr(expr
).pdt_kind
)
700 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
702 if (ref
->u
.c
.component
->attr
.pdt_kind
)
703 expr
= ref
->u
.c
.component
->initializer
;
707 if (expr
->expr_type
!= EXPR_CONSTANT
)
709 if (report_error
> 0)
710 gfc_error ("Constant expression required at %C");
711 else if (report_error
< 0)
712 gfc_error_now ("Constant expression required at %C");
716 if (expr
->ts
.type
!= BT_INTEGER
)
718 if (report_error
> 0)
719 gfc_error ("Integer expression required at %C");
720 else if (report_error
< 0)
721 gfc_error_now ("Integer expression required at %C");
725 /* Use long_long_integer_type_node to determine when to saturate. */
726 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
727 expr
->value
.integer
, false);
729 if (!wi::fits_shwi_p (val
))
731 if (report_error
> 0)
732 gfc_error ("Integer value too large in expression at %C");
733 else if (report_error
< 0)
734 gfc_error_now ("Integer value too large in expression at %C");
738 *result
= val
.to_shwi ();
744 /* Recursively copy a list of reference structures. */
747 gfc_copy_ref (gfc_ref
*src
)
755 dest
= gfc_get_ref ();
756 dest
->type
= src
->type
;
761 ar
= gfc_copy_array_ref (&src
->u
.ar
);
767 dest
->u
.c
= src
->u
.c
;
771 dest
->u
.i
= src
->u
.i
;
775 dest
->u
.ss
= src
->u
.ss
;
776 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
777 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
781 dest
->next
= gfc_copy_ref (src
->next
);
787 /* Detect whether an expression has any vector index array references. */
790 gfc_has_vector_index (gfc_expr
*e
)
794 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
795 if (ref
->type
== REF_ARRAY
)
796 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
797 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
803 /* Copy a shape array. */
806 gfc_copy_shape (mpz_t
*shape
, int rank
)
814 new_shape
= gfc_get_shape (rank
);
816 for (n
= 0; n
< rank
; n
++)
817 mpz_init_set (new_shape
[n
], shape
[n
]);
823 /* Copy a shape array excluding dimension N, where N is an integer
824 constant expression. Dimensions are numbered in Fortran style --
827 So, if the original shape array contains R elements
828 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
829 the result contains R-1 elements:
830 { s1 ... sN-1 sN+1 ... sR-1}
832 If anything goes wrong -- N is not a constant, its value is out
833 of range -- or anything else, just returns NULL. */
836 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
838 mpz_t
*new_shape
, *s
;
844 || dim
->expr_type
!= EXPR_CONSTANT
845 || dim
->ts
.type
!= BT_INTEGER
)
848 n
= mpz_get_si (dim
->value
.integer
);
849 n
--; /* Convert to zero based index. */
850 if (n
< 0 || n
>= rank
)
853 s
= new_shape
= gfc_get_shape (rank
- 1);
855 for (i
= 0; i
< rank
; i
++)
859 mpz_init_set (*s
, shape
[i
]);
867 /* Return the maximum kind of two expressions. In general, higher
868 kind numbers mean more precision for numeric types. */
871 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
873 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
877 /* Returns nonzero if the type is numeric, zero otherwise. */
880 numeric_type (bt type
)
882 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
886 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
889 gfc_numeric_ts (gfc_typespec
*ts
)
891 return numeric_type (ts
->type
);
895 /* Return an expression node with an optional argument list attached.
896 A variable number of gfc_expr pointers are strung together in an
897 argument list with a NULL pointer terminating the list. */
900 gfc_build_conversion (gfc_expr
*e
)
905 p
->expr_type
= EXPR_FUNCTION
;
907 p
->value
.function
.actual
= gfc_get_actual_arglist ();
908 p
->value
.function
.actual
->expr
= e
;
914 /* Given an expression node with some sort of numeric binary
915 expression, insert type conversions required to make the operands
916 have the same type. Conversion warnings are disabled if wconversion
919 The exception is that the operands of an exponential don't have to
920 have the same type. If possible, the base is promoted to the type
921 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
922 1.0**2 stays as it is. */
925 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
929 op1
= e
->value
.op
.op1
;
930 op2
= e
->value
.op
.op2
;
932 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
934 gfc_clear_ts (&e
->ts
);
938 /* Kind conversions of same type. */
939 if (op1
->ts
.type
== op2
->ts
.type
)
941 if (op1
->ts
.kind
== op2
->ts
.kind
)
943 /* No type conversions. */
948 if (op1
->ts
.kind
> op2
->ts
.kind
)
949 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
951 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
957 /* Integer combined with real or complex. */
958 if (op2
->ts
.type
== BT_INTEGER
)
962 /* Special case for ** operator. */
963 if (e
->value
.op
.op
== INTRINSIC_POWER
)
966 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
970 if (op1
->ts
.type
== BT_INTEGER
)
973 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
977 /* Real combined with complex. */
978 e
->ts
.type
= BT_COMPLEX
;
979 if (op1
->ts
.kind
> op2
->ts
.kind
)
980 e
->ts
.kind
= op1
->ts
.kind
;
982 e
->ts
.kind
= op2
->ts
.kind
;
983 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
984 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
985 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
986 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
993 /* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in
994 constant expressions, except TRANSFER (c.f. item (8)), which would need
995 separate treatment. */
998 is_non_constant_intrinsic (gfc_expr
*e
)
1000 if (e
->expr_type
== EXPR_FUNCTION
1001 && e
->value
.function
.isym
)
1003 switch (e
->value
.function
.isym
->id
)
1005 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
1006 case GFC_ISYM_GET_TEAM
:
1008 case GFC_ISYM_NUM_IMAGES
:
1009 case GFC_ISYM_TEAM_NUMBER
:
1010 case GFC_ISYM_THIS_IMAGE
:
1021 /* Determine if an expression is constant in the sense of F08:7.1.12.
1022 * This function expects that the expression has already been simplified. */
1025 gfc_is_constant_expr (gfc_expr
*e
)
1028 gfc_actual_arglist
*arg
;
1033 switch (e
->expr_type
)
1036 return (gfc_is_constant_expr (e
->value
.op
.op1
)
1037 && (e
->value
.op
.op2
== NULL
1038 || gfc_is_constant_expr (e
->value
.op
.op2
)));
1041 /* The only context in which this can occur is in a parameterized
1042 derived type declaration, so returning true is OK. */
1043 if (e
->symtree
->n
.sym
->attr
.pdt_len
1044 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1051 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1052 || e
->value
.function
.isym
);
1054 /* Check for intrinsics excluded in constant expressions. */
1055 if (e
->value
.function
.isym
&& is_non_constant_intrinsic (e
))
1058 /* Call to intrinsic with at least one argument. */
1059 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1061 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1062 if (!gfc_is_constant_expr (arg
->expr
))
1066 if (e
->value
.function
.isym
1067 && (e
->value
.function
.isym
->elemental
1068 || e
->value
.function
.isym
->pure
1069 || e
->value
.function
.isym
->inquiry
1070 || e
->value
.function
.isym
->transformational
))
1079 case EXPR_SUBSTRING
:
1080 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1081 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1084 case EXPR_STRUCTURE
:
1085 c
= gfc_constructor_first (e
->value
.constructor
);
1086 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1087 return gfc_constant_ac (e
);
1089 for (; c
; c
= gfc_constructor_next (c
))
1090 if (!gfc_is_constant_expr (c
->expr
))
1097 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1103 /* Is true if the expression or symbol is a passed CFI descriptor. */
1105 is_CFI_desc (gfc_symbol
*sym
, gfc_expr
*e
)
1108 && e
&& e
->expr_type
== EXPR_VARIABLE
)
1109 sym
= e
->symtree
->n
.sym
;
1111 if (sym
&& sym
->attr
.dummy
1112 && sym
->ns
->proc_name
->attr
.is_bind_c
1113 && (sym
->attr
.pointer
1114 || sym
->attr
.allocatable
1115 || (sym
->attr
.dimension
1116 && (sym
->as
->type
== AS_ASSUMED_SHAPE
1117 || sym
->as
->type
== AS_ASSUMED_RANK
))
1118 || (sym
->ts
.type
== BT_CHARACTER
1119 && (!sym
->ts
.u
.cl
|| !sym
->ts
.u
.cl
->length
))))
1126 /* Is true if an array reference is followed by a component or substring
1129 is_subref_array (gfc_expr
* e
)
1135 if (e
->expr_type
!= EXPR_VARIABLE
)
1138 sym
= e
->symtree
->n
.sym
;
1140 if (sym
->attr
.subref_array_pointer
)
1145 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1147 /* If we haven't seen the array reference and this is an intrinsic,
1148 what follows cannot be a subreference array, unless there is a
1149 substring reference. */
1150 if (!seen_array
&& ref
->type
== REF_COMPONENT
1151 && ref
->u
.c
.component
->ts
.type
!= BT_CHARACTER
1152 && ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1153 && !gfc_bt_struct (ref
->u
.c
.component
->ts
.type
))
1156 if (ref
->type
== REF_ARRAY
1157 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1161 && ref
->type
!= REF_ARRAY
)
1165 if (sym
->ts
.type
== BT_CLASS
1167 && CLASS_DATA (sym
)->attr
.dimension
1168 && CLASS_DATA (sym
)->attr
.class_pointer
)
1175 /* Try to collapse intrinsic expressions. */
1178 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1180 gfc_intrinsic_op op
;
1181 gfc_expr
*op1
, *op2
, *result
;
1183 if (p
->value
.op
.op
== INTRINSIC_USER
)
1186 op1
= p
->value
.op
.op1
;
1187 op2
= p
->value
.op
.op2
;
1188 op
= p
->value
.op
.op
;
1190 if (!gfc_simplify_expr (op1
, type
))
1192 if (!gfc_simplify_expr (op2
, type
))
1195 if (!gfc_is_constant_expr (op1
)
1196 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1200 p
->value
.op
.op1
= NULL
;
1201 p
->value
.op
.op2
= NULL
;
1205 case INTRINSIC_PARENTHESES
:
1206 result
= gfc_parentheses (op1
);
1209 case INTRINSIC_UPLUS
:
1210 result
= gfc_uplus (op1
);
1213 case INTRINSIC_UMINUS
:
1214 result
= gfc_uminus (op1
);
1217 case INTRINSIC_PLUS
:
1218 result
= gfc_add (op1
, op2
);
1221 case INTRINSIC_MINUS
:
1222 result
= gfc_subtract (op1
, op2
);
1225 case INTRINSIC_TIMES
:
1226 result
= gfc_multiply (op1
, op2
);
1229 case INTRINSIC_DIVIDE
:
1230 result
= gfc_divide (op1
, op2
);
1233 case INTRINSIC_POWER
:
1234 result
= gfc_power (op1
, op2
);
1237 case INTRINSIC_CONCAT
:
1238 result
= gfc_concat (op1
, op2
);
1242 case INTRINSIC_EQ_OS
:
1243 result
= gfc_eq (op1
, op2
, op
);
1247 case INTRINSIC_NE_OS
:
1248 result
= gfc_ne (op1
, op2
, op
);
1252 case INTRINSIC_GT_OS
:
1253 result
= gfc_gt (op1
, op2
, op
);
1257 case INTRINSIC_GE_OS
:
1258 result
= gfc_ge (op1
, op2
, op
);
1262 case INTRINSIC_LT_OS
:
1263 result
= gfc_lt (op1
, op2
, op
);
1267 case INTRINSIC_LE_OS
:
1268 result
= gfc_le (op1
, op2
, op
);
1272 result
= gfc_not (op1
);
1276 result
= gfc_and (op1
, op2
);
1280 result
= gfc_or (op1
, op2
);
1284 result
= gfc_eqv (op1
, op2
);
1287 case INTRINSIC_NEQV
:
1288 result
= gfc_neqv (op1
, op2
);
1292 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1297 gfc_free_expr (op1
);
1298 gfc_free_expr (op2
);
1302 result
->rank
= p
->rank
;
1303 result
->where
= p
->where
;
1304 gfc_replace_expr (p
, result
);
1310 /* Subroutine to simplify constructor expressions. Mutually recursive
1311 with gfc_simplify_expr(). */
1314 simplify_constructor (gfc_constructor_base base
, int type
)
1319 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1322 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1323 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1324 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1329 /* Try and simplify a copy. Replace the original if successful
1330 but keep going through the constructor at all costs. Not
1331 doing so can make a dog's dinner of complicated things. */
1332 p
= gfc_copy_expr (c
->expr
);
1334 if (!gfc_simplify_expr (p
, type
))
1340 gfc_replace_expr (c
->expr
, p
);
1348 /* Pull a single array element out of an array constructor. */
1351 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1352 gfc_constructor
**rval
)
1354 unsigned long nelemen
;
1360 gfc_constructor
*cons
;
1367 mpz_init_set_ui (offset
, 0);
1370 mpz_init_set_ui (span
, 1);
1371 for (i
= 0; i
< ar
->dimen
; i
++)
1373 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1374 || !gfc_reduce_init_expr (ar
->as
->upper
[i
])
1375 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1376 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1384 if (e
->expr_type
!= EXPR_CONSTANT
)
1390 /* Check the bounds. */
1391 if ((ar
->as
->upper
[i
]
1392 && mpz_cmp (e
->value
.integer
,
1393 ar
->as
->upper
[i
]->value
.integer
) > 0)
1394 || (mpz_cmp (e
->value
.integer
,
1395 ar
->as
->lower
[i
]->value
.integer
) < 0))
1397 gfc_error ("Index in dimension %d is out of bounds "
1398 "at %L", i
+ 1, &ar
->c_where
[i
]);
1404 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1405 mpz_mul (delta
, delta
, span
);
1406 mpz_add (offset
, offset
, delta
);
1408 mpz_set_ui (tmp
, 1);
1409 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1410 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1411 mpz_mul (span
, span
, tmp
);
1414 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1415 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1434 /* Find a component of a structure constructor. */
1436 static gfc_constructor
*
1437 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1439 gfc_component
*pick
= ref
->u
.c
.component
;
1440 gfc_constructor
*c
= gfc_constructor_first (base
);
1442 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1443 int ext
= dt
->attr
.extension
;
1445 /* For extended types, check if the desired component is in one of the
1447 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1448 pick
->name
, true, true, NULL
))
1450 dt
= dt
->components
->ts
.u
.derived
;
1451 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1455 gfc_component
*comp
= dt
->components
;
1456 while (comp
!= pick
)
1459 c
= gfc_constructor_next (c
);
1466 /* Replace an expression with the contents of a constructor, removing
1467 the subobject reference in the process. */
1470 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1480 e
= gfc_copy_expr (p
);
1481 e
->ref
= p
->ref
->next
;
1482 p
->ref
->next
= NULL
;
1483 gfc_replace_expr (p
, e
);
1487 /* Pull an array section out of an array constructor. */
1490 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1497 long unsigned one
= 1;
1499 mpz_t start
[GFC_MAX_DIMENSIONS
];
1500 mpz_t end
[GFC_MAX_DIMENSIONS
];
1501 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1502 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1503 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1508 gfc_constructor_base base
;
1509 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1519 base
= expr
->value
.constructor
;
1520 expr
->value
.constructor
= NULL
;
1522 rank
= ref
->u
.ar
.as
->rank
;
1524 if (expr
->shape
== NULL
)
1525 expr
->shape
= gfc_get_shape (rank
);
1527 mpz_init_set_ui (delta_mpz
, one
);
1528 mpz_init_set_ui (nelts
, one
);
1531 /* Do the initialization now, so that we can cleanup without
1532 keeping track of where we were. */
1533 for (d
= 0; d
< rank
; d
++)
1535 mpz_init (delta
[d
]);
1536 mpz_init (start
[d
]);
1539 mpz_init (stride
[d
]);
1543 /* Build the counters to clock through the array reference. */
1545 for (d
= 0; d
< rank
; d
++)
1547 /* Make this stretch of code easier on the eye! */
1548 begin
= ref
->u
.ar
.start
[d
];
1549 finish
= ref
->u
.ar
.end
[d
];
1550 step
= ref
->u
.ar
.stride
[d
];
1551 lower
= ref
->u
.ar
.as
->lower
[d
];
1552 upper
= ref
->u
.ar
.as
->upper
[d
];
1554 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1556 gfc_constructor
*ci
;
1559 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1565 gcc_assert (begin
->rank
== 1);
1566 /* Zero-sized arrays have no shape and no elements, stop early. */
1569 mpz_init_set_ui (nelts
, 0);
1573 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1574 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1575 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1576 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1579 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1581 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1582 || mpz_cmp (ci
->expr
->value
.integer
,
1583 lower
->value
.integer
) < 0)
1585 gfc_error ("index in dimension %d is out of bounds "
1586 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1594 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1595 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1596 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1602 /* Obtain the stride. */
1604 mpz_set (stride
[d
], step
->value
.integer
);
1606 mpz_set_ui (stride
[d
], one
);
1608 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1609 mpz_set_ui (stride
[d
], one
);
1611 /* Obtain the start value for the index. */
1613 mpz_set (start
[d
], begin
->value
.integer
);
1615 mpz_set (start
[d
], lower
->value
.integer
);
1617 mpz_set (ctr
[d
], start
[d
]);
1619 /* Obtain the end value for the index. */
1621 mpz_set (end
[d
], finish
->value
.integer
);
1623 mpz_set (end
[d
], upper
->value
.integer
);
1625 /* Separate 'if' because elements sometimes arrive with
1627 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1628 mpz_set (end
[d
], begin
->value
.integer
);
1630 /* Check the bounds. */
1631 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1632 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1633 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1634 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1636 gfc_error ("index in dimension %d is out of bounds "
1637 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1642 /* Calculate the number of elements and the shape. */
1643 mpz_set (tmp_mpz
, stride
[d
]);
1644 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1645 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1646 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1647 mpz_mul (nelts
, nelts
, tmp_mpz
);
1649 /* An element reference reduces the rank of the expression; don't
1650 add anything to the shape array. */
1651 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1652 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1655 /* Calculate the 'stride' (=delta) for conversion of the
1656 counter values into the index along the constructor. */
1657 mpz_set (delta
[d
], delta_mpz
);
1658 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1659 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1660 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1664 cons
= gfc_constructor_first (base
);
1666 /* Now clock through the array reference, calculating the index in
1667 the source constructor and transferring the elements to the new
1669 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1671 mpz_init_set_ui (ptr
, 0);
1674 for (d
= 0; d
< rank
; d
++)
1676 mpz_set (tmp_mpz
, ctr
[d
]);
1677 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1678 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1679 mpz_add (ptr
, ptr
, tmp_mpz
);
1681 if (!incr_ctr
) continue;
1683 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1685 gcc_assert(vecsub
[d
]);
1687 if (!gfc_constructor_next (vecsub
[d
]))
1688 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1691 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1694 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1698 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1700 if (mpz_cmp_ui (stride
[d
], 0) > 0
1701 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1702 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1703 mpz_set (ctr
[d
], start
[d
]);
1709 limit
= mpz_get_ui (ptr
);
1710 if (limit
>= flag_max_array_constructor
)
1712 gfc_error ("The number of elements in the array constructor "
1713 "at %L requires an increase of the allowed %d "
1714 "upper limit. See %<-fmax-array-constructor%> "
1715 "option", &expr
->where
, flag_max_array_constructor
);
1719 cons
= gfc_constructor_lookup (base
, limit
);
1721 gfc_constructor_append_expr (&expr
->value
.constructor
,
1722 gfc_copy_expr (cons
->expr
), NULL
);
1729 mpz_clear (delta_mpz
);
1730 mpz_clear (tmp_mpz
);
1732 for (d
= 0; d
< rank
; d
++)
1734 mpz_clear (delta
[d
]);
1735 mpz_clear (start
[d
]);
1738 mpz_clear (stride
[d
]);
1740 gfc_constructor_free (base
);
1744 /* Pull a substring out of an expression. */
1747 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1750 gfc_charlen_t start
;
1751 gfc_charlen_t length
;
1754 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1755 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1758 *newp
= gfc_copy_expr (p
);
1759 free ((*newp
)->value
.character
.string
);
1761 end
= (gfc_charlen_t
) mpz_get_si (p
->ref
->u
.ss
.end
->value
.integer
);
1762 start
= (gfc_charlen_t
) mpz_get_si (p
->ref
->u
.ss
.start
->value
.integer
);
1764 length
= end
- start
+ 1;
1768 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1769 (*newp
)->value
.character
.length
= length
;
1770 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1771 length
* sizeof (gfc_char_t
));
1777 /* Pull an inquiry result out of an expression. */
1780 find_inquiry_ref (gfc_expr
*p
, gfc_expr
**newp
)
1783 gfc_ref
*inquiry
= NULL
;
1786 tmp
= gfc_copy_expr (p
);
1788 if (tmp
->ref
&& tmp
->ref
->type
== REF_INQUIRY
)
1795 for (ref
= tmp
->ref
; ref
; ref
= ref
->next
)
1796 if (ref
->next
&& ref
->next
->type
== REF_INQUIRY
)
1798 inquiry
= ref
->next
;
1805 gfc_free_expr (tmp
);
1809 gfc_resolve_expr (tmp
);
1811 /* In principle there can be more than one inquiry reference. */
1812 for (; inquiry
; inquiry
= inquiry
->next
)
1814 switch (inquiry
->u
.i
)
1817 if (tmp
->ts
.type
!= BT_CHARACTER
)
1820 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1823 if (tmp
->ts
.u
.cl
->length
1824 && tmp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1825 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1826 else if (tmp
->expr_type
== EXPR_CONSTANT
)
1827 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1828 NULL
, tmp
->value
.character
.length
);
1835 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1838 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1841 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1842 NULL
, tmp
->ts
.kind
);
1846 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1849 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1852 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1853 mpfr_set ((*newp
)->value
.real
,
1854 mpc_realref (tmp
->value
.complex), GFC_RND_MODE
);
1858 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1861 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1864 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1865 mpfr_set ((*newp
)->value
.real
,
1866 mpc_imagref (tmp
->value
.complex), GFC_RND_MODE
);
1869 tmp
= gfc_copy_expr (*newp
);
1874 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1876 gfc_free_expr (*newp
);
1880 gfc_free_expr (tmp
);
1884 gfc_free_expr (tmp
);
1890 /* Simplify a subobject reference of a constructor. This occurs when
1891 parameter variable values are substituted. */
1894 simplify_const_ref (gfc_expr
*p
)
1896 gfc_constructor
*cons
, *c
;
1897 gfc_expr
*newp
= NULL
;
1902 switch (p
->ref
->type
)
1905 switch (p
->ref
->u
.ar
.type
)
1908 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1909 will generate this. */
1910 if (p
->expr_type
!= EXPR_ARRAY
)
1912 remove_subobject_ref (p
, NULL
);
1915 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1921 remove_subobject_ref (p
, cons
);
1925 if (!find_array_section (p
, p
->ref
))
1927 p
->ref
->u
.ar
.type
= AR_FULL
;
1932 if (p
->ref
->next
!= NULL
1933 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1935 for (c
= gfc_constructor_first (p
->value
.constructor
);
1936 c
; c
= gfc_constructor_next (c
))
1938 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1939 if (!simplify_const_ref (c
->expr
))
1943 if (gfc_bt_struct (p
->ts
.type
)
1945 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1947 /* There may have been component references. */
1948 p
->ts
= c
->expr
->ts
;
1952 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1954 if (p
->ts
.type
== BT_CHARACTER
1955 && last_ref
->type
== REF_SUBSTRING
)
1957 /* If this is a CHARACTER array and we possibly took
1958 a substring out of it, update the type-spec's
1959 character length according to the first element
1960 (as all should have the same length). */
1961 gfc_charlen_t string_len
;
1962 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1964 const gfc_expr
* first
= c
->expr
;
1965 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1966 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1967 string_len
= first
->value
.character
.length
;
1975 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1978 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
,
1982 gfc_free_expr (p
->ts
.u
.cl
->length
);
1985 = gfc_get_int_expr (gfc_charlen_int_kind
,
1989 gfc_free_ref_list (p
->ref
);
2000 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
2001 remove_subobject_ref (p
, cons
);
2005 if (!find_inquiry_ref (p
, &newp
))
2008 gfc_replace_expr (p
, newp
);
2009 gfc_free_ref_list (p
->ref
);
2014 if (!find_substring_ref (p
, &newp
))
2017 gfc_replace_expr (p
, newp
);
2018 gfc_free_ref_list (p
->ref
);
2028 /* Simplify a chain of references. */
2031 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
2036 for (; ref
; ref
= ref
->next
)
2041 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2043 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
2045 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
2047 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
2053 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
2055 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
2060 if (!find_inquiry_ref (*p
, &newp
))
2063 gfc_replace_expr (*p
, newp
);
2064 gfc_free_ref_list ((*p
)->ref
);
2076 /* Try to substitute the value of a parameter variable. */
2079 simplify_parameter_variable (gfc_expr
*p
, int type
)
2084 /* Set rank and check array ref; as resolve_variable calls
2085 gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
2086 if (!gfc_resolve_ref (p
))
2091 gfc_expression_rank (p
);
2093 /* Is this an inquiry? */
2094 bool inquiry
= false;
2095 gfc_ref
* ref
= p
->ref
;
2098 if (ref
->type
== REF_INQUIRY
)
2102 if (ref
&& ref
->type
== REF_INQUIRY
)
2103 inquiry
= ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
;
2105 if (gfc_is_size_zero_array (p
))
2107 if (p
->expr_type
== EXPR_ARRAY
)
2110 e
= gfc_get_expr ();
2111 e
->expr_type
= EXPR_ARRAY
;
2114 e
->value
.constructor
= NULL
;
2115 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2116 e
->where
= p
->where
;
2117 /* If %kind and %len are not used then we're done, otherwise
2118 drop through for simplification. */
2121 gfc_replace_expr (p
, e
);
2127 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2131 gfc_free_shape (&e
->shape
, e
->rank
);
2132 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2135 if (e
->ts
.type
== BT_CHARACTER
&& p
->ts
.u
.cl
)
2139 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
)
2140 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, p
->ts
.u
.cl
);
2142 /* Do not copy subobject refs for constant. */
2143 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2144 e
->ref
= gfc_copy_ref (p
->ref
);
2145 t
= gfc_simplify_expr (e
, type
);
2146 e
->where
= p
->where
;
2148 /* Only use the simplification if it eliminated all subobject references. */
2150 gfc_replace_expr (p
, e
);
2159 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2161 /* Given an expression, simplify it by collapsing constant
2162 expressions. Most simplification takes place when the expression
2163 tree is being constructed. If an intrinsic function is simplified
2164 at some point, we get called again to collapse the result against
2167 We work by recursively simplifying expression nodes, simplifying
2168 intrinsic functions where possible, which can lead to further
2169 constant collapsing. If an operator has constant operand(s), we
2170 rip the expression apart, and rebuild it, hoping that it becomes
2173 The expression type is defined for:
2174 0 Basic expression parsing
2175 1 Simplifying array constructors -- will substitute
2177 Returns false on error, true otherwise.
2178 NOTE: Will return true even if the expression cannot be simplified. */
2181 gfc_simplify_expr (gfc_expr
*p
, int type
)
2183 gfc_actual_arglist
*ap
;
2184 gfc_intrinsic_sym
* isym
= NULL
;
2190 switch (p
->expr_type
)
2193 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2194 simplify_ref_chain (p
->ref
, type
, &p
);
2200 // For array-bound functions, we don't need to optimize
2201 // the 'array' argument. In particular, if the argument
2202 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2203 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2204 // can have any lbound.
2205 ap
= p
->value
.function
.actual
;
2206 if (p
->value
.function
.isym
&&
2207 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2208 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2209 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2210 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2211 || p
->value
.function
.isym
->id
== GFC_ISYM_SHAPE
))
2214 for ( ; ap
; ap
= ap
->next
)
2215 if (!gfc_simplify_expr (ap
->expr
, type
))
2218 if (p
->value
.function
.isym
!= NULL
2219 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2222 if (p
->expr_type
== EXPR_FUNCTION
)
2225 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2226 if (isym
&& isym
->elemental
)
2227 scalarize_intrinsic_call (p
, false);
2232 case EXPR_SUBSTRING
:
2233 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2236 if (gfc_is_constant_expr (p
))
2239 HOST_WIDE_INT start
, end
;
2242 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2244 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2245 start
--; /* Convert from one-based to zero-based. */
2248 end
= p
->value
.character
.length
;
2249 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2250 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2255 s
= gfc_get_wide_string (end
- start
+ 2);
2256 memcpy (s
, p
->value
.character
.string
+ start
,
2257 (end
- start
) * sizeof (gfc_char_t
));
2258 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2259 free (p
->value
.character
.string
);
2260 p
->value
.character
.string
= s
;
2261 p
->value
.character
.length
= end
- start
;
2262 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2263 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2265 p
->value
.character
.length
);
2266 gfc_free_ref_list (p
->ref
);
2268 p
->expr_type
= EXPR_CONSTANT
;
2273 if (!simplify_intrinsic_op (p
, type
))
2278 /* Only substitute array parameter variables if we are in an
2279 initialization expression, or we want a subsection. */
2280 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2281 && (gfc_init_expr_flag
|| p
->ref
2282 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2284 if (!simplify_parameter_variable (p
, type
))
2291 gfc_simplify_iterator_var (p
);
2294 /* Simplify subcomponent references. */
2295 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2300 case EXPR_STRUCTURE
:
2302 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2305 /* If the following conditions hold, we found something like kind type
2306 inquiry of the form a(2)%kind while simplify the ref chain. */
2307 if (p
->expr_type
== EXPR_CONSTANT
&& !p
->ref
&& !p
->rank
&& !p
->shape
)
2310 if (!simplify_constructor (p
->value
.constructor
, type
))
2313 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2314 && p
->ref
->u
.ar
.type
== AR_FULL
)
2315 gfc_expand_constructor (p
, false);
2317 if (!simplify_const_ref (p
))
2334 /* Returns the type of an expression with the exception that iterator
2335 variables are automatically integers no matter what else they may
2341 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2348 /* Scalarize an expression for an elemental intrinsic call. */
2351 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2353 gfc_actual_arglist
*a
, *b
;
2354 gfc_constructor_base ctor
;
2355 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2356 gfc_constructor
*ci
, *new_ctor
;
2357 gfc_expr
*expr
, *old
, *p
;
2358 int n
, i
, rank
[5], array_arg
;
2363 a
= e
->value
.function
.actual
;
2364 for (; a
; a
= a
->next
)
2365 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2368 /* Find which, if any, arguments are arrays. Assume that the old
2369 expression carries the type information and that the first arg
2370 that is an array expression carries all the shape information.*/
2372 a
= e
->value
.function
.actual
;
2373 for (; a
; a
= a
->next
)
2376 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2379 expr
= gfc_copy_expr (a
->expr
);
2386 old
= gfc_copy_expr (e
);
2388 gfc_constructor_free (expr
->value
.constructor
);
2389 expr
->value
.constructor
= NULL
;
2391 expr
->where
= old
->where
;
2392 expr
->expr_type
= EXPR_ARRAY
;
2394 /* Copy the array argument constructors into an array, with nulls
2397 a
= old
->value
.function
.actual
;
2398 for (; a
; a
= a
->next
)
2400 /* Check that this is OK for an initialization expression. */
2401 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2405 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2407 rank
[n
] = a
->expr
->rank
;
2408 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2409 args
[n
] = gfc_constructor_first (ctor
);
2411 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2414 rank
[n
] = a
->expr
->rank
;
2417 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2418 args
[n
] = gfc_constructor_first (ctor
);
2426 /* Using the array argument as the master, step through the array
2427 calling the function for each element and advancing the array
2428 constructors together. */
2429 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2431 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2432 gfc_copy_expr (old
), NULL
);
2434 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2436 b
= old
->value
.function
.actual
;
2437 for (i
= 0; i
< n
; i
++)
2440 new_ctor
->expr
->value
.function
.actual
2441 = a
= gfc_get_actual_arglist ();
2444 a
->next
= gfc_get_actual_arglist ();
2449 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2451 a
->expr
= gfc_copy_expr (b
->expr
);
2456 /* Simplify the function calls. If the simplification fails, the
2457 error will be flagged up down-stream or the library will deal
2459 p
= gfc_copy_expr (new_ctor
->expr
);
2461 if (!gfc_simplify_expr (p
, init_flag
))
2464 gfc_replace_expr (new_ctor
->expr
, p
);
2466 for (i
= 0; i
< n
; i
++)
2468 args
[i
] = gfc_constructor_next (args
[i
]);
2470 for (i
= 1; i
< n
; i
++)
2471 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2472 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2478 /* Free "expr" but not the pointers it contains. */
2480 gfc_free_expr (old
);
2484 gfc_error_now ("elemental function arguments at %C are not compliant");
2487 gfc_free_expr (expr
);
2488 gfc_free_expr (old
);
2494 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2496 gfc_expr
*op1
= e
->value
.op
.op1
;
2497 gfc_expr
*op2
= e
->value
.op
.op2
;
2499 if (!(*check_function
)(op1
))
2502 switch (e
->value
.op
.op
)
2504 case INTRINSIC_UPLUS
:
2505 case INTRINSIC_UMINUS
:
2506 if (!numeric_type (et0 (op1
)))
2511 case INTRINSIC_EQ_OS
:
2513 case INTRINSIC_NE_OS
:
2515 case INTRINSIC_GT_OS
:
2517 case INTRINSIC_GE_OS
:
2519 case INTRINSIC_LT_OS
:
2521 case INTRINSIC_LE_OS
:
2522 if (!(*check_function
)(op2
))
2525 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2526 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2528 gfc_error ("Numeric or CHARACTER operands are required in "
2529 "expression at %L", &e
->where
);
2534 case INTRINSIC_PLUS
:
2535 case INTRINSIC_MINUS
:
2536 case INTRINSIC_TIMES
:
2537 case INTRINSIC_DIVIDE
:
2538 case INTRINSIC_POWER
:
2539 if (!(*check_function
)(op2
))
2542 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2547 case INTRINSIC_CONCAT
:
2548 if (!(*check_function
)(op2
))
2551 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2553 gfc_error ("Concatenation operator in expression at %L "
2554 "must have two CHARACTER operands", &op1
->where
);
2558 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2560 gfc_error ("Concat operator at %L must concatenate strings of the "
2561 "same kind", &e
->where
);
2568 if (et0 (op1
) != BT_LOGICAL
)
2570 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2571 "operand", &op1
->where
);
2580 case INTRINSIC_NEQV
:
2581 if (!(*check_function
)(op2
))
2584 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2586 gfc_error ("LOGICAL operands are required in expression at %L",
2593 case INTRINSIC_PARENTHESES
:
2597 gfc_error ("Only intrinsic operators can be used in expression at %L",
2605 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2610 /* F2003, 7.1.7 (3): In init expression, allocatable components
2611 must not be data-initialized. */
2613 check_alloc_comp_init (gfc_expr
*e
)
2615 gfc_component
*comp
;
2616 gfc_constructor
*ctor
;
2618 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2619 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2621 for (comp
= e
->ts
.u
.derived
->components
,
2622 ctor
= gfc_constructor_first (e
->value
.constructor
);
2623 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2625 if (comp
->attr
.allocatable
&& ctor
->expr
2626 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2628 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2629 "component %qs in structure constructor at %L",
2630 comp
->name
, &ctor
->expr
->where
);
2639 check_init_expr_arguments (gfc_expr
*e
)
2641 gfc_actual_arglist
*ap
;
2643 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2644 if (!gfc_check_init_expr (ap
->expr
))
2650 static bool check_restricted (gfc_expr
*);
2652 /* F95, 7.1.6.1, Initialization expressions, (7)
2653 F2003, 7.1.7 Initialization expression, (8)
2654 F2008, 7.1.12 Constant expression, (4) */
2657 check_inquiry (gfc_expr
*e
, int not_restricted
)
2660 const char *const *functions
;
2662 static const char *const inquiry_func_f95
[] = {
2663 "lbound", "shape", "size", "ubound",
2664 "bit_size", "len", "kind",
2665 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2666 "precision", "radix", "range", "tiny",
2670 static const char *const inquiry_func_f2003
[] = {
2671 "lbound", "shape", "size", "ubound",
2672 "bit_size", "len", "kind",
2673 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2674 "precision", "radix", "range", "tiny",
2678 /* std=f2008+ or -std=gnu */
2679 static const char *const inquiry_func_gnu
[] = {
2680 "lbound", "shape", "size", "ubound",
2681 "bit_size", "len", "kind",
2682 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2683 "precision", "radix", "range", "tiny",
2684 "new_line", "storage_size", NULL
2688 gfc_actual_arglist
*ap
;
2692 if (!e
->value
.function
.isym
2693 || !e
->value
.function
.isym
->inquiry
)
2696 /* An undeclared parameter will get us here (PR25018). */
2697 if (e
->symtree
== NULL
)
2700 sym
= e
->symtree
->n
.sym
;
2702 if (sym
->from_intmod
)
2704 if (sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2705 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2706 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2709 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2710 && sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2717 functions
= inquiry_func_gnu
;
2718 if (gfc_option
.warn_std
& GFC_STD_F2003
)
2719 functions
= inquiry_func_f2003
;
2720 if (gfc_option
.warn_std
& GFC_STD_F95
)
2721 functions
= inquiry_func_f95
;
2723 for (i
= 0; functions
[i
]; i
++)
2724 if (strcmp (functions
[i
], name
) == 0)
2727 if (functions
[i
] == NULL
)
2731 /* At this point we have an inquiry function with a variable argument. The
2732 type of the variable might be undefined, but we need it now, because the
2733 arguments of these functions are not allowed to be undefined. */
2735 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2740 asym
= ap
->expr
->symtree
? ap
->expr
->symtree
->n
.sym
: NULL
;
2742 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2744 if (asym
&& asym
->ts
.type
== BT_UNKNOWN
2745 && !gfc_set_default_type (asym
, 0, gfc_current_ns
))
2748 ap
->expr
->ts
= asym
->ts
;
2751 if (asym
&& asym
->assoc
&& asym
->assoc
->target
2752 && asym
->assoc
->target
->expr_type
== EXPR_CONSTANT
)
2754 gfc_free_expr (ap
->expr
);
2755 ap
->expr
= gfc_copy_expr (asym
->assoc
->target
);
2758 /* Assumed character length will not reduce to a constant expression
2759 with LEN, as required by the standard. */
2760 if (i
== 5 && not_restricted
&& asym
2761 && asym
->ts
.type
== BT_CHARACTER
2762 && ((asym
->ts
.u
.cl
&& asym
->ts
.u
.cl
->length
== NULL
)
2763 || asym
->ts
.deferred
))
2765 gfc_error ("Assumed or deferred character length variable %qs "
2766 "in constant expression at %L",
2767 asym
->name
, &ap
->expr
->where
);
2770 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2773 if (not_restricted
== 0
2774 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2775 && !check_restricted (ap
->expr
))
2778 if (not_restricted
== 0
2779 && ap
->expr
->expr_type
== EXPR_VARIABLE
2780 && asym
->attr
.dummy
&& asym
->attr
.optional
)
2788 /* F95, 7.1.6.1, Initialization expressions, (5)
2789 F2003, 7.1.7 Initialization expression, (5) */
2792 check_transformational (gfc_expr
*e
)
2794 static const char * const trans_func_f95
[] = {
2795 "repeat", "reshape", "selected_int_kind",
2796 "selected_real_kind", "transfer", "trim", NULL
2799 static const char * const trans_func_f2003
[] = {
2800 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2801 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2802 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2803 "trim", "unpack", NULL
2806 static const char * const trans_func_f2008
[] = {
2807 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2808 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2809 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2810 "trim", "unpack", "findloc", NULL
2815 const char *const *functions
;
2817 if (!e
->value
.function
.isym
2818 || !e
->value
.function
.isym
->transformational
)
2821 name
= e
->symtree
->n
.sym
->name
;
2823 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2824 functions
= trans_func_f2008
;
2825 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2826 functions
= trans_func_f2003
;
2828 functions
= trans_func_f95
;
2830 /* NULL() is dealt with below. */
2831 if (strcmp ("null", name
) == 0)
2834 for (i
= 0; functions
[i
]; i
++)
2835 if (strcmp (functions
[i
], name
) == 0)
2838 if (functions
[i
] == NULL
)
2840 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2841 "in an initialization expression", name
, &e
->where
);
2845 return check_init_expr_arguments (e
);
2849 /* F95, 7.1.6.1, Initialization expressions, (6)
2850 F2003, 7.1.7 Initialization expression, (6) */
2853 check_null (gfc_expr
*e
)
2855 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2858 return check_init_expr_arguments (e
);
2863 check_elemental (gfc_expr
*e
)
2865 if (!e
->value
.function
.isym
2866 || !e
->value
.function
.isym
->elemental
)
2869 if (e
->ts
.type
!= BT_INTEGER
2870 && e
->ts
.type
!= BT_CHARACTER
2871 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2872 "initialization expression at %L", &e
->where
))
2875 return check_init_expr_arguments (e
);
2880 check_conversion (gfc_expr
*e
)
2882 if (!e
->value
.function
.isym
2883 || !e
->value
.function
.isym
->conversion
)
2886 return check_init_expr_arguments (e
);
2890 /* Verify that an expression is an initialization expression. A side
2891 effect is that the expression tree is reduced to a single constant
2892 node if all goes well. This would normally happen when the
2893 expression is constructed but function references are assumed to be
2894 intrinsics in the context of initialization expressions. If
2895 false is returned an error message has been generated. */
2898 gfc_check_init_expr (gfc_expr
*e
)
2906 switch (e
->expr_type
)
2909 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2911 t
= gfc_simplify_expr (e
, 0);
2920 gfc_intrinsic_sym
* isym
= NULL
;
2921 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2923 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2924 IEEE_EXCEPTIONS modules. */
2925 int mod
= sym
->from_intmod
;
2926 if (mod
== INTMOD_NONE
&& sym
->generic
)
2927 mod
= sym
->generic
->sym
->from_intmod
;
2928 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2930 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2933 gfc_replace_expr (e
, new_expr
);
2939 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2940 into an array constructor, we need to skip the error check here.
2941 Conversion errors are caught below in scalarize_intrinsic_call. */
2942 conversion
= e
->value
.function
.isym
2943 && (e
->value
.function
.isym
->conversion
== 1);
2945 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2946 || (m
= gfc_intrinsic_func_interface (e
, 0)) == MATCH_NO
))
2948 gfc_error ("Function %qs in initialization expression at %L "
2949 "must be an intrinsic function",
2950 e
->symtree
->n
.sym
->name
, &e
->where
);
2954 if ((m
= check_conversion (e
)) == MATCH_NO
2955 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2956 && (m
= check_null (e
)) == MATCH_NO
2957 && (m
= check_transformational (e
)) == MATCH_NO
2958 && (m
= check_elemental (e
)) == MATCH_NO
)
2960 gfc_error ("Intrinsic function %qs at %L is not permitted "
2961 "in an initialization expression",
2962 e
->symtree
->n
.sym
->name
, &e
->where
);
2966 if (m
== MATCH_ERROR
)
2969 /* Try to scalarize an elemental intrinsic function that has an
2971 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2972 if (isym
&& isym
->elemental
2973 && (t
= scalarize_intrinsic_call (e
, true)))
2978 t
= gfc_simplify_expr (e
, 0);
2985 /* This occurs when parsing pdt templates. */
2986 if (gfc_expr_attr (e
).pdt_kind
)
2989 if (gfc_check_iter_variable (e
))
2992 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2994 /* A PARAMETER shall not be used to define itself, i.e.
2995 REAL, PARAMETER :: x = transfer(0, x)
2997 if (!e
->symtree
->n
.sym
->value
)
2999 gfc_error ("PARAMETER %qs is used at %L before its definition "
3000 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
3004 t
= simplify_parameter_variable (e
, 0);
3009 if (gfc_in_match_data ())
3014 if (e
->symtree
->n
.sym
->as
)
3016 switch (e
->symtree
->n
.sym
->as
->type
)
3018 case AS_ASSUMED_SIZE
:
3019 gfc_error ("Assumed size array %qs at %L is not permitted "
3020 "in an initialization expression",
3021 e
->symtree
->n
.sym
->name
, &e
->where
);
3024 case AS_ASSUMED_SHAPE
:
3025 gfc_error ("Assumed shape array %qs at %L is not permitted "
3026 "in an initialization expression",
3027 e
->symtree
->n
.sym
->name
, &e
->where
);
3031 if (!e
->symtree
->n
.sym
->attr
.allocatable
3032 && !e
->symtree
->n
.sym
->attr
.pointer
3033 && e
->symtree
->n
.sym
->attr
.dummy
)
3034 gfc_error ("Assumed-shape array %qs at %L is not permitted "
3035 "in an initialization expression",
3036 e
->symtree
->n
.sym
->name
, &e
->where
);
3038 gfc_error ("Deferred array %qs at %L is not permitted "
3039 "in an initialization expression",
3040 e
->symtree
->n
.sym
->name
, &e
->where
);
3044 gfc_error ("Array %qs at %L is a variable, which does "
3045 "not reduce to a constant expression",
3046 e
->symtree
->n
.sym
->name
, &e
->where
);
3049 case AS_ASSUMED_RANK
:
3050 gfc_error ("Assumed-rank array %qs at %L is not permitted "
3051 "in an initialization expression",
3052 e
->symtree
->n
.sym
->name
, &e
->where
);
3060 gfc_error ("Parameter %qs at %L has not been declared or is "
3061 "a variable, which does not reduce to a constant "
3062 "expression", e
->symtree
->name
, &e
->where
);
3071 case EXPR_SUBSTRING
:
3074 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
3078 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
3080 t
= gfc_simplify_expr (e
, 0);
3086 case EXPR_STRUCTURE
:
3087 t
= e
->ts
.is_iso_c
? true : false;
3091 t
= check_alloc_comp_init (e
);
3095 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3102 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3106 t
= gfc_expand_constructor (e
, true);
3110 t
= gfc_check_constructor_type (e
);
3114 gfc_internal_error ("check_init_expr(): Unknown expression type");
3120 /* Reduces a general expression to an initialization expression (a constant).
3121 This used to be part of gfc_match_init_expr.
3122 Note that this function doesn't free the given expression on false. */
3125 gfc_reduce_init_expr (gfc_expr
*expr
)
3129 gfc_init_expr_flag
= true;
3130 t
= gfc_resolve_expr (expr
);
3132 t
= gfc_check_init_expr (expr
);
3133 gfc_init_expr_flag
= false;
3138 if (expr
->expr_type
== EXPR_ARRAY
)
3140 if (!gfc_check_constructor_type (expr
))
3142 if (!gfc_expand_constructor (expr
, true))
3150 /* Match an initialization expression. We work by first matching an
3151 expression, then reducing it to a constant. */
3154 gfc_match_init_expr (gfc_expr
**result
)
3162 gfc_init_expr_flag
= true;
3164 m
= gfc_match_expr (&expr
);
3167 gfc_init_expr_flag
= false;
3171 if (gfc_derived_parameter_expr (expr
))
3174 gfc_init_expr_flag
= false;
3178 t
= gfc_reduce_init_expr (expr
);
3181 gfc_free_expr (expr
);
3182 gfc_init_expr_flag
= false;
3187 gfc_init_expr_flag
= false;
3193 /* Given an actual argument list, test to see that each argument is a
3194 restricted expression and optionally if the expression type is
3195 integer or character. */
3198 restricted_args (gfc_actual_arglist
*a
)
3200 for (; a
; a
= a
->next
)
3202 if (!check_restricted (a
->expr
))
3210 /************* Restricted/specification expressions *************/
3213 /* Make sure a non-intrinsic function is a specification function,
3214 * see F08:7.1.11.5. */
3217 external_spec_function (gfc_expr
*e
)
3221 f
= e
->value
.function
.esym
;
3223 /* IEEE functions allowed are "a reference to a transformational function
3224 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3225 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3226 IEEE_EXCEPTIONS". */
3227 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3228 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3230 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3231 || !strcmp (f
->name
, "ieee_support_rounding")
3232 || !strcmp (f
->name
, "ieee_support_flag")
3233 || !strcmp (f
->name
, "ieee_support_halting")
3234 || !strcmp (f
->name
, "ieee_support_datatype")
3235 || !strcmp (f
->name
, "ieee_support_denormal")
3236 || !strcmp (f
->name
, "ieee_support_subnormal")
3237 || !strcmp (f
->name
, "ieee_support_divide")
3238 || !strcmp (f
->name
, "ieee_support_inf")
3239 || !strcmp (f
->name
, "ieee_support_io")
3240 || !strcmp (f
->name
, "ieee_support_nan")
3241 || !strcmp (f
->name
, "ieee_support_sqrt")
3242 || !strcmp (f
->name
, "ieee_support_standard")
3243 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3244 goto function_allowed
;
3247 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3249 gfc_error ("Specification function %qs at %L cannot be a statement "
3250 "function", f
->name
, &e
->where
);
3254 if (f
->attr
.proc
== PROC_INTERNAL
)
3256 gfc_error ("Specification function %qs at %L cannot be an internal "
3257 "function", f
->name
, &e
->where
);
3261 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3263 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3269 if (f
->attr
.recursive
3270 && !gfc_notify_std (GFC_STD_F2003
,
3271 "Specification function %qs "
3272 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3276 return restricted_args (e
->value
.function
.actual
);
3280 /* Check to see that a function reference to an intrinsic is a
3281 restricted expression. */
3284 restricted_intrinsic (gfc_expr
*e
)
3286 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3287 if (check_inquiry (e
, 0) == MATCH_YES
)
3290 return restricted_args (e
->value
.function
.actual
);
3294 /* Check the expressions of an actual arglist. Used by check_restricted. */
3297 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3299 for (; arg
; arg
= arg
->next
)
3300 if (!checker (arg
->expr
))
3307 /* Check the subscription expressions of a reference chain with a checking
3308 function; used by check_restricted. */
3311 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3321 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3323 if (!checker (ref
->u
.ar
.start
[dim
]))
3325 if (!checker (ref
->u
.ar
.end
[dim
]))
3327 if (!checker (ref
->u
.ar
.stride
[dim
]))
3333 /* Nothing needed, just proceed to next reference. */
3337 if (!checker (ref
->u
.ss
.start
))
3339 if (!checker (ref
->u
.ss
.end
))
3348 return check_references (ref
->next
, checker
);
3351 /* Return true if ns is a parent of the current ns. */
3354 is_parent_of_current_ns (gfc_namespace
*ns
)
3357 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3364 /* Verify that an expression is a restricted expression. Like its
3365 cousin check_init_expr(), an error message is generated if we
3369 check_restricted (gfc_expr
*e
)
3377 switch (e
->expr_type
)
3380 t
= check_intrinsic_op (e
, check_restricted
);
3382 t
= gfc_simplify_expr (e
, 0);
3387 if (e
->value
.function
.esym
)
3389 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3391 t
= external_spec_function (e
);
3395 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3398 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3401 t
= restricted_intrinsic (e
);
3406 sym
= e
->symtree
->n
.sym
;
3409 /* If a dummy argument appears in a context that is valid for a
3410 restricted expression in an elemental procedure, it will have
3411 already been simplified away once we get here. Therefore we
3412 don't need to jump through hoops to distinguish valid from
3413 invalid cases. Allowed in F2008 and F2018. */
3414 if (gfc_notification_std (GFC_STD_F2008
)
3415 && sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3416 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3418 gfc_error_now ("Dummy argument %qs not "
3419 "allowed in expression at %L",
3420 sym
->name
, &e
->where
);
3424 if (sym
->attr
.optional
)
3426 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3427 sym
->name
, &e
->where
);
3431 if (sym
->attr
.intent
== INTENT_OUT
)
3433 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3434 sym
->name
, &e
->where
);
3438 /* Check reference chain if any. */
3439 if (!check_references (e
->ref
, &check_restricted
))
3442 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3443 processed in resolve.c(resolve_formal_arglist). This is done so
3444 that host associated dummy array indices are accepted (PR23446).
3445 This mechanism also does the same for the specification expressions
3446 of array-valued functions. */
3448 || sym
->attr
.in_common
3449 || sym
->attr
.use_assoc
3451 || sym
->attr
.implied_index
3452 || sym
->attr
.flavor
== FL_PARAMETER
3453 || is_parent_of_current_ns (sym
->ns
)
3454 || (sym
->ns
->proc_name
!= NULL
3455 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3456 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3462 gfc_error ("Variable %qs cannot appear in the expression at %L",
3463 sym
->name
, &e
->where
);
3464 /* Prevent a repetition of the error. */
3473 case EXPR_SUBSTRING
:
3474 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3478 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3480 t
= gfc_simplify_expr (e
, 0);
3484 case EXPR_STRUCTURE
:
3485 t
= gfc_check_constructor (e
, check_restricted
);
3489 t
= gfc_check_constructor (e
, check_restricted
);
3493 gfc_internal_error ("check_restricted(): Unknown expression type");
3500 /* Check to see that an expression is a specification expression. If
3501 we return false, an error has been generated. */
3504 gfc_specification_expr (gfc_expr
*e
)
3506 gfc_component
*comp
;
3511 if (e
->ts
.type
!= BT_INTEGER
)
3513 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3514 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3518 comp
= gfc_get_proc_ptr_comp (e
);
3519 if (e
->expr_type
== EXPR_FUNCTION
3520 && !e
->value
.function
.isym
3521 && !e
->value
.function
.esym
3522 && !gfc_pure (e
->symtree
->n
.sym
)
3523 && (!comp
|| !comp
->attr
.pure
))
3525 gfc_error ("Function %qs at %L must be PURE",
3526 e
->symtree
->n
.sym
->name
, &e
->where
);
3527 /* Prevent repeat error messages. */
3528 e
->symtree
->n
.sym
->attr
.pure
= 1;
3534 gfc_error ("Expression at %L must be scalar", &e
->where
);
3538 if (!gfc_simplify_expr (e
, 0))
3541 return check_restricted (e
);
3545 /************** Expression conformance checks. *************/
3547 /* Given two expressions, make sure that the arrays are conformable. */
3550 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3552 int op1_flag
, op2_flag
, d
;
3553 mpz_t op1_size
, op2_size
;
3559 if (op1
->rank
== 0 || op2
->rank
== 0)
3562 va_start (argp
, optype_msgid
);
3563 d
= vsnprintf (buffer
, sizeof (buffer
), optype_msgid
, argp
);
3565 if (d
< 1 || d
>= (int) sizeof (buffer
)) /* Reject truncation. */
3566 gfc_internal_error ("optype_msgid overflow: %d", d
);
3568 if (op1
->rank
!= op2
->rank
)
3570 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3571 op1
->rank
, op2
->rank
, &op1
->where
);
3577 for (d
= 0; d
< op1
->rank
; d
++)
3579 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3580 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3582 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3584 gfc_error ("Different shape for %s at %L on dimension %d "
3585 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3586 (int) mpz_get_si (op1_size
),
3587 (int) mpz_get_si (op2_size
));
3593 mpz_clear (op1_size
);
3595 mpz_clear (op2_size
);
3605 /* Given an assignable expression and an arbitrary expression, make
3606 sure that the assignment can take place. Only add a call to the intrinsic
3607 conversion routines, when allow_convert is set. When this assign is a
3608 coarray call, then the convert is done by the coarray routine implictly and
3609 adding the intrinsic conversion would do harm in most cases. */
3612 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3619 sym
= lvalue
->symtree
->n
.sym
;
3621 /* See if this is the component or subcomponent of a pointer and guard
3622 against assignment to LEN or KIND part-refs. */
3623 has_pointer
= sym
->attr
.pointer
;
3624 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3626 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3627 && ref
->u
.c
.component
->attr
.pointer
)
3629 else if (ref
->type
== REF_INQUIRY
3630 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3632 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3633 "allowed", &lvalue
->where
);
3638 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3639 variable local to a function subprogram. Its existence begins when
3640 execution of the function is initiated and ends when execution of the
3641 function is terminated...
3642 Therefore, the left hand side is no longer a variable, when it is: */
3643 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3644 && !sym
->attr
.external
)
3649 /* (i) Use associated; */
3650 if (sym
->attr
.use_assoc
)
3653 /* (ii) The assignment is in the main program; or */
3654 if (gfc_current_ns
->proc_name
3655 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3658 /* (iii) A module or internal procedure... */
3659 if (gfc_current_ns
->proc_name
3660 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3661 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3662 && gfc_current_ns
->parent
3663 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3664 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3665 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3667 /* ... that is not a function... */
3668 if (gfc_current_ns
->proc_name
3669 && !gfc_current_ns
->proc_name
->attr
.function
)
3672 /* ... or is not an entry and has a different name. */
3673 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3677 /* (iv) Host associated and not the function symbol or the
3678 parent result. This picks up sibling references, which
3679 cannot be entries. */
3680 if (!sym
->attr
.entry
3681 && sym
->ns
== gfc_current_ns
->parent
3682 && sym
!= gfc_current_ns
->proc_name
3683 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3688 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3694 /* Reject assigning to an external symbol. For initializers, this
3695 was already done before, in resolve_fl_procedure. */
3696 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
3697 && sym
->attr
.proc
!= PROC_MODULE
&& !rvalue
->error
)
3699 gfc_error ("Illegal assignment to external procedure at %L",
3705 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3707 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3708 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3712 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3714 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3719 if (rvalue
->expr_type
== EXPR_NULL
)
3721 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3722 && lvalue
->symtree
->n
.sym
->attr
.data
)
3726 gfc_error ("NULL appears on right-hand side in assignment at %L",
3732 /* This is possibly a typo: x = f() instead of x => f(). */
3734 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3735 gfc_warning (OPT_Wsurprising
,
3736 "POINTER-valued function appears on right-hand side of "
3737 "assignment at %L", &rvalue
->where
);
3739 /* Check size of array assignments. */
3740 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3741 && !gfc_check_conformance (lvalue
, rvalue
, _("array assignment")))
3744 /* Handle the case of a BOZ literal on the RHS. */
3745 if (rvalue
->ts
.type
== BT_BOZ
)
3747 if (lvalue
->symtree
->n
.sym
->attr
.data
)
3749 if (lvalue
->ts
.type
== BT_INTEGER
3750 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3753 if (lvalue
->ts
.type
== BT_REAL
3754 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3756 if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
3757 "be assigned to a REAL variable",
3764 if (!lvalue
->symtree
->n
.sym
->attr
.data
3765 && gfc_invalid_boz ("BOZ literal constant at %L is neither a "
3766 "data-stmt-constant nor an actual argument to "
3767 "INT, REAL, DBLE, or CMPLX intrinsic function",
3771 if (lvalue
->ts
.type
== BT_INTEGER
3772 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3775 if (lvalue
->ts
.type
== BT_REAL
3776 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3779 gfc_error ("BOZ literal constant near %L cannot be assigned to a "
3780 "%qs variable", &rvalue
->where
, gfc_typename (lvalue
));
3784 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3786 gfc_error ("The assignment to a KIND or LEN component of a "
3787 "parameterized type at %L is not allowed",
3792 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3795 /* Only DATA Statements come here. */
3800 /* Numeric can be converted to any other numeric. And Hollerith can be
3801 converted to any other type. */
3802 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3803 || rvalue
->ts
.type
== BT_HOLLERITH
)
3806 if (flag_dec_char_conversions
&& (gfc_numeric_ts (&lvalue
->ts
)
3807 || lvalue
->ts
.type
== BT_LOGICAL
)
3808 && rvalue
->ts
.type
== BT_CHARACTER
3809 && rvalue
->ts
.kind
== gfc_default_character_kind
)
3812 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3815 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3816 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3817 "conversion of %s to %s", where
,
3818 gfc_typename (rvalue
), gfc_typename (lvalue
));
3823 /* Assignment is the only case where character variables of different
3824 kind values can be converted into one another. */
3825 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3827 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3828 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3836 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3840 /* Check that a pointer assignment is OK. We first check lvalue, and
3841 we only check rvalue if it's not an assignment to NULL() or a
3842 NULLIFY statement. */
3845 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
3846 bool suppress_type_test
, bool is_init_expr
)
3848 symbol_attribute attr
, lhs_attr
;
3850 bool is_pure
, is_implicit_pure
, rank_remap
;
3854 if (!lvalue
->symtree
)
3857 lhs_attr
= gfc_expr_attr (lvalue
);
3858 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3860 gfc_error ("Pointer assignment target is not a POINTER at %L",
3865 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3866 && !lhs_attr
.proc_pointer
)
3868 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3869 "l-value since it is a procedure",
3870 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3874 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3877 same_rank
= lvalue
->rank
== rvalue
->rank
;
3878 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3880 if (ref
->type
== REF_COMPONENT
)
3881 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3883 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3887 if (ref
->u
.ar
.type
== AR_FULL
)
3890 if (ref
->u
.ar
.type
!= AR_SECTION
)
3892 gfc_error ("Expected bounds specification for %qs at %L",
3893 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3897 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3898 "for %qs in pointer assignment at %L",
3899 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3902 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3904 * (C1017) If bounds-spec-list is specified, the number of
3905 * bounds-specs shall equal the rank of data-pointer-object.
3907 * If bounds-spec-list appears, it specifies the lower bounds.
3909 * (C1018) If bounds-remapping-list is specified, the number of
3910 * bounds-remappings shall equal the rank of data-pointer-object.
3912 * If bounds-remapping-list appears, it specifies the upper and
3913 * lower bounds of each dimension of the pointer; the pointer target
3914 * shall be simply contiguous or of rank one.
3916 * (C1019) If bounds-remapping-list is not specified, the ranks of
3917 * data-pointer-object and data-target shall be the same.
3919 * Thus when bounds are given, all lbounds are necessary and either
3920 * all or none of the upper bounds; no strides are allowed. If the
3921 * upper bounds are present, we may do rank remapping. */
3922 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3924 if (ref
->u
.ar
.stride
[dim
])
3926 gfc_error ("Stride must not be present at %L",
3930 if (!same_rank
&& (!ref
->u
.ar
.start
[dim
] ||!ref
->u
.ar
.end
[dim
]))
3932 gfc_error ("Rank remapping requires a "
3933 "list of %<lower-bound : upper-bound%> "
3934 "specifications at %L", &lvalue
->where
);
3937 if (!ref
->u
.ar
.start
[dim
]
3938 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3940 gfc_error ("Expected list of %<lower-bound :%> or "
3941 "list of %<lower-bound : upper-bound%> "
3942 "specifications at %L", &lvalue
->where
);
3947 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3950 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
]))
3952 gfc_error ("Rank remapping requires a "
3953 "list of %<lower-bound : upper-bound%> "
3954 "specifications at %L", &lvalue
->where
);
3957 if (!rank_remap
&& ref
->u
.ar
.end
[dim
])
3959 gfc_error ("Expected list of %<lower-bound :%> or "
3960 "list of %<lower-bound : upper-bound%> "
3961 "specifications at %L", &lvalue
->where
);
3969 is_pure
= gfc_pure (NULL
);
3970 is_implicit_pure
= gfc_implicit_pure (NULL
);
3972 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3973 kind, etc for lvalue and rvalue must match, and rvalue must be a
3974 pure variable if we're in a pure function. */
3975 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3978 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3979 if (lvalue
->expr_type
== EXPR_VARIABLE
3980 && gfc_is_coindexed (lvalue
))
3983 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3984 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3986 gfc_error ("Pointer object at %L shall not have a coindex",
3992 /* Checks on rvalue for procedure pointer assignments. */
3997 gfc_component
*comp1
, *comp2
;
4000 attr
= gfc_expr_attr (rvalue
);
4001 if (!((rvalue
->expr_type
== EXPR_NULL
)
4002 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
4003 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
4004 || (rvalue
->expr_type
== EXPR_VARIABLE
4005 && attr
.flavor
== FL_PROCEDURE
)))
4007 gfc_error ("Invalid procedure pointer assignment at %L",
4012 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
4014 /* Check for intrinsics. */
4015 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
4016 if (!sym
->attr
.intrinsic
4017 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
4018 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
4020 sym
->attr
.intrinsic
= 1;
4021 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
4022 attr
= gfc_expr_attr (rvalue
);
4024 /* Check for result of embracing function. */
4025 if (sym
->attr
.function
&& sym
->result
== sym
)
4029 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4030 if (sym
== ns
->proc_name
)
4032 gfc_error ("Function result %qs is invalid as proc-target "
4033 "in procedure pointer assignment at %L",
4034 sym
->name
, &rvalue
->where
);
4041 gfc_error ("Abstract interface %qs is invalid "
4042 "in procedure pointer assignment at %L",
4043 rvalue
->symtree
->name
, &rvalue
->where
);
4046 /* Check for F08:C729. */
4047 if (attr
.flavor
== FL_PROCEDURE
)
4049 if (attr
.proc
== PROC_ST_FUNCTION
)
4051 gfc_error ("Statement function %qs is invalid "
4052 "in procedure pointer assignment at %L",
4053 rvalue
->symtree
->name
, &rvalue
->where
);
4056 if (attr
.proc
== PROC_INTERNAL
&&
4057 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
4058 "is invalid in procedure pointer assignment "
4059 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
4061 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
4062 attr
.subroutine
) == 0)
4064 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
4065 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
4069 /* Check for F08:C730. */
4070 if (attr
.elemental
&& !attr
.intrinsic
)
4072 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
4073 "in procedure pointer assignment at %L",
4074 rvalue
->symtree
->name
, &rvalue
->where
);
4078 /* Ensure that the calling convention is the same. As other attributes
4079 such as DLLEXPORT may differ, one explicitly only tests for the
4080 calling conventions. */
4081 if (rvalue
->expr_type
== EXPR_VARIABLE
4082 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
4083 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4085 symbol_attribute calls
;
4088 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
4089 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
4090 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
4092 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4093 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
4095 gfc_error ("Mismatch in the procedure pointer assignment "
4096 "at %L: mismatch in the calling convention",
4102 comp1
= gfc_get_proc_ptr_comp (lvalue
);
4104 s1
= comp1
->ts
.interface
;
4107 s1
= lvalue
->symtree
->n
.sym
;
4108 if (s1
->ts
.interface
)
4109 s1
= s1
->ts
.interface
;
4112 comp2
= gfc_get_proc_ptr_comp (rvalue
);
4115 if (rvalue
->expr_type
== EXPR_FUNCTION
)
4117 s2
= comp2
->ts
.interface
->result
;
4122 s2
= comp2
->ts
.interface
;
4126 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
4128 if (rvalue
->value
.function
.esym
)
4129 s2
= rvalue
->value
.function
.esym
->result
;
4131 s2
= rvalue
->symtree
->n
.sym
->result
;
4137 s2
= rvalue
->symtree
->n
.sym
;
4141 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
4142 s2
= s2
->ts
.interface
;
4144 /* Special check for the case of absent interface on the lvalue.
4145 * All other interface checks are done below. */
4146 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
4148 gfc_error ("Interface mismatch in procedure pointer assignment "
4149 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
4153 /* F08:7.2.2.4 (4) */
4154 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
4158 gfc_error ("Explicit interface required for component %qs at %L: %s",
4159 comp1
->name
, &lvalue
->where
, err
);
4162 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
4164 gfc_error ("Explicit interface required for %qs at %L: %s",
4165 s1
->name
, &lvalue
->where
, err
);
4169 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
4173 gfc_error ("Explicit interface required for component %qs at %L: %s",
4174 comp2
->name
, &rvalue
->where
, err
);
4177 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
4179 gfc_error ("Explicit interface required for %qs at %L: %s",
4180 s2
->name
, &rvalue
->where
, err
);
4185 if (s1
== s2
|| !s1
|| !s2
)
4188 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
4189 err
, sizeof(err
), NULL
, NULL
))
4191 gfc_error ("Interface mismatch in procedure pointer assignment "
4192 "at %L: %s", &rvalue
->where
, err
);
4196 /* Check F2008Cor2, C729. */
4197 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4198 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4200 gfc_error ("Procedure pointer target %qs at %L must be either an "
4201 "intrinsic, host or use associated, referenced or have "
4202 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4210 /* A non-proc pointer cannot point to a constant. */
4211 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4213 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4219 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4221 /* Check for F03:C717. */
4222 if (UNLIMITED_POLY (rvalue
)
4223 && !(UNLIMITED_POLY (lvalue
)
4224 || (lvalue
->ts
.type
== BT_DERIVED
4225 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4226 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4227 gfc_error ("Data-pointer-object at %L must be unlimited "
4228 "polymorphic, or of a type with the BIND or SEQUENCE "
4229 "attribute, to be compatible with an unlimited "
4230 "polymorphic target", &lvalue
->where
);
4231 else if (!suppress_type_test
)
4232 gfc_error ("Different types in pointer assignment at %L; "
4233 "attempted assignment of %s to %s", &lvalue
->where
,
4234 gfc_typename (rvalue
), gfc_typename (lvalue
));
4238 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4240 gfc_error ("Different kind type parameters in pointer "
4241 "assignment at %L", &lvalue
->where
);
4245 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4247 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4251 /* Make sure the vtab is present. */
4252 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4253 gfc_find_vtab (&rvalue
->ts
);
4255 /* Check rank remapping. */
4260 /* If this can be determined, check that the target must be at least as
4261 large as the pointer assigned to it is. */
4262 if (gfc_array_size (lvalue
, &lsize
)
4263 && gfc_array_size (rvalue
, &rsize
)
4264 && mpz_cmp (rsize
, lsize
) < 0)
4266 gfc_error ("Rank remapping target is smaller than size of the"
4267 " pointer (%ld < %ld) at %L",
4268 mpz_get_si (rsize
), mpz_get_si (lsize
),
4273 /* The target must be either rank one or it must be simply contiguous
4274 and F2008 must be allowed. */
4275 if (rvalue
->rank
!= 1)
4277 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4279 gfc_error ("Rank remapping target must be rank 1 or"
4280 " simply contiguous at %L", &rvalue
->where
);
4283 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4284 "rank 1 at %L", &rvalue
->where
))
4289 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4290 if (rvalue
->expr_type
== EXPR_NULL
)
4293 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4294 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4296 attr
= gfc_expr_attr (rvalue
);
4298 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4300 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4301 to caf_get. Map this to the same error message as below when it is
4302 still a variable expression. */
4303 if (rvalue
->value
.function
.isym
4304 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4305 /* The test above might need to be extend when F08, Note 5.4 has to be
4306 interpreted in the way that target and pointer with the same coindex
4308 gfc_error ("Data target at %L shall not have a coindex",
4311 gfc_error ("Target expression in pointer assignment "
4312 "at %L must deliver a pointer result",
4322 if (gfc_is_size_zero_array (rvalue
))
4324 gfc_error ("Zero-sized array detected at %L where an entity with "
4325 "the TARGET attribute is expected", &rvalue
->where
);
4328 else if (!rvalue
->symtree
)
4330 gfc_error ("Pointer assignment target in initialization expression "
4331 "does not have the TARGET attribute at %L",
4336 sym
= rvalue
->symtree
->n
.sym
;
4338 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4339 target
= CLASS_DATA (sym
)->attr
.target
;
4341 target
= sym
->attr
.target
;
4343 if (!target
&& !proc_pointer
)
4345 gfc_error ("Pointer assignment target in initialization expression "
4346 "does not have the TARGET attribute at %L",
4353 if (!attr
.target
&& !attr
.pointer
)
4355 gfc_error ("Pointer assignment target is neither TARGET "
4356 "nor POINTER at %L", &rvalue
->where
);
4361 if (lvalue
->ts
.type
== BT_CHARACTER
)
4363 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4368 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4370 gfc_error ("Bad target in pointer assignment in PURE "
4371 "procedure at %L", &rvalue
->where
);
4374 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4375 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4377 if (gfc_has_vector_index (rvalue
))
4379 gfc_error ("Pointer assignment with vector subscript "
4380 "on rhs at %L", &rvalue
->where
);
4384 if (attr
.is_protected
&& attr
.use_assoc
4385 && !(attr
.pointer
|| attr
.proc_pointer
))
4387 gfc_error ("Pointer assignment target has PROTECTED "
4388 "attribute at %L", &rvalue
->where
);
4392 /* F2008, C725. For PURE also C1283. */
4393 if (rvalue
->expr_type
== EXPR_VARIABLE
4394 && gfc_is_coindexed (rvalue
))
4397 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4398 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4400 gfc_error ("Data target at %L shall not have a coindex",
4406 /* Warn for assignments of contiguous pointers to targets which is not
4407 contiguous. Be lenient in the definition of what counts as
4410 if (lhs_attr
.contiguous
4411 && lhs_attr
.dimension
> 0)
4413 if (gfc_is_not_contiguous (rvalue
))
4415 gfc_error ("Assignment to contiguous pointer from "
4416 "non-contiguous target at %L", &rvalue
->where
);
4419 if (!gfc_is_simply_contiguous (rvalue
, false, true))
4420 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4421 "non-contiguous target at %L", &rvalue
->where
);
4424 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4425 if (warn_target_lifetime
4426 && rvalue
->expr_type
== EXPR_VARIABLE
4427 && !rvalue
->symtree
->n
.sym
->attr
.save
4428 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4429 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4430 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4431 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4432 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4437 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4438 || lvalue
->symtree
->n
.sym
->attr
.result
4439 || lvalue
->symtree
->n
.sym
->attr
.function
4440 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4441 && lvalue
->symtree
->n
.sym
->ns
4442 != rvalue
->symtree
->n
.sym
->ns
)
4443 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4444 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4446 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4447 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4448 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4449 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4450 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4452 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4459 gfc_warning (OPT_Wtarget_lifetime
,
4460 "Pointer at %L in pointer assignment might outlive the "
4461 "pointer target", &lvalue
->where
);
4468 /* Relative of gfc_check_assign() except that the lvalue is a single
4469 symbol. Used for initialization assignments. */
4472 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4476 bool pointer
, proc_pointer
;
4478 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4480 lvalue
.expr_type
= EXPR_VARIABLE
;
4481 lvalue
.ts
= sym
->ts
;
4483 lvalue
.rank
= sym
->as
->rank
;
4484 lvalue
.symtree
= XCNEW (gfc_symtree
);
4485 lvalue
.symtree
->n
.sym
= sym
;
4486 lvalue
.where
= sym
->declared_at
;
4490 lvalue
.ref
= gfc_get_ref ();
4491 lvalue
.ref
->type
= REF_COMPONENT
;
4492 lvalue
.ref
->u
.c
.component
= comp
;
4493 lvalue
.ref
->u
.c
.sym
= sym
;
4494 lvalue
.ts
= comp
->ts
;
4495 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4496 lvalue
.where
= comp
->loc
;
4497 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4498 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4499 proc_pointer
= comp
->attr
.proc_pointer
;
4503 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4504 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4505 proc_pointer
= sym
->attr
.proc_pointer
;
4508 if (pointer
|| proc_pointer
)
4509 r
= gfc_check_pointer_assign (&lvalue
, rvalue
, false, true);
4512 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4513 into an array constructor, we should check if it can be reduced
4514 as an initialization expression. */
4515 if (rvalue
->expr_type
== EXPR_FUNCTION
4516 && rvalue
->value
.function
.isym
4517 && (rvalue
->value
.function
.isym
->conversion
== 1))
4518 gfc_check_init_expr (rvalue
);
4520 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4523 free (lvalue
.symtree
);
4529 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
&& !proc_pointer
)
4531 /* F08:C461. Additional checks for pointer initialization. */
4532 symbol_attribute attr
;
4533 attr
= gfc_expr_attr (rvalue
);
4534 if (attr
.allocatable
)
4536 gfc_error ("Pointer initialization target at %L "
4537 "must not be ALLOCATABLE", &rvalue
->where
);
4540 if (!attr
.target
|| attr
.pointer
)
4542 gfc_error ("Pointer initialization target at %L "
4543 "must have the TARGET attribute", &rvalue
->where
);
4547 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4548 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4549 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4551 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4552 attr
.save
= SAVE_IMPLICIT
;
4557 gfc_error ("Pointer initialization target at %L "
4558 "must have the SAVE attribute", &rvalue
->where
);
4563 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4565 /* F08:C1220. Additional checks for procedure pointer initialization. */
4566 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4567 if (attr
.proc_pointer
)
4569 gfc_error ("Procedure pointer initialization target at %L "
4570 "may not be a procedure pointer", &rvalue
->where
);
4573 if (attr
.proc
== PROC_INTERNAL
)
4575 gfc_error ("Internal procedure %qs is invalid in "
4576 "procedure pointer initialization at %L",
4577 rvalue
->symtree
->name
, &rvalue
->where
);
4582 gfc_error ("Dummy procedure %qs is invalid in "
4583 "procedure pointer initialization at %L",
4584 rvalue
->symtree
->name
, &rvalue
->where
);
4592 /* Build an initializer for a local integer, real, complex, logical, or
4593 character variable, based on the command line flags finit-local-zero,
4594 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4595 With force, an initializer is ALWAYS generated. */
4598 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4600 gfc_expr
*init_expr
;
4602 /* Try to build an initializer expression. */
4603 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4605 /* If we want to force generation, make sure we default to zero. */
4606 gfc_init_local_real init_real
= flag_init_real
;
4607 int init_logical
= gfc_option
.flag_init_logical
;
4610 if (init_real
== GFC_INIT_REAL_OFF
)
4611 init_real
= GFC_INIT_REAL_ZERO
;
4612 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4613 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4616 /* We will only initialize integers, reals, complex, logicals, and
4617 characters, and only if the corresponding command-line flags
4618 were set. Otherwise, we free init_expr and return null. */
4622 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4623 mpz_set_si (init_expr
->value
.integer
,
4624 gfc_option
.flag_init_integer_value
);
4627 gfc_free_expr (init_expr
);
4635 case GFC_INIT_REAL_SNAN
:
4636 init_expr
->is_snan
= 1;
4638 case GFC_INIT_REAL_NAN
:
4639 mpfr_set_nan (init_expr
->value
.real
);
4642 case GFC_INIT_REAL_INF
:
4643 mpfr_set_inf (init_expr
->value
.real
, 1);
4646 case GFC_INIT_REAL_NEG_INF
:
4647 mpfr_set_inf (init_expr
->value
.real
, -1);
4650 case GFC_INIT_REAL_ZERO
:
4651 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4655 gfc_free_expr (init_expr
);
4664 case GFC_INIT_REAL_SNAN
:
4665 init_expr
->is_snan
= 1;
4667 case GFC_INIT_REAL_NAN
:
4668 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4669 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4672 case GFC_INIT_REAL_INF
:
4673 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4674 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4677 case GFC_INIT_REAL_NEG_INF
:
4678 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4679 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4682 case GFC_INIT_REAL_ZERO
:
4683 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4687 gfc_free_expr (init_expr
);
4694 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4695 init_expr
->value
.logical
= 0;
4696 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4697 init_expr
->value
.logical
= 1;
4700 gfc_free_expr (init_expr
);
4706 /* For characters, the length must be constant in order to
4707 create a default initializer. */
4708 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4710 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4712 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4713 init_expr
->value
.character
.length
= char_len
;
4714 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4715 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4716 init_expr
->value
.character
.string
[i
]
4717 = (unsigned char) gfc_option
.flag_init_character_value
;
4721 gfc_free_expr (init_expr
);
4725 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4726 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4728 gfc_actual_arglist
*arg
;
4729 init_expr
= gfc_get_expr ();
4730 init_expr
->where
= *where
;
4731 init_expr
->ts
= *ts
;
4732 init_expr
->expr_type
= EXPR_FUNCTION
;
4733 init_expr
->value
.function
.isym
=
4734 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4735 init_expr
->value
.function
.name
= "repeat";
4736 arg
= gfc_get_actual_arglist ();
4737 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4738 arg
->expr
->value
.character
.string
[0] =
4739 gfc_option
.flag_init_character_value
;
4740 arg
->next
= gfc_get_actual_arglist ();
4741 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4742 init_expr
->value
.function
.actual
= arg
;
4747 gfc_free_expr (init_expr
);
4754 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4755 * require that an expression be built. */
4758 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4760 return gfc_build_init_expr (ts
, where
, false);
4763 /* Apply an initialization expression to a typespec. Can be used for symbols or
4764 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4765 combined with some effort. */
4768 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4770 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4773 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4774 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4776 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4778 if (init
->expr_type
== EXPR_CONSTANT
)
4779 gfc_set_constant_character_len (len
, init
, -1);
4781 && init
->ts
.type
== BT_CHARACTER
4782 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4783 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4784 init
->ts
.u
.cl
->length
->value
.integer
))
4786 gfc_constructor
*ctor
;
4787 ctor
= gfc_constructor_first (init
->value
.constructor
);
4791 bool has_ts
= (init
->ts
.u
.cl
4792 && init
->ts
.u
.cl
->length_from_typespec
);
4794 /* Remember the length of the first element for checking
4795 that all elements *in the constructor* have the same
4796 length. This need not be the length of the LHS! */
4797 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4798 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4799 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4801 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4802 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4804 gfc_set_constant_character_len (len
, ctor
->expr
,
4805 has_ts
? -1 : first_len
);
4806 if (!ctor
->expr
->ts
.u
.cl
)
4808 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4810 ctor
->expr
->ts
.u
.cl
->length
4811 = gfc_copy_expr (ts
->u
.cl
->length
);
4819 /* Check whether an expression is a structure constructor and whether it has
4820 other values than NULL. */
4823 is_non_empty_structure_constructor (gfc_expr
* e
)
4825 if (e
->expr_type
!= EXPR_STRUCTURE
)
4828 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4831 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4833 cons
= gfc_constructor_next (cons
);
4839 /* Check for default initializer; sym->value is not enough
4840 as it is also set for EXPR_NULL of allocatables. */
4843 gfc_has_default_initializer (gfc_symbol
*der
)
4847 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4848 for (c
= der
->components
; c
; c
= c
->next
)
4849 if (gfc_bt_struct (c
->ts
.type
))
4851 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4852 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4854 && is_non_empty_structure_constructor (c
->initializer
))
4855 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4857 if (c
->attr
.pointer
&& c
->initializer
)
4871 Generate an initializer expression which initializes the entirety of a union.
4872 A normal structure constructor is insufficient without undue effort, because
4873 components of maps may be oddly aligned/overlapped. (For example if a
4874 character is initialized from one map overtop a real from the other, only one
4875 byte of the real is actually initialized.) Unfortunately we don't know the
4876 size of the union right now, so we can't generate a proper initializer, but
4877 we use a NULL expr as a placeholder and do the right thing later in
4878 gfc_trans_subcomponent_assign.
4881 generate_union_initializer (gfc_component
*un
)
4883 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4886 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4887 placeholder
->ts
= un
->ts
;
4892 /* Get the user-specified initializer for a union, if any. This means the user
4893 has said to initialize component(s) of a map. For simplicity's sake we
4894 only allow the user to initialize the first map. We don't have to worry
4895 about overlapping initializers as they are released early in resolution (see
4896 resolve_fl_struct). */
4899 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4902 gfc_expr
*init
=NULL
;
4904 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4907 for (map
= union_type
->components
; map
; map
= map
->next
)
4909 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4911 init
= gfc_default_initializer (&map
->ts
);
4925 class_allocatable (gfc_component
*comp
)
4927 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4928 && CLASS_DATA (comp
)->attr
.allocatable
;
4932 class_pointer (gfc_component
*comp
)
4934 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4935 && CLASS_DATA (comp
)->attr
.pointer
;
4939 comp_allocatable (gfc_component
*comp
)
4941 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4945 comp_pointer (gfc_component
*comp
)
4947 return comp
->attr
.pointer
4948 || comp
->attr
.proc_pointer
4949 || comp
->attr
.class_pointer
4950 || class_pointer (comp
);
4953 /* Fetch or generate an initializer for the given component.
4954 Only generate an initializer if generate is true. */
4957 component_initializer (gfc_component
*c
, bool generate
)
4959 gfc_expr
*init
= NULL
;
4961 /* Allocatable components always get EXPR_NULL.
4962 Pointer components are only initialized when generating, and only if they
4963 do not already have an initializer. */
4964 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4966 init
= gfc_get_null_expr (&c
->loc
);
4971 /* See if we can find the initializer immediately. */
4972 if (c
->initializer
|| !generate
)
4973 return c
->initializer
;
4975 /* Recursively handle derived type components. */
4976 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4977 init
= gfc_generate_initializer (&c
->ts
, true);
4979 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4981 gfc_component
*map
= NULL
;
4982 gfc_constructor
*ctor
;
4983 gfc_expr
*user_init
;
4985 /* If we don't have a user initializer and we aren't generating one, this
4986 union has no initializer. */
4987 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4988 if (!user_init
&& !generate
)
4991 /* Otherwise use a structure constructor. */
4992 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4996 /* If we are to generate an initializer for the union, add a constructor
4997 which initializes the whole union first. */
5000 ctor
= gfc_constructor_get ();
5001 ctor
->expr
= generate_union_initializer (c
);
5002 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5005 /* If we found an initializer in one of our maps, apply it. Note this
5006 is applied _after_ the entire-union initializer above if any. */
5009 ctor
= gfc_constructor_get ();
5010 ctor
->expr
= user_init
;
5011 ctor
->n
.component
= map
;
5012 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5016 /* Treat simple components like locals. */
5019 /* We MUST give an initializer, so force generation. */
5020 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
5021 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
5028 /* Get an expression for a default initializer of a derived type. */
5031 gfc_default_initializer (gfc_typespec
*ts
)
5033 return gfc_generate_initializer (ts
, false);
5036 /* Generate an initializer expression for an iso_c_binding type
5037 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
5040 generate_isocbinding_initializer (gfc_symbol
*derived
)
5042 /* The initializers have already been built into the c_null_[fun]ptr symbols
5043 from gen_special_c_interop_ptr. */
5044 gfc_symtree
*npsym
= NULL
;
5045 if (0 == strcmp (derived
->name
, "c_ptr"))
5046 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
5047 else if (0 == strcmp (derived
->name
, "c_funptr"))
5048 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
5050 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
5051 " type, expected %<c_ptr%> or %<c_funptr%>");
5054 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
5055 init
->symtree
= npsym
;
5056 init
->ts
.is_iso_c
= true;
5063 /* Get or generate an expression for a default initializer of a derived type.
5064 If -finit-derived is specified, generate default initialization expressions
5065 for components that lack them when generate is set. */
5068 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
5070 gfc_expr
*init
, *tmp
;
5071 gfc_component
*comp
;
5073 generate
= flag_init_derived
&& generate
;
5075 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
5076 return generate_isocbinding_initializer (ts
->u
.derived
);
5078 /* See if we have a default initializer in this, but not in nested
5079 types (otherwise we could use gfc_has_default_initializer()).
5080 We don't need to check if we are going to generate them. */
5081 comp
= ts
->u
.derived
->components
;
5084 for (; comp
; comp
= comp
->next
)
5085 if (comp
->initializer
|| comp_allocatable (comp
))
5092 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
5093 &ts
->u
.derived
->declared_at
);
5096 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
5098 gfc_constructor
*ctor
= gfc_constructor_get();
5100 /* Fetch or generate an initializer for the component. */
5101 tmp
= component_initializer (comp
, generate
);
5104 /* Save the component ref for STRUCTUREs and UNIONs. */
5105 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
5106 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
5107 ctor
->n
.component
= comp
;
5109 /* If the initializer was not generated, we need a copy. */
5110 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
5111 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
5112 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
5115 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
5121 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5128 /* Given a symbol, create an expression node with that symbol as a
5129 variable. If the symbol is array valued, setup a reference of the
5133 gfc_get_variable_expr (gfc_symtree
*var
)
5137 e
= gfc_get_expr ();
5138 e
->expr_type
= EXPR_VARIABLE
;
5140 e
->ts
= var
->n
.sym
->ts
;
5142 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
5143 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
5144 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
5145 && CLASS_DATA (var
->n
.sym
)->as
)))
5147 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
5148 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
5149 e
->ref
= gfc_get_ref ();
5150 e
->ref
->type
= REF_ARRAY
;
5151 e
->ref
->u
.ar
.type
= AR_FULL
;
5152 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
5153 ? CLASS_DATA (var
->n
.sym
)->as
5161 /* Adds a full array reference to an expression, as needed. */
5164 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
5167 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5172 ref
->next
= gfc_get_ref ();
5177 e
->ref
= gfc_get_ref ();
5180 ref
->type
= REF_ARRAY
;
5181 ref
->u
.ar
.type
= AR_FULL
;
5182 ref
->u
.ar
.dimen
= e
->rank
;
5183 ref
->u
.ar
.where
= e
->where
;
5189 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
5193 lval
= gfc_get_expr ();
5194 lval
->expr_type
= EXPR_VARIABLE
;
5195 lval
->where
= sym
->declared_at
;
5197 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5199 /* It will always be a full array. */
5200 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5201 lval
->rank
= as
? as
->rank
: 0;
5203 gfc_add_full_array_ref (lval
, as
);
5208 /* Returns the array_spec of a full array expression. A NULL is
5209 returned otherwise. */
5211 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
5216 if (expr
->rank
== 0)
5219 /* Follow any component references. */
5220 if (expr
->expr_type
== EXPR_VARIABLE
5221 || expr
->expr_type
== EXPR_CONSTANT
)
5224 as
= expr
->symtree
->n
.sym
->as
;
5228 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5233 as
= ref
->u
.c
.component
->as
;
5242 switch (ref
->u
.ar
.type
)
5265 /* General expression traversal function. */
5268 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5269 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5274 gfc_actual_arglist
*args
;
5281 if ((*func
) (expr
, sym
, &f
))
5284 if (expr
->ts
.type
== BT_CHARACTER
5286 && expr
->ts
.u
.cl
->length
5287 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5288 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5291 switch (expr
->expr_type
)
5296 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5298 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5306 case EXPR_SUBSTRING
:
5309 case EXPR_STRUCTURE
:
5311 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5312 c
; c
= gfc_constructor_next (c
))
5314 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5318 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5320 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5322 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5324 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5331 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5333 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5349 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5351 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5353 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5355 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5361 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5363 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5368 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5369 && ref
->u
.c
.component
->ts
.u
.cl
5370 && ref
->u
.c
.component
->ts
.u
.cl
->length
5371 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5373 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5377 if (ref
->u
.c
.component
->as
)
5378 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5379 + ref
->u
.c
.component
->as
->corank
; i
++)
5381 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5384 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5401 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5404 expr_set_symbols_referenced (gfc_expr
*expr
,
5405 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5406 int *f ATTRIBUTE_UNUSED
)
5408 if (expr
->expr_type
!= EXPR_VARIABLE
)
5410 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5415 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5417 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5421 /* Determine if an expression is a procedure pointer component and return
5422 the component in that case. Otherwise return NULL. */
5425 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5429 if (!expr
|| !expr
->ref
)
5436 if (ref
->type
== REF_COMPONENT
5437 && ref
->u
.c
.component
->attr
.proc_pointer
)
5438 return ref
->u
.c
.component
;
5444 /* Determine if an expression is a procedure pointer component. */
5447 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5449 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5453 /* Determine if an expression is a function with an allocatable class scalar
5456 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5458 if (expr
->expr_type
== EXPR_FUNCTION
5459 && expr
->value
.function
.esym
5460 && expr
->value
.function
.esym
->result
5461 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5462 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5463 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5470 /* Determine if an expression is a function with an allocatable class array
5473 gfc_is_class_array_function (gfc_expr
*expr
)
5475 if (expr
->expr_type
== EXPR_FUNCTION
5476 && expr
->value
.function
.esym
5477 && expr
->value
.function
.esym
->result
5478 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5479 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5480 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5481 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5488 /* Walk an expression tree and check each variable encountered for being typed.
5489 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5490 mode as is a basic arithmetic expression using those; this is for things in
5493 INTEGER :: arr(n), n
5494 INTEGER :: arr(n + 1), n
5496 The namespace is needed for IMPLICIT typing. */
5498 static gfc_namespace
* check_typed_ns
;
5501 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5502 int* f ATTRIBUTE_UNUSED
)
5506 if (e
->expr_type
!= EXPR_VARIABLE
)
5509 gcc_assert (e
->symtree
);
5510 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5517 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5521 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5525 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5526 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5528 if (e
->expr_type
== EXPR_OP
)
5532 gcc_assert (e
->value
.op
.op1
);
5533 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5535 if (t
&& e
->value
.op
.op2
)
5536 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5542 /* Otherwise, walk the expression and do it strictly. */
5543 check_typed_ns
= ns
;
5544 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5546 return error_found
? false : true;
5550 /* This function returns true if it contains any references to PDT KIND
5551 or LEN parameters. */
5554 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5555 int* f ATTRIBUTE_UNUSED
)
5557 if (e
->expr_type
!= EXPR_VARIABLE
)
5560 gcc_assert (e
->symtree
);
5561 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5562 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5570 gfc_derived_parameter_expr (gfc_expr
*e
)
5572 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5576 /* This function returns the overall type of a type parameter spec list.
5577 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5578 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5579 unless derived is not NULL. In this latter case, all the LEN parameters
5580 must be either assumed or deferred for the return argument to be set to
5581 anything other than SPEC_EXPLICIT. */
5584 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5586 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5588 bool seen_assumed
= false;
5589 bool seen_deferred
= false;
5591 if (derived
== NULL
)
5593 for (; param_list
; param_list
= param_list
->next
)
5594 if (param_list
->spec_type
== SPEC_ASSUMED
5595 || param_list
->spec_type
== SPEC_DEFERRED
)
5596 return param_list
->spec_type
;
5600 for (; param_list
; param_list
= param_list
->next
)
5602 c
= gfc_find_component (derived
, param_list
->name
,
5604 gcc_assert (c
!= NULL
);
5605 if (c
->attr
.pdt_kind
)
5607 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5608 return SPEC_EXPLICIT
;
5609 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5610 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5611 if (seen_assumed
&& seen_deferred
)
5612 return SPEC_EXPLICIT
;
5614 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5621 gfc_ref_this_image (gfc_ref
*ref
)
5625 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5627 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5628 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5635 gfc_find_team_co (gfc_expr
*e
)
5639 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5640 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5641 return ref
->u
.ar
.team
;
5643 if (e
->value
.function
.actual
->expr
)
5644 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5646 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5647 return ref
->u
.ar
.team
;
5653 gfc_find_stat_co (gfc_expr
*e
)
5657 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5658 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5659 return ref
->u
.ar
.stat
;
5661 if (e
->value
.function
.actual
->expr
)
5662 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5664 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5665 return ref
->u
.ar
.stat
;
5671 gfc_is_coindexed (gfc_expr
*e
)
5675 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5676 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5677 return !gfc_ref_this_image (ref
);
5683 /* Coarrays are variables with a corank but not being coindexed. However, also
5684 the following is a coarray: A subobject of a coarray is a coarray if it does
5685 not have any cosubscripts, vector subscripts, allocatable component
5686 selection, or pointer component selection. (F2008, 2.4.7) */
5689 gfc_is_coarray (gfc_expr
*e
)
5693 gfc_component
*comp
;
5698 if (e
->expr_type
!= EXPR_VARIABLE
)
5702 sym
= e
->symtree
->n
.sym
;
5704 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5705 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5707 coarray
= sym
->attr
.codimension
;
5709 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5713 comp
= ref
->u
.c
.component
;
5714 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5715 && (CLASS_DATA (comp
)->attr
.class_pointer
5716 || CLASS_DATA (comp
)->attr
.allocatable
))
5719 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5721 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5724 coarray
= comp
->attr
.codimension
;
5732 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5738 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5739 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5751 return coarray
&& !coindexed
;
5756 gfc_get_corank (gfc_expr
*e
)
5761 if (!gfc_is_coarray (e
))
5764 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5765 corank
= e
->ts
.u
.derived
->components
->as
5766 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5768 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5770 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5772 if (ref
->type
== REF_ARRAY
)
5773 corank
= ref
->u
.ar
.as
->corank
;
5774 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5781 /* Check whether the expression has an ultimate allocatable component.
5782 Being itself allocatable does not count. */
5784 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5786 gfc_ref
*ref
, *last
= NULL
;
5788 if (e
->expr_type
!= EXPR_VARIABLE
)
5791 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5792 if (ref
->type
== REF_COMPONENT
)
5795 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5796 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5797 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5798 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5802 if (e
->ts
.type
== BT_CLASS
)
5803 return CLASS_DATA (e
)->attr
.alloc_comp
;
5804 else if (e
->ts
.type
== BT_DERIVED
)
5805 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5811 /* Check whether the expression has an pointer component.
5812 Being itself a pointer does not count. */
5814 gfc_has_ultimate_pointer (gfc_expr
*e
)
5816 gfc_ref
*ref
, *last
= NULL
;
5818 if (e
->expr_type
!= EXPR_VARIABLE
)
5821 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5822 if (ref
->type
== REF_COMPONENT
)
5825 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5826 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5827 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5828 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5832 if (e
->ts
.type
== BT_CLASS
)
5833 return CLASS_DATA (e
)->attr
.pointer_comp
;
5834 else if (e
->ts
.type
== BT_DERIVED
)
5835 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5841 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5842 Note: A scalar is not regarded as "simply contiguous" by the standard.
5843 if bool is not strict, some further checks are done - for instance,
5844 a "(::1)" is accepted. */
5847 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5851 gfc_array_ref
*ar
= NULL
;
5852 gfc_ref
*ref
, *part_ref
= NULL
;
5855 if (expr
->expr_type
== EXPR_ARRAY
)
5858 if (expr
->expr_type
== EXPR_FUNCTION
)
5860 if (expr
->value
.function
.esym
)
5861 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5864 /* Type-bound procedures. */
5865 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5866 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5870 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5871 if (r
->type
== REF_COMPONENT
)
5874 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5875 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5878 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5881 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5884 if (!permit_element
&& expr
->rank
== 0)
5887 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5890 return false; /* Array shall be last part-ref. */
5892 if (ref
->type
== REF_COMPONENT
)
5894 else if (ref
->type
== REF_SUBSTRING
)
5896 else if (ref
->type
== REF_INQUIRY
)
5898 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5902 sym
= expr
->symtree
->n
.sym
;
5903 if (expr
->ts
.type
!= BT_CLASS
5905 && !part_ref
->u
.c
.component
->attr
.contiguous
5906 && part_ref
->u
.c
.component
->attr
.pointer
)
5908 && !sym
->attr
.contiguous
5909 && (sym
->attr
.pointer
5910 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5911 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5914 if (!ar
|| ar
->type
== AR_FULL
)
5917 gcc_assert (ar
->type
== AR_SECTION
);
5919 /* Check for simply contiguous array */
5921 for (i
= 0; i
< ar
->dimen
; i
++)
5923 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5926 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5932 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5935 /* If the previous section was not contiguous, that's an error,
5936 unless we have effective only one element and checking is not
5938 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5939 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5940 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5941 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5942 ar
->end
[i
]->value
.integer
) != 0))
5945 /* Following the standard, "(::1)" or - if known at compile time -
5946 "(lbound:ubound)" are not simply contiguous; if strict
5947 is false, they are regarded as simply contiguous. */
5948 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5949 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5950 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5954 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5955 || !ar
->as
->lower
[i
]
5956 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5957 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5958 ar
->as
->lower
[i
]->value
.integer
) != 0))
5962 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5963 || !ar
->as
->upper
[i
]
5964 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5965 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5966 ar
->as
->upper
[i
]->value
.integer
) != 0))
5973 /* Return true if the expression is guaranteed to be non-contiguous,
5974 false if we cannot prove anything. It is probably best to call
5975 this after gfc_is_simply_contiguous. If neither of them returns
5976 true, we cannot say (at compile-time). */
5979 gfc_is_not_contiguous (gfc_expr
*array
)
5982 gfc_array_ref
*ar
= NULL
;
5984 bool previous_incomplete
;
5986 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
5988 /* Array-ref shall be last ref. */
5990 if (ar
&& ar
->type
!= AR_ELEMENT
)
5993 if (ref
->type
== REF_ARRAY
)
5997 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
6000 previous_incomplete
= false;
6002 /* Check if we can prove that the array is not contiguous. */
6004 for (i
= 0; i
< ar
->dimen
; i
++)
6006 mpz_t arr_size
, ref_size
;
6008 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
6010 if (gfc_dep_difference (ar
->as
->upper
[i
], ar
->as
->lower
[i
], &arr_size
))
6012 /* a(2:4,2:) is known to be non-contiguous, but
6013 a(2:4,i:i) can be contiguous. */
6014 mpz_add_ui (arr_size
, arr_size
, 1L);
6015 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
6017 mpz_clear (arr_size
);
6018 mpz_clear (ref_size
);
6021 else if (mpz_cmp (arr_size
, ref_size
) != 0)
6022 previous_incomplete
= true;
6024 mpz_clear (arr_size
);
6027 /* Check for a(::2), i.e. where the stride is not unity.
6028 This is only done if there is more than one element in
6029 the reference along this dimension. */
6031 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
6032 && ar
->dimen_type
[i
] == DIMEN_RANGE
6033 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
6034 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
6036 mpz_clear (ref_size
);
6040 mpz_clear (ref_size
);
6043 /* We didn't find anything definitive. */
6047 /* Build call to an intrinsic procedure. The number of arguments has to be
6048 passed (rather than ending the list with a NULL value) because we may
6049 want to add arguments but with a NULL-expression. */
6052 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
6053 locus where
, unsigned numarg
, ...)
6056 gfc_actual_arglist
* atail
;
6057 gfc_intrinsic_sym
* isym
;
6060 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
6062 isym
= gfc_intrinsic_function_by_id (id
);
6065 result
= gfc_get_expr ();
6066 result
->expr_type
= EXPR_FUNCTION
;
6067 result
->ts
= isym
->ts
;
6068 result
->where
= where
;
6069 result
->value
.function
.name
= mangled_name
;
6070 result
->value
.function
.isym
= isym
;
6072 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
6073 gfc_commit_symbol (result
->symtree
->n
.sym
);
6074 gcc_assert (result
->symtree
6075 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
6076 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
6077 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
6078 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6079 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
6080 result
->symtree
->n
.sym
->attr
.artificial
= 1;
6082 va_start (ap
, numarg
);
6084 for (i
= 0; i
< numarg
; ++i
)
6088 atail
->next
= gfc_get_actual_arglist ();
6089 atail
= atail
->next
;
6092 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
6094 atail
->expr
= va_arg (ap
, gfc_expr
*);
6102 /* Check if an expression may appear in a variable definition context
6103 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
6104 This is called from the various places when resolving
6105 the pieces that make up such a context.
6106 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
6107 variables), some checks are not performed.
6109 Optionally, a possible error message can be suppressed if context is NULL
6110 and just the return status (true / false) be requested. */
6113 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
6114 bool own_scope
, const char* context
)
6116 gfc_symbol
* sym
= NULL
;
6118 bool check_intentin
;
6120 symbol_attribute attr
;
6124 if (e
->expr_type
== EXPR_VARIABLE
)
6126 gcc_assert (e
->symtree
);
6127 sym
= e
->symtree
->n
.sym
;
6129 else if (e
->expr_type
== EXPR_FUNCTION
)
6131 gcc_assert (e
->symtree
);
6132 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
6135 attr
= gfc_expr_attr (e
);
6136 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
6138 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
6141 gfc_error ("Fortran 2008: Pointer functions in variable definition"
6142 " context (%s) at %L", context
, &e
->where
);
6146 else if (e
->expr_type
!= EXPR_VARIABLE
)
6149 gfc_error ("Non-variable expression in variable definition context (%s)"
6150 " at %L", context
, &e
->where
);
6154 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
6157 gfc_error ("Named constant %qs in variable definition context (%s)"
6158 " at %L", sym
->name
, context
, &e
->where
);
6161 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
6162 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
6163 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
)
6164 && !(sym
->attr
.flavor
== FL_PROCEDURE
6165 && sym
->attr
.function
&& sym
->attr
.pointer
))
6168 gfc_error ("%qs in variable definition context (%s) at %L is not"
6169 " a variable", sym
->name
, context
, &e
->where
);
6173 /* Find out whether the expr is a pointer; this also means following
6174 component references to the last one. */
6175 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
6176 if (pointer
&& !is_pointer
)
6179 gfc_error ("Non-POINTER in pointer association context (%s)"
6180 " at %L", context
, &e
->where
);
6184 if (e
->ts
.type
== BT_DERIVED
6185 && e
->ts
.u
.derived
== NULL
)
6188 gfc_error ("Type inaccessible in variable definition context (%s) "
6189 "at %L", context
, &e
->where
);
6196 || (e
->ts
.type
== BT_DERIVED
6197 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6198 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
6201 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6202 context
, &e
->where
);
6206 /* TS18508, C702/C203. */
6209 || (e
->ts
.type
== BT_DERIVED
6210 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6211 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
6214 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6215 context
, &e
->where
);
6219 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6220 component of sub-component of a pointer; we need to distinguish
6221 assignment to a pointer component from pointer-assignment to a pointer
6222 component. Note that (normal) assignment to procedure pointers is not
6224 check_intentin
= !own_scope
;
6225 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
6226 && CLASS_DATA (sym
))
6227 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
6228 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
6230 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
6231 check_intentin
= false;
6232 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
6234 ptr_component
= true;
6236 check_intentin
= false;
6238 if (ref
->type
== REF_INQUIRY
6239 && (ref
->u
.i
== INQUIRY_KIND
|| ref
->u
.i
== INQUIRY_LEN
))
6242 gfc_error ("%qs parameter inquiry for %qs in "
6243 "variable definition context (%s) at %L",
6244 ref
->u
.i
== INQUIRY_KIND
? "KIND" : "LEN",
6245 sym
->name
, context
, &e
->where
);
6251 && (sym
->attr
.intent
== INTENT_IN
6252 || (sym
->attr
.select_type_temporary
&& sym
->assoc
6253 && sym
->assoc
->target
&& sym
->assoc
->target
->symtree
6254 && sym
->assoc
->target
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)))
6256 if (pointer
&& is_pointer
)
6259 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6260 " association context (%s) at %L",
6261 sym
->name
, context
, &e
->where
);
6264 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
6266 const char *name
= sym
->attr
.select_type_temporary
6267 ? sym
->assoc
->target
->symtree
->name
: sym
->name
;
6269 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6270 " definition context (%s) at %L",
6271 name
, context
, &e
->where
);
6276 /* PROTECTED and use-associated. */
6277 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
6279 if (pointer
&& is_pointer
)
6282 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6283 " pointer association context (%s) at %L",
6284 sym
->name
, context
, &e
->where
);
6287 if (!pointer
&& !is_pointer
)
6290 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6291 " variable definition context (%s) at %L",
6292 sym
->name
, context
, &e
->where
);
6297 /* Variable not assignable from a PURE procedure but appears in
6298 variable definition context. */
6299 own_scope
= own_scope
6300 || (sym
->attr
.result
&& sym
->ns
->proc_name
6301 && sym
== sym
->ns
->proc_name
->result
);
6302 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6305 gfc_error ("Variable %qs cannot appear in a variable definition"
6306 " context (%s) at %L in PURE procedure",
6307 sym
->name
, context
, &e
->where
);
6311 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6312 && gfc_impure_variable (sym
))
6317 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6319 sym
= ns
->proc_name
;
6322 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6324 sym
->attr
.implicit_pure
= 0;
6329 /* Check variable definition context for associate-names. */
6330 if (!pointer
&& sym
->assoc
&& !sym
->attr
.select_rank_temporary
)
6333 gfc_association_list
* assoc
;
6335 gcc_assert (sym
->assoc
->target
);
6337 /* If this is a SELECT TYPE temporary (the association is used internally
6338 for SELECT TYPE), silently go over to the target. */
6339 if (sym
->attr
.select_type_temporary
)
6341 gfc_expr
* t
= sym
->assoc
->target
;
6343 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6344 name
= t
->symtree
->name
;
6346 if (t
->symtree
->n
.sym
->assoc
)
6347 assoc
= t
->symtree
->n
.sym
->assoc
;
6356 gcc_assert (name
&& assoc
);
6358 /* Is association to a valid variable? */
6359 if (!assoc
->variable
)
6363 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6364 gfc_error ("%qs at %L associated to vector-indexed target"
6365 " cannot be used in a variable definition"
6367 name
, &e
->where
, context
);
6369 gfc_error ("%qs at %L associated to expression"
6370 " cannot be used in a variable definition"
6372 name
, &e
->where
, context
);
6377 /* Target must be allowed to appear in a variable definition context. */
6378 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6381 gfc_error ("Associate-name %qs cannot appear in a variable"
6382 " definition context (%s) at %L because its target"
6383 " at %L cannot, either",
6384 name
, context
, &e
->where
,
6385 &assoc
->target
->where
);
6390 /* Check for same value in vector expression subscript. */
6393 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6394 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6395 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6396 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6397 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6399 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6400 if (arr
->expr_type
== EXPR_ARRAY
)
6402 gfc_constructor
*c
, *n
;
6405 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6406 c
!= NULL
; c
= gfc_constructor_next (c
))
6408 if (c
== NULL
|| c
->iterator
!= NULL
)
6413 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6414 n
= gfc_constructor_next (n
))
6416 if (n
->iterator
!= NULL
)
6420 if (gfc_dep_compare_expr (ec
, en
) == 0)
6423 gfc_error_now ("Elements with the same value "
6424 "at %L and %L in vector "
6425 "subscript in a variable "
6426 "definition context (%s)",
6427 &(ec
->where
), &(en
->where
),