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 /* Determine if an expression is constant in the sense of F08:7.1.12.
994 * This function expects that the expression has already been simplified. */
997 gfc_is_constant_expr (gfc_expr
*e
)
1000 gfc_actual_arglist
*arg
;
1005 switch (e
->expr_type
)
1008 return (gfc_is_constant_expr (e
->value
.op
.op1
)
1009 && (e
->value
.op
.op2
== NULL
1010 || gfc_is_constant_expr (e
->value
.op
.op2
)));
1013 /* The only context in which this can occur is in a parameterized
1014 derived type declaration, so returning true is OK. */
1015 if (e
->symtree
->n
.sym
->attr
.pdt_len
1016 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1023 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1024 || e
->value
.function
.isym
);
1026 /* Call to intrinsic with at least one argument. */
1027 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1029 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1030 if (!gfc_is_constant_expr (arg
->expr
))
1034 if (e
->value
.function
.isym
1035 && (e
->value
.function
.isym
->elemental
1036 || e
->value
.function
.isym
->pure
1037 || e
->value
.function
.isym
->inquiry
1038 || e
->value
.function
.isym
->transformational
))
1047 case EXPR_SUBSTRING
:
1048 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1049 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1052 case EXPR_STRUCTURE
:
1053 c
= gfc_constructor_first (e
->value
.constructor
);
1054 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1055 return gfc_constant_ac (e
);
1057 for (; c
; c
= gfc_constructor_next (c
))
1058 if (!gfc_is_constant_expr (c
->expr
))
1065 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1071 /* Is true if the expression or symbol is a passed CFI descriptor. */
1073 is_CFI_desc (gfc_symbol
*sym
, gfc_expr
*e
)
1076 && e
&& e
->expr_type
== EXPR_VARIABLE
)
1077 sym
= e
->symtree
->n
.sym
;
1079 if (sym
&& sym
->attr
.dummy
1080 && sym
->ns
->proc_name
->attr
.is_bind_c
1081 && sym
->attr
.dimension
1082 && (sym
->attr
.pointer
1083 || sym
->attr
.allocatable
1084 || sym
->as
->type
== AS_ASSUMED_SHAPE
1085 || sym
->as
->type
== AS_ASSUMED_RANK
))
1092 /* Is true if an array reference is followed by a component or substring
1095 is_subref_array (gfc_expr
* e
)
1101 if (e
->expr_type
!= EXPR_VARIABLE
)
1104 sym
= e
->symtree
->n
.sym
;
1106 if (sym
->attr
.subref_array_pointer
)
1111 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1113 /* If we haven't seen the array reference and this is an intrinsic,
1114 what follows cannot be a subreference array, unless there is a
1115 substring reference. */
1116 if (!seen_array
&& ref
->type
== REF_COMPONENT
1117 && ref
->u
.c
.component
->ts
.type
!= BT_CHARACTER
1118 && ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1119 && !gfc_bt_struct (ref
->u
.c
.component
->ts
.type
))
1122 if (ref
->type
== REF_ARRAY
1123 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1127 && ref
->type
!= REF_ARRAY
)
1131 if (sym
->ts
.type
== BT_CLASS
1133 && CLASS_DATA (sym
)->attr
.dimension
1134 && CLASS_DATA (sym
)->attr
.class_pointer
)
1141 /* Try to collapse intrinsic expressions. */
1144 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1146 gfc_intrinsic_op op
;
1147 gfc_expr
*op1
, *op2
, *result
;
1149 if (p
->value
.op
.op
== INTRINSIC_USER
)
1152 op1
= p
->value
.op
.op1
;
1153 op2
= p
->value
.op
.op2
;
1154 op
= p
->value
.op
.op
;
1156 if (!gfc_simplify_expr (op1
, type
))
1158 if (!gfc_simplify_expr (op2
, type
))
1161 if (!gfc_is_constant_expr (op1
)
1162 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1166 p
->value
.op
.op1
= NULL
;
1167 p
->value
.op
.op2
= NULL
;
1171 case INTRINSIC_PARENTHESES
:
1172 result
= gfc_parentheses (op1
);
1175 case INTRINSIC_UPLUS
:
1176 result
= gfc_uplus (op1
);
1179 case INTRINSIC_UMINUS
:
1180 result
= gfc_uminus (op1
);
1183 case INTRINSIC_PLUS
:
1184 result
= gfc_add (op1
, op2
);
1187 case INTRINSIC_MINUS
:
1188 result
= gfc_subtract (op1
, op2
);
1191 case INTRINSIC_TIMES
:
1192 result
= gfc_multiply (op1
, op2
);
1195 case INTRINSIC_DIVIDE
:
1196 result
= gfc_divide (op1
, op2
);
1199 case INTRINSIC_POWER
:
1200 result
= gfc_power (op1
, op2
);
1203 case INTRINSIC_CONCAT
:
1204 result
= gfc_concat (op1
, op2
);
1208 case INTRINSIC_EQ_OS
:
1209 result
= gfc_eq (op1
, op2
, op
);
1213 case INTRINSIC_NE_OS
:
1214 result
= gfc_ne (op1
, op2
, op
);
1218 case INTRINSIC_GT_OS
:
1219 result
= gfc_gt (op1
, op2
, op
);
1223 case INTRINSIC_GE_OS
:
1224 result
= gfc_ge (op1
, op2
, op
);
1228 case INTRINSIC_LT_OS
:
1229 result
= gfc_lt (op1
, op2
, op
);
1233 case INTRINSIC_LE_OS
:
1234 result
= gfc_le (op1
, op2
, op
);
1238 result
= gfc_not (op1
);
1242 result
= gfc_and (op1
, op2
);
1246 result
= gfc_or (op1
, op2
);
1250 result
= gfc_eqv (op1
, op2
);
1253 case INTRINSIC_NEQV
:
1254 result
= gfc_neqv (op1
, op2
);
1258 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1263 gfc_free_expr (op1
);
1264 gfc_free_expr (op2
);
1268 result
->rank
= p
->rank
;
1269 result
->where
= p
->where
;
1270 gfc_replace_expr (p
, result
);
1276 /* Subroutine to simplify constructor expressions. Mutually recursive
1277 with gfc_simplify_expr(). */
1280 simplify_constructor (gfc_constructor_base base
, int type
)
1285 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1288 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1289 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1290 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1295 /* Try and simplify a copy. Replace the original if successful
1296 but keep going through the constructor at all costs. Not
1297 doing so can make a dog's dinner of complicated things. */
1298 p
= gfc_copy_expr (c
->expr
);
1300 if (!gfc_simplify_expr (p
, type
))
1306 gfc_replace_expr (c
->expr
, p
);
1314 /* Pull a single array element out of an array constructor. */
1317 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1318 gfc_constructor
**rval
)
1320 unsigned long nelemen
;
1326 gfc_constructor
*cons
;
1333 mpz_init_set_ui (offset
, 0);
1336 mpz_init_set_ui (span
, 1);
1337 for (i
= 0; i
< ar
->dimen
; i
++)
1339 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1340 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1348 if (e
->expr_type
!= EXPR_CONSTANT
)
1354 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1355 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1357 /* Check the bounds. */
1358 if ((ar
->as
->upper
[i
]
1359 && mpz_cmp (e
->value
.integer
,
1360 ar
->as
->upper
[i
]->value
.integer
) > 0)
1361 || (mpz_cmp (e
->value
.integer
,
1362 ar
->as
->lower
[i
]->value
.integer
) < 0))
1364 gfc_error ("Index in dimension %d is out of bounds "
1365 "at %L", i
+ 1, &ar
->c_where
[i
]);
1371 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1372 mpz_mul (delta
, delta
, span
);
1373 mpz_add (offset
, offset
, delta
);
1375 mpz_set_ui (tmp
, 1);
1376 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1377 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1378 mpz_mul (span
, span
, tmp
);
1381 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1382 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1401 /* Find a component of a structure constructor. */
1403 static gfc_constructor
*
1404 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1406 gfc_component
*pick
= ref
->u
.c
.component
;
1407 gfc_constructor
*c
= gfc_constructor_first (base
);
1409 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1410 int ext
= dt
->attr
.extension
;
1412 /* For extended types, check if the desired component is in one of the
1414 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1415 pick
->name
, true, true, NULL
))
1417 dt
= dt
->components
->ts
.u
.derived
;
1418 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1422 gfc_component
*comp
= dt
->components
;
1423 while (comp
!= pick
)
1426 c
= gfc_constructor_next (c
);
1433 /* Replace an expression with the contents of a constructor, removing
1434 the subobject reference in the process. */
1437 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1447 e
= gfc_copy_expr (p
);
1448 e
->ref
= p
->ref
->next
;
1449 p
->ref
->next
= NULL
;
1450 gfc_replace_expr (p
, e
);
1454 /* Pull an array section out of an array constructor. */
1457 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1464 long unsigned one
= 1;
1466 mpz_t start
[GFC_MAX_DIMENSIONS
];
1467 mpz_t end
[GFC_MAX_DIMENSIONS
];
1468 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1469 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1470 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1475 gfc_constructor_base base
;
1476 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1486 base
= expr
->value
.constructor
;
1487 expr
->value
.constructor
= NULL
;
1489 rank
= ref
->u
.ar
.as
->rank
;
1491 if (expr
->shape
== NULL
)
1492 expr
->shape
= gfc_get_shape (rank
);
1494 mpz_init_set_ui (delta_mpz
, one
);
1495 mpz_init_set_ui (nelts
, one
);
1498 /* Do the initialization now, so that we can cleanup without
1499 keeping track of where we were. */
1500 for (d
= 0; d
< rank
; d
++)
1502 mpz_init (delta
[d
]);
1503 mpz_init (start
[d
]);
1506 mpz_init (stride
[d
]);
1510 /* Build the counters to clock through the array reference. */
1512 for (d
= 0; d
< rank
; d
++)
1514 /* Make this stretch of code easier on the eye! */
1515 begin
= ref
->u
.ar
.start
[d
];
1516 finish
= ref
->u
.ar
.end
[d
];
1517 step
= ref
->u
.ar
.stride
[d
];
1518 lower
= ref
->u
.ar
.as
->lower
[d
];
1519 upper
= ref
->u
.ar
.as
->upper
[d
];
1521 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1523 gfc_constructor
*ci
;
1526 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1532 gcc_assert (begin
->rank
== 1);
1533 /* Zero-sized arrays have no shape and no elements, stop early. */
1536 mpz_init_set_ui (nelts
, 0);
1540 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1541 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1542 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1543 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1546 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1548 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1549 || mpz_cmp (ci
->expr
->value
.integer
,
1550 lower
->value
.integer
) < 0)
1552 gfc_error ("index in dimension %d is out of bounds "
1553 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1561 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1562 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1563 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1569 /* Obtain the stride. */
1571 mpz_set (stride
[d
], step
->value
.integer
);
1573 mpz_set_ui (stride
[d
], one
);
1575 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1576 mpz_set_ui (stride
[d
], one
);
1578 /* Obtain the start value for the index. */
1580 mpz_set (start
[d
], begin
->value
.integer
);
1582 mpz_set (start
[d
], lower
->value
.integer
);
1584 mpz_set (ctr
[d
], start
[d
]);
1586 /* Obtain the end value for the index. */
1588 mpz_set (end
[d
], finish
->value
.integer
);
1590 mpz_set (end
[d
], upper
->value
.integer
);
1592 /* Separate 'if' because elements sometimes arrive with
1594 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1595 mpz_set (end
[d
], begin
->value
.integer
);
1597 /* Check the bounds. */
1598 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1599 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1600 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1601 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1603 gfc_error ("index in dimension %d is out of bounds "
1604 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1609 /* Calculate the number of elements and the shape. */
1610 mpz_set (tmp_mpz
, stride
[d
]);
1611 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1612 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1613 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1614 mpz_mul (nelts
, nelts
, tmp_mpz
);
1616 /* An element reference reduces the rank of the expression; don't
1617 add anything to the shape array. */
1618 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1619 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1622 /* Calculate the 'stride' (=delta) for conversion of the
1623 counter values into the index along the constructor. */
1624 mpz_set (delta
[d
], delta_mpz
);
1625 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1626 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1627 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1631 cons
= gfc_constructor_first (base
);
1633 /* Now clock through the array reference, calculating the index in
1634 the source constructor and transferring the elements to the new
1636 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1638 mpz_init_set_ui (ptr
, 0);
1641 for (d
= 0; d
< rank
; d
++)
1643 mpz_set (tmp_mpz
, ctr
[d
]);
1644 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1645 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1646 mpz_add (ptr
, ptr
, tmp_mpz
);
1648 if (!incr_ctr
) continue;
1650 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1652 gcc_assert(vecsub
[d
]);
1654 if (!gfc_constructor_next (vecsub
[d
]))
1655 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1658 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1661 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1665 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1667 if (mpz_cmp_ui (stride
[d
], 0) > 0
1668 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1669 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1670 mpz_set (ctr
[d
], start
[d
]);
1676 limit
= mpz_get_ui (ptr
);
1677 if (limit
>= flag_max_array_constructor
)
1679 gfc_error ("The number of elements in the array constructor "
1680 "at %L requires an increase of the allowed %d "
1681 "upper limit. See %<-fmax-array-constructor%> "
1682 "option", &expr
->where
, flag_max_array_constructor
);
1686 cons
= gfc_constructor_lookup (base
, limit
);
1688 gfc_constructor_append_expr (&expr
->value
.constructor
,
1689 gfc_copy_expr (cons
->expr
), NULL
);
1696 mpz_clear (delta_mpz
);
1697 mpz_clear (tmp_mpz
);
1699 for (d
= 0; d
< rank
; d
++)
1701 mpz_clear (delta
[d
]);
1702 mpz_clear (start
[d
]);
1705 mpz_clear (stride
[d
]);
1707 gfc_constructor_free (base
);
1711 /* Pull a substring out of an expression. */
1714 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1717 gfc_charlen_t start
;
1718 gfc_charlen_t length
;
1721 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1722 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1725 *newp
= gfc_copy_expr (p
);
1726 free ((*newp
)->value
.character
.string
);
1728 end
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1729 start
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1731 length
= end
- start
+ 1;
1735 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1736 (*newp
)->value
.character
.length
= length
;
1737 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1738 length
* sizeof (gfc_char_t
));
1744 /* Pull an inquiry result out of an expression. */
1747 find_inquiry_ref (gfc_expr
*p
, gfc_expr
**newp
)
1750 gfc_ref
*inquiry
= NULL
;
1753 tmp
= gfc_copy_expr (p
);
1755 if (tmp
->ref
&& tmp
->ref
->type
== REF_INQUIRY
)
1762 for (ref
= tmp
->ref
; ref
; ref
= ref
->next
)
1763 if (ref
->next
&& ref
->next
->type
== REF_INQUIRY
)
1765 inquiry
= ref
->next
;
1772 gfc_free_expr (tmp
);
1776 gfc_resolve_expr (tmp
);
1778 /* In principle there can be more than one inquiry reference. */
1779 for (; inquiry
; inquiry
= inquiry
->next
)
1781 switch (inquiry
->u
.i
)
1784 if (tmp
->ts
.type
!= BT_CHARACTER
)
1787 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1790 if (tmp
->ts
.u
.cl
->length
1791 && tmp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1792 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1793 else if (tmp
->expr_type
== EXPR_CONSTANT
)
1794 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1795 NULL
, tmp
->value
.character
.length
);
1802 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1805 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1808 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1809 NULL
, tmp
->ts
.kind
);
1813 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1816 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1819 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1820 mpfr_set ((*newp
)->value
.real
,
1821 mpc_realref (tmp
->value
.complex), GFC_RND_MODE
);
1825 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1828 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1831 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1832 mpfr_set ((*newp
)->value
.real
,
1833 mpc_imagref (tmp
->value
.complex), GFC_RND_MODE
);
1836 tmp
= gfc_copy_expr (*newp
);
1841 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1843 gfc_free_expr (*newp
);
1847 gfc_free_expr (tmp
);
1851 gfc_free_expr (tmp
);
1857 /* Simplify a subobject reference of a constructor. This occurs when
1858 parameter variable values are substituted. */
1861 simplify_const_ref (gfc_expr
*p
)
1863 gfc_constructor
*cons
, *c
;
1864 gfc_expr
*newp
= NULL
;
1869 switch (p
->ref
->type
)
1872 switch (p
->ref
->u
.ar
.type
)
1875 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1876 will generate this. */
1877 if (p
->expr_type
!= EXPR_ARRAY
)
1879 remove_subobject_ref (p
, NULL
);
1882 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1888 remove_subobject_ref (p
, cons
);
1892 if (!find_array_section (p
, p
->ref
))
1894 p
->ref
->u
.ar
.type
= AR_FULL
;
1899 if (p
->ref
->next
!= NULL
1900 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1902 for (c
= gfc_constructor_first (p
->value
.constructor
);
1903 c
; c
= gfc_constructor_next (c
))
1905 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1906 if (!simplify_const_ref (c
->expr
))
1910 if (gfc_bt_struct (p
->ts
.type
)
1912 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1914 /* There may have been component references. */
1915 p
->ts
= c
->expr
->ts
;
1919 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1921 if (p
->ts
.type
== BT_CHARACTER
1922 && last_ref
->type
== REF_SUBSTRING
)
1924 /* If this is a CHARACTER array and we possibly took
1925 a substring out of it, update the type-spec's
1926 character length according to the first element
1927 (as all should have the same length). */
1928 gfc_charlen_t string_len
;
1929 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1931 const gfc_expr
* first
= c
->expr
;
1932 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1933 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1934 string_len
= first
->value
.character
.length
;
1942 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1945 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
,
1949 gfc_free_expr (p
->ts
.u
.cl
->length
);
1952 = gfc_get_int_expr (gfc_charlen_int_kind
,
1956 gfc_free_ref_list (p
->ref
);
1967 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1968 remove_subobject_ref (p
, cons
);
1972 if (!find_inquiry_ref (p
, &newp
))
1975 gfc_replace_expr (p
, newp
);
1976 gfc_free_ref_list (p
->ref
);
1981 if (!find_substring_ref (p
, &newp
))
1984 gfc_replace_expr (p
, newp
);
1985 gfc_free_ref_list (p
->ref
);
1995 /* Simplify a chain of references. */
1998 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
2003 for (; ref
; ref
= ref
->next
)
2008 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2010 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
2012 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
2014 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
2020 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
2022 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
2027 if (!find_inquiry_ref (*p
, &newp
))
2030 gfc_replace_expr (*p
, newp
);
2031 gfc_free_ref_list ((*p
)->ref
);
2043 /* Try to substitute the value of a parameter variable. */
2046 simplify_parameter_variable (gfc_expr
*p
, int type
)
2051 /* Set rank and check array ref; as resolve_variable calls
2052 gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
2053 if (!gfc_resolve_ref (p
))
2058 gfc_expression_rank (p
);
2060 /* Is this an inquiry? */
2061 bool inquiry
= false;
2062 gfc_ref
* ref
= p
->ref
;
2065 if (ref
->type
== REF_INQUIRY
)
2069 if (ref
&& ref
->type
== REF_INQUIRY
)
2070 inquiry
= ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
;
2072 if (gfc_is_size_zero_array (p
))
2074 if (p
->expr_type
== EXPR_ARRAY
)
2077 e
= gfc_get_expr ();
2078 e
->expr_type
= EXPR_ARRAY
;
2081 e
->value
.constructor
= NULL
;
2082 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2083 e
->where
= p
->where
;
2084 /* If %kind and %len are not used then we're done, otherwise
2085 drop through for simplification. */
2088 gfc_replace_expr (p
, e
);
2094 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2100 if (e
->ts
.type
== BT_CHARACTER
&& p
->ts
.u
.cl
)
2104 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
)
2105 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, p
->ts
.u
.cl
);
2107 /* Do not copy subobject refs for constant. */
2108 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2109 e
->ref
= gfc_copy_ref (p
->ref
);
2110 t
= gfc_simplify_expr (e
, type
);
2111 e
->where
= p
->where
;
2113 /* Only use the simplification if it eliminated all subobject references. */
2115 gfc_replace_expr (p
, e
);
2124 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2126 /* Given an expression, simplify it by collapsing constant
2127 expressions. Most simplification takes place when the expression
2128 tree is being constructed. If an intrinsic function is simplified
2129 at some point, we get called again to collapse the result against
2132 We work by recursively simplifying expression nodes, simplifying
2133 intrinsic functions where possible, which can lead to further
2134 constant collapsing. If an operator has constant operand(s), we
2135 rip the expression apart, and rebuild it, hoping that it becomes
2138 The expression type is defined for:
2139 0 Basic expression parsing
2140 1 Simplifying array constructors -- will substitute
2142 Returns false on error, true otherwise.
2143 NOTE: Will return true even if the expression cannot be simplified. */
2146 gfc_simplify_expr (gfc_expr
*p
, int type
)
2148 gfc_actual_arglist
*ap
;
2149 gfc_intrinsic_sym
* isym
= NULL
;
2155 switch (p
->expr_type
)
2158 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2159 simplify_ref_chain (p
->ref
, type
, &p
);
2165 // For array-bound functions, we don't need to optimize
2166 // the 'array' argument. In particular, if the argument
2167 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2168 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2169 // can have any lbound.
2170 ap
= p
->value
.function
.actual
;
2171 if (p
->value
.function
.isym
&&
2172 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2173 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2174 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2175 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
))
2178 for ( ; ap
; ap
= ap
->next
)
2179 if (!gfc_simplify_expr (ap
->expr
, type
))
2182 if (p
->value
.function
.isym
!= NULL
2183 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2186 if (p
->expr_type
== EXPR_FUNCTION
)
2189 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2190 if (isym
&& isym
->elemental
)
2191 scalarize_intrinsic_call (p
, false);
2196 case EXPR_SUBSTRING
:
2197 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2200 if (gfc_is_constant_expr (p
))
2203 HOST_WIDE_INT start
, end
;
2206 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2208 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2209 start
--; /* Convert from one-based to zero-based. */
2212 end
= p
->value
.character
.length
;
2213 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2214 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2219 s
= gfc_get_wide_string (end
- start
+ 2);
2220 memcpy (s
, p
->value
.character
.string
+ start
,
2221 (end
- start
) * sizeof (gfc_char_t
));
2222 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2223 free (p
->value
.character
.string
);
2224 p
->value
.character
.string
= s
;
2225 p
->value
.character
.length
= end
- start
;
2226 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2227 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2229 p
->value
.character
.length
);
2230 gfc_free_ref_list (p
->ref
);
2232 p
->expr_type
= EXPR_CONSTANT
;
2237 if (!simplify_intrinsic_op (p
, type
))
2242 /* Only substitute array parameter variables if we are in an
2243 initialization expression, or we want a subsection. */
2244 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2245 && (gfc_init_expr_flag
|| p
->ref
2246 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2248 if (!simplify_parameter_variable (p
, type
))
2255 gfc_simplify_iterator_var (p
);
2258 /* Simplify subcomponent references. */
2259 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2264 case EXPR_STRUCTURE
:
2266 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2269 /* If the following conditions hold, we found something like kind type
2270 inquiry of the form a(2)%kind while simplify the ref chain. */
2271 if (p
->expr_type
== EXPR_CONSTANT
&& !p
->ref
&& !p
->rank
&& !p
->shape
)
2274 if (!simplify_constructor (p
->value
.constructor
, type
))
2277 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2278 && p
->ref
->u
.ar
.type
== AR_FULL
)
2279 gfc_expand_constructor (p
, false);
2281 if (!simplify_const_ref (p
))
2298 /* Returns the type of an expression with the exception that iterator
2299 variables are automatically integers no matter what else they may
2305 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2312 /* Scalarize an expression for an elemental intrinsic call. */
2315 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2317 gfc_actual_arglist
*a
, *b
;
2318 gfc_constructor_base ctor
;
2319 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2320 gfc_constructor
*ci
, *new_ctor
;
2321 gfc_expr
*expr
, *old
, *p
;
2322 int n
, i
, rank
[5], array_arg
;
2327 a
= e
->value
.function
.actual
;
2328 for (; a
; a
= a
->next
)
2329 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2332 /* Find which, if any, arguments are arrays. Assume that the old
2333 expression carries the type information and that the first arg
2334 that is an array expression carries all the shape information.*/
2336 a
= e
->value
.function
.actual
;
2337 for (; a
; a
= a
->next
)
2340 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2343 expr
= gfc_copy_expr (a
->expr
);
2350 old
= gfc_copy_expr (e
);
2352 gfc_constructor_free (expr
->value
.constructor
);
2353 expr
->value
.constructor
= NULL
;
2355 expr
->where
= old
->where
;
2356 expr
->expr_type
= EXPR_ARRAY
;
2358 /* Copy the array argument constructors into an array, with nulls
2361 a
= old
->value
.function
.actual
;
2362 for (; a
; a
= a
->next
)
2364 /* Check that this is OK for an initialization expression. */
2365 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2369 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2371 rank
[n
] = a
->expr
->rank
;
2372 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2373 args
[n
] = gfc_constructor_first (ctor
);
2375 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2378 rank
[n
] = a
->expr
->rank
;
2381 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2382 args
[n
] = gfc_constructor_first (ctor
);
2390 /* Using the array argument as the master, step through the array
2391 calling the function for each element and advancing the array
2392 constructors together. */
2393 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2395 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2396 gfc_copy_expr (old
), NULL
);
2398 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2400 b
= old
->value
.function
.actual
;
2401 for (i
= 0; i
< n
; i
++)
2404 new_ctor
->expr
->value
.function
.actual
2405 = a
= gfc_get_actual_arglist ();
2408 a
->next
= gfc_get_actual_arglist ();
2413 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2415 a
->expr
= gfc_copy_expr (b
->expr
);
2420 /* Simplify the function calls. If the simplification fails, the
2421 error will be flagged up down-stream or the library will deal
2423 p
= gfc_copy_expr (new_ctor
->expr
);
2425 if (!gfc_simplify_expr (p
, init_flag
))
2428 gfc_replace_expr (new_ctor
->expr
, p
);
2430 for (i
= 0; i
< n
; i
++)
2432 args
[i
] = gfc_constructor_next (args
[i
]);
2434 for (i
= 1; i
< n
; i
++)
2435 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2436 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2442 /* Free "expr" but not the pointers it contains. */
2444 gfc_free_expr (old
);
2448 gfc_error_now ("elemental function arguments at %C are not compliant");
2451 gfc_free_expr (expr
);
2452 gfc_free_expr (old
);
2458 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2460 gfc_expr
*op1
= e
->value
.op
.op1
;
2461 gfc_expr
*op2
= e
->value
.op
.op2
;
2463 if (!(*check_function
)(op1
))
2466 switch (e
->value
.op
.op
)
2468 case INTRINSIC_UPLUS
:
2469 case INTRINSIC_UMINUS
:
2470 if (!numeric_type (et0 (op1
)))
2475 case INTRINSIC_EQ_OS
:
2477 case INTRINSIC_NE_OS
:
2479 case INTRINSIC_GT_OS
:
2481 case INTRINSIC_GE_OS
:
2483 case INTRINSIC_LT_OS
:
2485 case INTRINSIC_LE_OS
:
2486 if (!(*check_function
)(op2
))
2489 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2490 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2492 gfc_error ("Numeric or CHARACTER operands are required in "
2493 "expression at %L", &e
->where
);
2498 case INTRINSIC_PLUS
:
2499 case INTRINSIC_MINUS
:
2500 case INTRINSIC_TIMES
:
2501 case INTRINSIC_DIVIDE
:
2502 case INTRINSIC_POWER
:
2503 if (!(*check_function
)(op2
))
2506 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2511 case INTRINSIC_CONCAT
:
2512 if (!(*check_function
)(op2
))
2515 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2517 gfc_error ("Concatenation operator in expression at %L "
2518 "must have two CHARACTER operands", &op1
->where
);
2522 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2524 gfc_error ("Concat operator at %L must concatenate strings of the "
2525 "same kind", &e
->where
);
2532 if (et0 (op1
) != BT_LOGICAL
)
2534 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2535 "operand", &op1
->where
);
2544 case INTRINSIC_NEQV
:
2545 if (!(*check_function
)(op2
))
2548 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2550 gfc_error ("LOGICAL operands are required in expression at %L",
2557 case INTRINSIC_PARENTHESES
:
2561 gfc_error ("Only intrinsic operators can be used in expression at %L",
2569 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2574 /* F2003, 7.1.7 (3): In init expression, allocatable components
2575 must not be data-initialized. */
2577 check_alloc_comp_init (gfc_expr
*e
)
2579 gfc_component
*comp
;
2580 gfc_constructor
*ctor
;
2582 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2583 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2585 for (comp
= e
->ts
.u
.derived
->components
,
2586 ctor
= gfc_constructor_first (e
->value
.constructor
);
2587 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2589 if (comp
->attr
.allocatable
&& ctor
->expr
2590 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2592 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2593 "component %qs in structure constructor at %L",
2594 comp
->name
, &ctor
->expr
->where
);
2603 check_init_expr_arguments (gfc_expr
*e
)
2605 gfc_actual_arglist
*ap
;
2607 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2608 if (!gfc_check_init_expr (ap
->expr
))
2614 static bool check_restricted (gfc_expr
*);
2616 /* F95, 7.1.6.1, Initialization expressions, (7)
2617 F2003, 7.1.7 Initialization expression, (8)
2618 F2008, 7.1.12 Constant expression, (4) */
2621 check_inquiry (gfc_expr
*e
, int not_restricted
)
2624 const char *const *functions
;
2626 static const char *const inquiry_func_f95
[] = {
2627 "lbound", "shape", "size", "ubound",
2628 "bit_size", "len", "kind",
2629 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2630 "precision", "radix", "range", "tiny",
2634 static const char *const inquiry_func_f2003
[] = {
2635 "lbound", "shape", "size", "ubound",
2636 "bit_size", "len", "kind",
2637 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2638 "precision", "radix", "range", "tiny",
2642 /* std=f2008+ or -std=gnu */
2643 static const char *const inquiry_func_gnu
[] = {
2644 "lbound", "shape", "size", "ubound",
2645 "bit_size", "len", "kind",
2646 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2647 "precision", "radix", "range", "tiny",
2648 "new_line", "storage_size", NULL
2652 gfc_actual_arglist
*ap
;
2656 if (!e
->value
.function
.isym
2657 || !e
->value
.function
.isym
->inquiry
)
2660 /* An undeclared parameter will get us here (PR25018). */
2661 if (e
->symtree
== NULL
)
2664 sym
= e
->symtree
->n
.sym
;
2666 if (sym
->from_intmod
)
2668 if (sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2669 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2670 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2673 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2674 && sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2681 functions
= inquiry_func_gnu
;
2682 if (gfc_option
.warn_std
& GFC_STD_F2003
)
2683 functions
= inquiry_func_f2003
;
2684 if (gfc_option
.warn_std
& GFC_STD_F95
)
2685 functions
= inquiry_func_f95
;
2687 for (i
= 0; functions
[i
]; i
++)
2688 if (strcmp (functions
[i
], name
) == 0)
2691 if (functions
[i
] == NULL
)
2695 /* At this point we have an inquiry function with a variable argument. The
2696 type of the variable might be undefined, but we need it now, because the
2697 arguments of these functions are not allowed to be undefined. */
2699 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2704 asym
= ap
->expr
->symtree
? ap
->expr
->symtree
->n
.sym
: NULL
;
2706 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2708 if (asym
&& asym
->ts
.type
== BT_UNKNOWN
2709 && !gfc_set_default_type (asym
, 0, gfc_current_ns
))
2712 ap
->expr
->ts
= asym
->ts
;
2715 if (asym
&& asym
->assoc
&& asym
->assoc
->target
2716 && asym
->assoc
->target
->expr_type
== EXPR_CONSTANT
)
2718 gfc_free_expr (ap
->expr
);
2719 ap
->expr
= gfc_copy_expr (asym
->assoc
->target
);
2722 /* Assumed character length will not reduce to a constant expression
2723 with LEN, as required by the standard. */
2724 if (i
== 5 && not_restricted
&& asym
2725 && asym
->ts
.type
== BT_CHARACTER
2726 && ((asym
->ts
.u
.cl
&& asym
->ts
.u
.cl
->length
== NULL
)
2727 || asym
->ts
.deferred
))
2729 gfc_error ("Assumed or deferred character length variable %qs "
2730 "in constant expression at %L",
2731 asym
->name
, &ap
->expr
->where
);
2734 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2737 if (not_restricted
== 0
2738 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2739 && !check_restricted (ap
->expr
))
2742 if (not_restricted
== 0
2743 && ap
->expr
->expr_type
== EXPR_VARIABLE
2744 && asym
->attr
.dummy
&& asym
->attr
.optional
)
2752 /* F95, 7.1.6.1, Initialization expressions, (5)
2753 F2003, 7.1.7 Initialization expression, (5) */
2756 check_transformational (gfc_expr
*e
)
2758 static const char * const trans_func_f95
[] = {
2759 "repeat", "reshape", "selected_int_kind",
2760 "selected_real_kind", "transfer", "trim", NULL
2763 static const char * const trans_func_f2003
[] = {
2764 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2765 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2766 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2767 "trim", "unpack", NULL
2770 static const char * const trans_func_f2008
[] = {
2771 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2772 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2773 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2774 "trim", "unpack", "findloc", NULL
2779 const char *const *functions
;
2781 if (!e
->value
.function
.isym
2782 || !e
->value
.function
.isym
->transformational
)
2785 name
= e
->symtree
->n
.sym
->name
;
2787 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2788 functions
= trans_func_f2008
;
2789 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2790 functions
= trans_func_f2003
;
2792 functions
= trans_func_f95
;
2794 /* NULL() is dealt with below. */
2795 if (strcmp ("null", name
) == 0)
2798 for (i
= 0; functions
[i
]; i
++)
2799 if (strcmp (functions
[i
], name
) == 0)
2802 if (functions
[i
] == NULL
)
2804 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2805 "in an initialization expression", name
, &e
->where
);
2809 return check_init_expr_arguments (e
);
2813 /* F95, 7.1.6.1, Initialization expressions, (6)
2814 F2003, 7.1.7 Initialization expression, (6) */
2817 check_null (gfc_expr
*e
)
2819 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2822 return check_init_expr_arguments (e
);
2827 check_elemental (gfc_expr
*e
)
2829 if (!e
->value
.function
.isym
2830 || !e
->value
.function
.isym
->elemental
)
2833 if (e
->ts
.type
!= BT_INTEGER
2834 && e
->ts
.type
!= BT_CHARACTER
2835 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2836 "initialization expression at %L", &e
->where
))
2839 return check_init_expr_arguments (e
);
2844 check_conversion (gfc_expr
*e
)
2846 if (!e
->value
.function
.isym
2847 || !e
->value
.function
.isym
->conversion
)
2850 return check_init_expr_arguments (e
);
2854 /* Verify that an expression is an initialization expression. A side
2855 effect is that the expression tree is reduced to a single constant
2856 node if all goes well. This would normally happen when the
2857 expression is constructed but function references are assumed to be
2858 intrinsics in the context of initialization expressions. If
2859 false is returned an error message has been generated. */
2862 gfc_check_init_expr (gfc_expr
*e
)
2870 switch (e
->expr_type
)
2873 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2875 t
= gfc_simplify_expr (e
, 0);
2884 gfc_intrinsic_sym
* isym
= NULL
;
2885 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2887 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2888 IEEE_EXCEPTIONS modules. */
2889 int mod
= sym
->from_intmod
;
2890 if (mod
== INTMOD_NONE
&& sym
->generic
)
2891 mod
= sym
->generic
->sym
->from_intmod
;
2892 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2894 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2897 gfc_replace_expr (e
, new_expr
);
2903 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2904 into an array constructor, we need to skip the error check here.
2905 Conversion errors are caught below in scalarize_intrinsic_call. */
2906 conversion
= e
->value
.function
.isym
2907 && (e
->value
.function
.isym
->conversion
== 1);
2909 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2910 || (m
= gfc_intrinsic_func_interface (e
, 0)) == MATCH_NO
))
2912 gfc_error ("Function %qs in initialization expression at %L "
2913 "must be an intrinsic function",
2914 e
->symtree
->n
.sym
->name
, &e
->where
);
2918 if ((m
= check_conversion (e
)) == MATCH_NO
2919 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2920 && (m
= check_null (e
)) == MATCH_NO
2921 && (m
= check_transformational (e
)) == MATCH_NO
2922 && (m
= check_elemental (e
)) == MATCH_NO
)
2924 gfc_error ("Intrinsic function %qs at %L is not permitted "
2925 "in an initialization expression",
2926 e
->symtree
->n
.sym
->name
, &e
->where
);
2930 if (m
== MATCH_ERROR
)
2933 /* Try to scalarize an elemental intrinsic function that has an
2935 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2936 if (isym
&& isym
->elemental
2937 && (t
= scalarize_intrinsic_call (e
, true)))
2942 t
= gfc_simplify_expr (e
, 0);
2949 /* This occurs when parsing pdt templates. */
2950 if (gfc_expr_attr (e
).pdt_kind
)
2953 if (gfc_check_iter_variable (e
))
2956 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2958 /* A PARAMETER shall not be used to define itself, i.e.
2959 REAL, PARAMETER :: x = transfer(0, x)
2961 if (!e
->symtree
->n
.sym
->value
)
2963 gfc_error ("PARAMETER %qs is used at %L before its definition "
2964 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2968 t
= simplify_parameter_variable (e
, 0);
2973 if (gfc_in_match_data ())
2978 if (e
->symtree
->n
.sym
->as
)
2980 switch (e
->symtree
->n
.sym
->as
->type
)
2982 case AS_ASSUMED_SIZE
:
2983 gfc_error ("Assumed size array %qs at %L is not permitted "
2984 "in an initialization expression",
2985 e
->symtree
->n
.sym
->name
, &e
->where
);
2988 case AS_ASSUMED_SHAPE
:
2989 gfc_error ("Assumed shape array %qs at %L is not permitted "
2990 "in an initialization expression",
2991 e
->symtree
->n
.sym
->name
, &e
->where
);
2995 if (!e
->symtree
->n
.sym
->attr
.allocatable
2996 && !e
->symtree
->n
.sym
->attr
.pointer
2997 && e
->symtree
->n
.sym
->attr
.dummy
)
2998 gfc_error ("Assumed-shape array %qs at %L is not permitted "
2999 "in an initialization expression",
3000 e
->symtree
->n
.sym
->name
, &e
->where
);
3002 gfc_error ("Deferred array %qs at %L is not permitted "
3003 "in an initialization expression",
3004 e
->symtree
->n
.sym
->name
, &e
->where
);
3008 gfc_error ("Array %qs at %L is a variable, which does "
3009 "not reduce to a constant expression",
3010 e
->symtree
->n
.sym
->name
, &e
->where
);
3013 case AS_ASSUMED_RANK
:
3014 gfc_error ("Assumed-rank array %qs at %L is not permitted "
3015 "in an initialization expression",
3016 e
->symtree
->n
.sym
->name
, &e
->where
);
3024 gfc_error ("Parameter %qs at %L has not been declared or is "
3025 "a variable, which does not reduce to a constant "
3026 "expression", e
->symtree
->name
, &e
->where
);
3035 case EXPR_SUBSTRING
:
3038 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
3042 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
3044 t
= gfc_simplify_expr (e
, 0);
3050 case EXPR_STRUCTURE
:
3051 t
= e
->ts
.is_iso_c
? true : false;
3055 t
= check_alloc_comp_init (e
);
3059 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3066 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3070 t
= gfc_expand_constructor (e
, true);
3074 t
= gfc_check_constructor_type (e
);
3078 gfc_internal_error ("check_init_expr(): Unknown expression type");
3084 /* Reduces a general expression to an initialization expression (a constant).
3085 This used to be part of gfc_match_init_expr.
3086 Note that this function doesn't free the given expression on false. */
3089 gfc_reduce_init_expr (gfc_expr
*expr
)
3093 gfc_init_expr_flag
= true;
3094 t
= gfc_resolve_expr (expr
);
3096 t
= gfc_check_init_expr (expr
);
3097 gfc_init_expr_flag
= false;
3102 if (expr
->expr_type
== EXPR_ARRAY
)
3104 if (!gfc_check_constructor_type (expr
))
3106 if (!gfc_expand_constructor (expr
, true))
3114 /* Match an initialization expression. We work by first matching an
3115 expression, then reducing it to a constant. */
3118 gfc_match_init_expr (gfc_expr
**result
)
3126 gfc_init_expr_flag
= true;
3128 m
= gfc_match_expr (&expr
);
3131 gfc_init_expr_flag
= false;
3135 if (gfc_derived_parameter_expr (expr
))
3138 gfc_init_expr_flag
= false;
3142 t
= gfc_reduce_init_expr (expr
);
3145 gfc_free_expr (expr
);
3146 gfc_init_expr_flag
= false;
3151 gfc_init_expr_flag
= false;
3157 /* Given an actual argument list, test to see that each argument is a
3158 restricted expression and optionally if the expression type is
3159 integer or character. */
3162 restricted_args (gfc_actual_arglist
*a
)
3164 for (; a
; a
= a
->next
)
3166 if (!check_restricted (a
->expr
))
3174 /************* Restricted/specification expressions *************/
3177 /* Make sure a non-intrinsic function is a specification function,
3178 * see F08:7.1.11.5. */
3181 external_spec_function (gfc_expr
*e
)
3185 f
= e
->value
.function
.esym
;
3187 /* IEEE functions allowed are "a reference to a transformational function
3188 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3189 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3190 IEEE_EXCEPTIONS". */
3191 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3192 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3194 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3195 || !strcmp (f
->name
, "ieee_support_rounding")
3196 || !strcmp (f
->name
, "ieee_support_flag")
3197 || !strcmp (f
->name
, "ieee_support_halting")
3198 || !strcmp (f
->name
, "ieee_support_datatype")
3199 || !strcmp (f
->name
, "ieee_support_denormal")
3200 || !strcmp (f
->name
, "ieee_support_subnormal")
3201 || !strcmp (f
->name
, "ieee_support_divide")
3202 || !strcmp (f
->name
, "ieee_support_inf")
3203 || !strcmp (f
->name
, "ieee_support_io")
3204 || !strcmp (f
->name
, "ieee_support_nan")
3205 || !strcmp (f
->name
, "ieee_support_sqrt")
3206 || !strcmp (f
->name
, "ieee_support_standard")
3207 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3208 goto function_allowed
;
3211 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3213 gfc_error ("Specification function %qs at %L cannot be a statement "
3214 "function", f
->name
, &e
->where
);
3218 if (f
->attr
.proc
== PROC_INTERNAL
)
3220 gfc_error ("Specification function %qs at %L cannot be an internal "
3221 "function", f
->name
, &e
->where
);
3225 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3227 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3233 if (f
->attr
.recursive
3234 && !gfc_notify_std (GFC_STD_F2003
,
3235 "Specification function %qs "
3236 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3240 return restricted_args (e
->value
.function
.actual
);
3244 /* Check to see that a function reference to an intrinsic is a
3245 restricted expression. */
3248 restricted_intrinsic (gfc_expr
*e
)
3250 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3251 if (check_inquiry (e
, 0) == MATCH_YES
)
3254 return restricted_args (e
->value
.function
.actual
);
3258 /* Check the expressions of an actual arglist. Used by check_restricted. */
3261 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3263 for (; arg
; arg
= arg
->next
)
3264 if (!checker (arg
->expr
))
3271 /* Check the subscription expressions of a reference chain with a checking
3272 function; used by check_restricted. */
3275 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3285 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3287 if (!checker (ref
->u
.ar
.start
[dim
]))
3289 if (!checker (ref
->u
.ar
.end
[dim
]))
3291 if (!checker (ref
->u
.ar
.stride
[dim
]))
3297 /* Nothing needed, just proceed to next reference. */
3301 if (!checker (ref
->u
.ss
.start
))
3303 if (!checker (ref
->u
.ss
.end
))
3312 return check_references (ref
->next
, checker
);
3315 /* Return true if ns is a parent of the current ns. */
3318 is_parent_of_current_ns (gfc_namespace
*ns
)
3321 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3328 /* Verify that an expression is a restricted expression. Like its
3329 cousin check_init_expr(), an error message is generated if we
3333 check_restricted (gfc_expr
*e
)
3341 switch (e
->expr_type
)
3344 t
= check_intrinsic_op (e
, check_restricted
);
3346 t
= gfc_simplify_expr (e
, 0);
3351 if (e
->value
.function
.esym
)
3353 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3355 t
= external_spec_function (e
);
3359 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3362 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3365 t
= restricted_intrinsic (e
);
3370 sym
= e
->symtree
->n
.sym
;
3373 /* If a dummy argument appears in a context that is valid for a
3374 restricted expression in an elemental procedure, it will have
3375 already been simplified away once we get here. Therefore we
3376 don't need to jump through hoops to distinguish valid from
3377 invalid cases. Allowed in F2008 and F2018. */
3378 if (gfc_notification_std (GFC_STD_F2008
)
3379 && sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3380 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3382 gfc_error_now ("Dummy argument %qs not "
3383 "allowed in expression at %L",
3384 sym
->name
, &e
->where
);
3388 if (sym
->attr
.optional
)
3390 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3391 sym
->name
, &e
->where
);
3395 if (sym
->attr
.intent
== INTENT_OUT
)
3397 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3398 sym
->name
, &e
->where
);
3402 /* Check reference chain if any. */
3403 if (!check_references (e
->ref
, &check_restricted
))
3406 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3407 processed in resolve.c(resolve_formal_arglist). This is done so
3408 that host associated dummy array indices are accepted (PR23446).
3409 This mechanism also does the same for the specification expressions
3410 of array-valued functions. */
3412 || sym
->attr
.in_common
3413 || sym
->attr
.use_assoc
3415 || sym
->attr
.implied_index
3416 || sym
->attr
.flavor
== FL_PARAMETER
3417 || is_parent_of_current_ns (sym
->ns
)
3418 || (sym
->ns
->proc_name
!= NULL
3419 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3420 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3426 gfc_error ("Variable %qs cannot appear in the expression at %L",
3427 sym
->name
, &e
->where
);
3428 /* Prevent a repetition of the error. */
3437 case EXPR_SUBSTRING
:
3438 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3442 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3444 t
= gfc_simplify_expr (e
, 0);
3448 case EXPR_STRUCTURE
:
3449 t
= gfc_check_constructor (e
, check_restricted
);
3453 t
= gfc_check_constructor (e
, check_restricted
);
3457 gfc_internal_error ("check_restricted(): Unknown expression type");
3464 /* Check to see that an expression is a specification expression. If
3465 we return false, an error has been generated. */
3468 gfc_specification_expr (gfc_expr
*e
)
3470 gfc_component
*comp
;
3475 if (e
->ts
.type
!= BT_INTEGER
)
3477 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3478 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3482 comp
= gfc_get_proc_ptr_comp (e
);
3483 if (e
->expr_type
== EXPR_FUNCTION
3484 && !e
->value
.function
.isym
3485 && !e
->value
.function
.esym
3486 && !gfc_pure (e
->symtree
->n
.sym
)
3487 && (!comp
|| !comp
->attr
.pure
))
3489 gfc_error ("Function %qs at %L must be PURE",
3490 e
->symtree
->n
.sym
->name
, &e
->where
);
3491 /* Prevent repeat error messages. */
3492 e
->symtree
->n
.sym
->attr
.pure
= 1;
3498 gfc_error ("Expression at %L must be scalar", &e
->where
);
3502 if (!gfc_simplify_expr (e
, 0))
3505 return check_restricted (e
);
3509 /************** Expression conformance checks. *************/
3511 /* Given two expressions, make sure that the arrays are conformable. */
3514 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3516 int op1_flag
, op2_flag
, d
;
3517 mpz_t op1_size
, op2_size
;
3523 if (op1
->rank
== 0 || op2
->rank
== 0)
3526 va_start (argp
, optype_msgid
);
3527 d
= vsnprintf (buffer
, sizeof (buffer
), optype_msgid
, argp
);
3529 if (d
< 1 || d
>= (int) sizeof (buffer
)) /* Reject truncation. */
3530 gfc_internal_error ("optype_msgid overflow: %d", d
);
3532 if (op1
->rank
!= op2
->rank
)
3534 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3535 op1
->rank
, op2
->rank
, &op1
->where
);
3541 for (d
= 0; d
< op1
->rank
; d
++)
3543 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3544 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3546 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3548 gfc_error ("Different shape for %s at %L on dimension %d "
3549 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3550 (int) mpz_get_si (op1_size
),
3551 (int) mpz_get_si (op2_size
));
3557 mpz_clear (op1_size
);
3559 mpz_clear (op2_size
);
3569 /* Given an assignable expression and an arbitrary expression, make
3570 sure that the assignment can take place. Only add a call to the intrinsic
3571 conversion routines, when allow_convert is set. When this assign is a
3572 coarray call, then the convert is done by the coarray routine implictly and
3573 adding the intrinsic conversion would do harm in most cases. */
3576 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3583 sym
= lvalue
->symtree
->n
.sym
;
3585 /* See if this is the component or subcomponent of a pointer and guard
3586 against assignment to LEN or KIND part-refs. */
3587 has_pointer
= sym
->attr
.pointer
;
3588 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3590 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3591 && ref
->u
.c
.component
->attr
.pointer
)
3593 else if (ref
->type
== REF_INQUIRY
3594 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3596 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3597 "allowed", &lvalue
->where
);
3602 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3603 variable local to a function subprogram. Its existence begins when
3604 execution of the function is initiated and ends when execution of the
3605 function is terminated...
3606 Therefore, the left hand side is no longer a variable, when it is: */
3607 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3608 && !sym
->attr
.external
)
3613 /* (i) Use associated; */
3614 if (sym
->attr
.use_assoc
)
3617 /* (ii) The assignment is in the main program; or */
3618 if (gfc_current_ns
->proc_name
3619 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3622 /* (iii) A module or internal procedure... */
3623 if (gfc_current_ns
->proc_name
3624 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3625 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3626 && gfc_current_ns
->parent
3627 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3628 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3629 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3631 /* ... that is not a function... */
3632 if (gfc_current_ns
->proc_name
3633 && !gfc_current_ns
->proc_name
->attr
.function
)
3636 /* ... or is not an entry and has a different name. */
3637 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3641 /* (iv) Host associated and not the function symbol or the
3642 parent result. This picks up sibling references, which
3643 cannot be entries. */
3644 if (!sym
->attr
.entry
3645 && sym
->ns
== gfc_current_ns
->parent
3646 && sym
!= gfc_current_ns
->proc_name
3647 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3652 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3658 /* Reject assigning to an external symbol. For initializers, this
3659 was already done before, in resolve_fl_procedure. */
3660 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
3661 && sym
->attr
.proc
!= PROC_MODULE
&& !rvalue
->error
)
3663 gfc_error ("Illegal assignment to external procedure at %L",
3669 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3671 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3672 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3676 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3678 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3683 if (rvalue
->expr_type
== EXPR_NULL
)
3685 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3686 && lvalue
->symtree
->n
.sym
->attr
.data
)
3690 gfc_error ("NULL appears on right-hand side in assignment at %L",
3696 /* This is possibly a typo: x = f() instead of x => f(). */
3698 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3699 gfc_warning (OPT_Wsurprising
,
3700 "POINTER-valued function appears on right-hand side of "
3701 "assignment at %L", &rvalue
->where
);
3703 /* Check size of array assignments. */
3704 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3705 && !gfc_check_conformance (lvalue
, rvalue
, _("array assignment")))
3708 /* Handle the case of a BOZ literal on the RHS. */
3709 if (rvalue
->ts
.type
== BT_BOZ
)
3711 if (lvalue
->symtree
->n
.sym
->attr
.data
)
3713 if (lvalue
->ts
.type
== BT_INTEGER
3714 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3717 if (lvalue
->ts
.type
== BT_REAL
3718 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3720 if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
3721 "be assigned to a REAL variable",
3728 if (!lvalue
->symtree
->n
.sym
->attr
.data
3729 && gfc_invalid_boz ("BOZ literal constant at %L is neither a "
3730 "data-stmt-constant nor an actual argument to "
3731 "INT, REAL, DBLE, or CMPLX intrinsic function",
3735 if (lvalue
->ts
.type
== BT_INTEGER
3736 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3739 if (lvalue
->ts
.type
== BT_REAL
3740 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3743 gfc_error ("BOZ literal constant near %L cannot be assigned to a "
3744 "%qs variable", &rvalue
->where
, gfc_typename (lvalue
));
3748 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3750 gfc_error ("The assignment to a KIND or LEN component of a "
3751 "parameterized type at %L is not allowed",
3756 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3759 /* Only DATA Statements come here. */
3764 /* Numeric can be converted to any other numeric. And Hollerith can be
3765 converted to any other type. */
3766 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3767 || rvalue
->ts
.type
== BT_HOLLERITH
)
3770 if (flag_dec_char_conversions
&& (gfc_numeric_ts (&lvalue
->ts
)
3771 || lvalue
->ts
.type
== BT_LOGICAL
)
3772 && rvalue
->ts
.type
== BT_CHARACTER
3773 && rvalue
->ts
.kind
== gfc_default_character_kind
)
3776 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3779 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3780 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3781 "conversion of %s to %s", where
,
3782 gfc_typename (rvalue
), gfc_typename (lvalue
));
3787 /* Assignment is the only case where character variables of different
3788 kind values can be converted into one another. */
3789 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3791 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3792 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3800 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3804 /* Check that a pointer assignment is OK. We first check lvalue, and
3805 we only check rvalue if it's not an assignment to NULL() or a
3806 NULLIFY statement. */
3809 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
3810 bool suppress_type_test
, bool is_init_expr
)
3812 symbol_attribute attr
, lhs_attr
;
3814 bool is_pure
, is_implicit_pure
, rank_remap
;
3818 if (!lvalue
->symtree
)
3821 lhs_attr
= gfc_expr_attr (lvalue
);
3822 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3824 gfc_error ("Pointer assignment target is not a POINTER at %L",
3829 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3830 && !lhs_attr
.proc_pointer
)
3832 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3833 "l-value since it is a procedure",
3834 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3838 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3841 same_rank
= lvalue
->rank
== rvalue
->rank
;
3842 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3844 if (ref
->type
== REF_COMPONENT
)
3845 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3847 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3851 if (ref
->u
.ar
.type
== AR_FULL
)
3854 if (ref
->u
.ar
.type
!= AR_SECTION
)
3856 gfc_error ("Expected bounds specification for %qs at %L",
3857 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3861 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3862 "for %qs in pointer assignment at %L",
3863 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3866 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3868 * (C1017) If bounds-spec-list is specified, the number of
3869 * bounds-specs shall equal the rank of data-pointer-object.
3871 * If bounds-spec-list appears, it specifies the lower bounds.
3873 * (C1018) If bounds-remapping-list is specified, the number of
3874 * bounds-remappings shall equal the rank of data-pointer-object.
3876 * If bounds-remapping-list appears, it specifies the upper and
3877 * lower bounds of each dimension of the pointer; the pointer target
3878 * shall be simply contiguous or of rank one.
3880 * (C1019) If bounds-remapping-list is not specified, the ranks of
3881 * data-pointer-object and data-target shall be the same.
3883 * Thus when bounds are given, all lbounds are necessary and either
3884 * all or none of the upper bounds; no strides are allowed. If the
3885 * upper bounds are present, we may do rank remapping. */
3886 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3888 if (ref
->u
.ar
.stride
[dim
])
3890 gfc_error ("Stride must not be present at %L",
3894 if (!same_rank
&& (!ref
->u
.ar
.start
[dim
] ||!ref
->u
.ar
.end
[dim
]))
3896 gfc_error ("Rank remapping requires a "
3897 "list of %<lower-bound : upper-bound%> "
3898 "specifications at %L", &lvalue
->where
);
3901 if (!ref
->u
.ar
.start
[dim
]
3902 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3904 gfc_error ("Expected list of %<lower-bound :%> or "
3905 "list of %<lower-bound : upper-bound%> "
3906 "specifications at %L", &lvalue
->where
);
3911 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3914 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
]))
3916 gfc_error ("Rank remapping requires a "
3917 "list of %<lower-bound : upper-bound%> "
3918 "specifications at %L", &lvalue
->where
);
3921 if (!rank_remap
&& ref
->u
.ar
.end
[dim
])
3923 gfc_error ("Expected list of %<lower-bound :%> or "
3924 "list of %<lower-bound : upper-bound%> "
3925 "specifications at %L", &lvalue
->where
);
3933 is_pure
= gfc_pure (NULL
);
3934 is_implicit_pure
= gfc_implicit_pure (NULL
);
3936 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3937 kind, etc for lvalue and rvalue must match, and rvalue must be a
3938 pure variable if we're in a pure function. */
3939 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3942 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3943 if (lvalue
->expr_type
== EXPR_VARIABLE
3944 && gfc_is_coindexed (lvalue
))
3947 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3948 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3950 gfc_error ("Pointer object at %L shall not have a coindex",
3956 /* Checks on rvalue for procedure pointer assignments. */
3961 gfc_component
*comp1
, *comp2
;
3964 attr
= gfc_expr_attr (rvalue
);
3965 if (!((rvalue
->expr_type
== EXPR_NULL
)
3966 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3967 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3968 || (rvalue
->expr_type
== EXPR_VARIABLE
3969 && attr
.flavor
== FL_PROCEDURE
)))
3971 gfc_error ("Invalid procedure pointer assignment at %L",
3976 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3978 /* Check for intrinsics. */
3979 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3980 if (!sym
->attr
.intrinsic
3981 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3982 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3984 sym
->attr
.intrinsic
= 1;
3985 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3986 attr
= gfc_expr_attr (rvalue
);
3988 /* Check for result of embracing function. */
3989 if (sym
->attr
.function
&& sym
->result
== sym
)
3993 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3994 if (sym
== ns
->proc_name
)
3996 gfc_error ("Function result %qs is invalid as proc-target "
3997 "in procedure pointer assignment at %L",
3998 sym
->name
, &rvalue
->where
);
4005 gfc_error ("Abstract interface %qs is invalid "
4006 "in procedure pointer assignment at %L",
4007 rvalue
->symtree
->name
, &rvalue
->where
);
4010 /* Check for F08:C729. */
4011 if (attr
.flavor
== FL_PROCEDURE
)
4013 if (attr
.proc
== PROC_ST_FUNCTION
)
4015 gfc_error ("Statement function %qs is invalid "
4016 "in procedure pointer assignment at %L",
4017 rvalue
->symtree
->name
, &rvalue
->where
);
4020 if (attr
.proc
== PROC_INTERNAL
&&
4021 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
4022 "is invalid in procedure pointer assignment "
4023 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
4025 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
4026 attr
.subroutine
) == 0)
4028 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
4029 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
4033 /* Check for F08:C730. */
4034 if (attr
.elemental
&& !attr
.intrinsic
)
4036 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
4037 "in procedure pointer assignment at %L",
4038 rvalue
->symtree
->name
, &rvalue
->where
);
4042 /* Ensure that the calling convention is the same. As other attributes
4043 such as DLLEXPORT may differ, one explicitly only tests for the
4044 calling conventions. */
4045 if (rvalue
->expr_type
== EXPR_VARIABLE
4046 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
4047 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4049 symbol_attribute calls
;
4052 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
4053 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
4054 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
4056 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4057 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
4059 gfc_error ("Mismatch in the procedure pointer assignment "
4060 "at %L: mismatch in the calling convention",
4066 comp1
= gfc_get_proc_ptr_comp (lvalue
);
4068 s1
= comp1
->ts
.interface
;
4071 s1
= lvalue
->symtree
->n
.sym
;
4072 if (s1
->ts
.interface
)
4073 s1
= s1
->ts
.interface
;
4076 comp2
= gfc_get_proc_ptr_comp (rvalue
);
4079 if (rvalue
->expr_type
== EXPR_FUNCTION
)
4081 s2
= comp2
->ts
.interface
->result
;
4086 s2
= comp2
->ts
.interface
;
4090 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
4092 if (rvalue
->value
.function
.esym
)
4093 s2
= rvalue
->value
.function
.esym
->result
;
4095 s2
= rvalue
->symtree
->n
.sym
->result
;
4101 s2
= rvalue
->symtree
->n
.sym
;
4105 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
4106 s2
= s2
->ts
.interface
;
4108 /* Special check for the case of absent interface on the lvalue.
4109 * All other interface checks are done below. */
4110 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
4112 gfc_error ("Interface mismatch in procedure pointer assignment "
4113 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
4117 /* F08:7.2.2.4 (4) */
4118 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
4122 gfc_error ("Explicit interface required for component %qs at %L: %s",
4123 comp1
->name
, &lvalue
->where
, err
);
4126 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
4128 gfc_error ("Explicit interface required for %qs at %L: %s",
4129 s1
->name
, &lvalue
->where
, err
);
4133 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
4137 gfc_error ("Explicit interface required for component %qs at %L: %s",
4138 comp2
->name
, &rvalue
->where
, err
);
4141 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
4143 gfc_error ("Explicit interface required for %qs at %L: %s",
4144 s2
->name
, &rvalue
->where
, err
);
4149 if (s1
== s2
|| !s1
|| !s2
)
4152 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
4153 err
, sizeof(err
), NULL
, NULL
))
4155 gfc_error ("Interface mismatch in procedure pointer assignment "
4156 "at %L: %s", &rvalue
->where
, err
);
4160 /* Check F2008Cor2, C729. */
4161 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4162 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4164 gfc_error ("Procedure pointer target %qs at %L must be either an "
4165 "intrinsic, host or use associated, referenced or have "
4166 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4174 /* A non-proc pointer cannot point to a constant. */
4175 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4177 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4183 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4185 /* Check for F03:C717. */
4186 if (UNLIMITED_POLY (rvalue
)
4187 && !(UNLIMITED_POLY (lvalue
)
4188 || (lvalue
->ts
.type
== BT_DERIVED
4189 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4190 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4191 gfc_error ("Data-pointer-object at %L must be unlimited "
4192 "polymorphic, or of a type with the BIND or SEQUENCE "
4193 "attribute, to be compatible with an unlimited "
4194 "polymorphic target", &lvalue
->where
);
4195 else if (!suppress_type_test
)
4196 gfc_error ("Different types in pointer assignment at %L; "
4197 "attempted assignment of %s to %s", &lvalue
->where
,
4198 gfc_typename (rvalue
), gfc_typename (lvalue
));
4202 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4204 gfc_error ("Different kind type parameters in pointer "
4205 "assignment at %L", &lvalue
->where
);
4209 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4211 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4215 /* Make sure the vtab is present. */
4216 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4217 gfc_find_vtab (&rvalue
->ts
);
4219 /* Check rank remapping. */
4224 /* If this can be determined, check that the target must be at least as
4225 large as the pointer assigned to it is. */
4226 if (gfc_array_size (lvalue
, &lsize
)
4227 && gfc_array_size (rvalue
, &rsize
)
4228 && mpz_cmp (rsize
, lsize
) < 0)
4230 gfc_error ("Rank remapping target is smaller than size of the"
4231 " pointer (%ld < %ld) at %L",
4232 mpz_get_si (rsize
), mpz_get_si (lsize
),
4237 /* The target must be either rank one or it must be simply contiguous
4238 and F2008 must be allowed. */
4239 if (rvalue
->rank
!= 1)
4241 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4243 gfc_error ("Rank remapping target must be rank 1 or"
4244 " simply contiguous at %L", &rvalue
->where
);
4247 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4248 "rank 1 at %L", &rvalue
->where
))
4253 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4254 if (rvalue
->expr_type
== EXPR_NULL
)
4257 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4258 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4260 attr
= gfc_expr_attr (rvalue
);
4262 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4264 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4265 to caf_get. Map this to the same error message as below when it is
4266 still a variable expression. */
4267 if (rvalue
->value
.function
.isym
4268 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4269 /* The test above might need to be extend when F08, Note 5.4 has to be
4270 interpreted in the way that target and pointer with the same coindex
4272 gfc_error ("Data target at %L shall not have a coindex",
4275 gfc_error ("Target expression in pointer assignment "
4276 "at %L must deliver a pointer result",
4286 if (gfc_is_size_zero_array (rvalue
))
4288 gfc_error ("Zero-sized array detected at %L where an entity with "
4289 "the TARGET attribute is expected", &rvalue
->where
);
4292 else if (!rvalue
->symtree
)
4294 gfc_error ("Pointer assignment target in initialization expression "
4295 "does not have the TARGET attribute at %L",
4300 sym
= rvalue
->symtree
->n
.sym
;
4302 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4303 target
= CLASS_DATA (sym
)->attr
.target
;
4305 target
= sym
->attr
.target
;
4307 if (!target
&& !proc_pointer
)
4309 gfc_error ("Pointer assignment target in initialization expression "
4310 "does not have the TARGET attribute at %L",
4317 if (!attr
.target
&& !attr
.pointer
)
4319 gfc_error ("Pointer assignment target is neither TARGET "
4320 "nor POINTER at %L", &rvalue
->where
);
4325 if (lvalue
->ts
.type
== BT_CHARACTER
)
4327 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4332 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4334 gfc_error ("Bad target in pointer assignment in PURE "
4335 "procedure at %L", &rvalue
->where
);
4338 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4339 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4341 if (gfc_has_vector_index (rvalue
))
4343 gfc_error ("Pointer assignment with vector subscript "
4344 "on rhs at %L", &rvalue
->where
);
4348 if (attr
.is_protected
&& attr
.use_assoc
4349 && !(attr
.pointer
|| attr
.proc_pointer
))
4351 gfc_error ("Pointer assignment target has PROTECTED "
4352 "attribute at %L", &rvalue
->where
);
4356 /* F2008, C725. For PURE also C1283. */
4357 if (rvalue
->expr_type
== EXPR_VARIABLE
4358 && gfc_is_coindexed (rvalue
))
4361 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4362 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4364 gfc_error ("Data target at %L shall not have a coindex",
4370 /* Warn for assignments of contiguous pointers to targets which is not
4371 contiguous. Be lenient in the definition of what counts as
4374 if (lhs_attr
.contiguous
4375 && lhs_attr
.dimension
> 0)
4377 if (gfc_is_not_contiguous (rvalue
))
4379 gfc_error ("Assignment to contiguous pointer from "
4380 "non-contiguous target at %L", &rvalue
->where
);
4383 if (!gfc_is_simply_contiguous (rvalue
, false, true))
4384 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4385 "non-contiguous target at %L", &rvalue
->where
);
4388 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4389 if (warn_target_lifetime
4390 && rvalue
->expr_type
== EXPR_VARIABLE
4391 && !rvalue
->symtree
->n
.sym
->attr
.save
4392 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4393 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4394 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4395 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4396 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4401 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4402 || lvalue
->symtree
->n
.sym
->attr
.result
4403 || lvalue
->symtree
->n
.sym
->attr
.function
4404 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4405 && lvalue
->symtree
->n
.sym
->ns
4406 != rvalue
->symtree
->n
.sym
->ns
)
4407 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4408 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4410 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4411 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4412 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4413 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4414 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4416 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4423 gfc_warning (OPT_Wtarget_lifetime
,
4424 "Pointer at %L in pointer assignment might outlive the "
4425 "pointer target", &lvalue
->where
);
4432 /* Relative of gfc_check_assign() except that the lvalue is a single
4433 symbol. Used for initialization assignments. */
4436 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4440 bool pointer
, proc_pointer
;
4442 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4444 lvalue
.expr_type
= EXPR_VARIABLE
;
4445 lvalue
.ts
= sym
->ts
;
4447 lvalue
.rank
= sym
->as
->rank
;
4448 lvalue
.symtree
= XCNEW (gfc_symtree
);
4449 lvalue
.symtree
->n
.sym
= sym
;
4450 lvalue
.where
= sym
->declared_at
;
4454 lvalue
.ref
= gfc_get_ref ();
4455 lvalue
.ref
->type
= REF_COMPONENT
;
4456 lvalue
.ref
->u
.c
.component
= comp
;
4457 lvalue
.ref
->u
.c
.sym
= sym
;
4458 lvalue
.ts
= comp
->ts
;
4459 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4460 lvalue
.where
= comp
->loc
;
4461 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4462 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4463 proc_pointer
= comp
->attr
.proc_pointer
;
4467 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4468 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4469 proc_pointer
= sym
->attr
.proc_pointer
;
4472 if (pointer
|| proc_pointer
)
4473 r
= gfc_check_pointer_assign (&lvalue
, rvalue
, false, true);
4476 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4477 into an array constructor, we should check if it can be reduced
4478 as an initialization expression. */
4479 if (rvalue
->expr_type
== EXPR_FUNCTION
4480 && rvalue
->value
.function
.isym
4481 && (rvalue
->value
.function
.isym
->conversion
== 1))
4482 gfc_check_init_expr (rvalue
);
4484 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4487 free (lvalue
.symtree
);
4493 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
&& !proc_pointer
)
4495 /* F08:C461. Additional checks for pointer initialization. */
4496 symbol_attribute attr
;
4497 attr
= gfc_expr_attr (rvalue
);
4498 if (attr
.allocatable
)
4500 gfc_error ("Pointer initialization target at %L "
4501 "must not be ALLOCATABLE", &rvalue
->where
);
4504 if (!attr
.target
|| attr
.pointer
)
4506 gfc_error ("Pointer initialization target at %L "
4507 "must have the TARGET attribute", &rvalue
->where
);
4511 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4512 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4513 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4515 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4516 attr
.save
= SAVE_IMPLICIT
;
4521 gfc_error ("Pointer initialization target at %L "
4522 "must have the SAVE attribute", &rvalue
->where
);
4527 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4529 /* F08:C1220. Additional checks for procedure pointer initialization. */
4530 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4531 if (attr
.proc_pointer
)
4533 gfc_error ("Procedure pointer initialization target at %L "
4534 "may not be a procedure pointer", &rvalue
->where
);
4537 if (attr
.proc
== PROC_INTERNAL
)
4539 gfc_error ("Internal procedure %qs is invalid in "
4540 "procedure pointer initialization at %L",
4541 rvalue
->symtree
->name
, &rvalue
->where
);
4546 gfc_error ("Dummy procedure %qs is invalid in "
4547 "procedure pointer initialization at %L",
4548 rvalue
->symtree
->name
, &rvalue
->where
);
4556 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4557 * require that an expression be built. */
4560 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4562 return gfc_build_init_expr (ts
, where
, false);
4565 /* Build an initializer for a local integer, real, complex, logical, or
4566 character variable, based on the command line flags finit-local-zero,
4567 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4568 With force, an initializer is ALWAYS generated. */
4571 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4573 gfc_expr
*init_expr
;
4575 /* Try to build an initializer expression. */
4576 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4578 /* If we want to force generation, make sure we default to zero. */
4579 gfc_init_local_real init_real
= flag_init_real
;
4580 int init_logical
= gfc_option
.flag_init_logical
;
4583 if (init_real
== GFC_INIT_REAL_OFF
)
4584 init_real
= GFC_INIT_REAL_ZERO
;
4585 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4586 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4589 /* We will only initialize integers, reals, complex, logicals, and
4590 characters, and only if the corresponding command-line flags
4591 were set. Otherwise, we free init_expr and return null. */
4595 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4596 mpz_set_si (init_expr
->value
.integer
,
4597 gfc_option
.flag_init_integer_value
);
4600 gfc_free_expr (init_expr
);
4608 case GFC_INIT_REAL_SNAN
:
4609 init_expr
->is_snan
= 1;
4611 case GFC_INIT_REAL_NAN
:
4612 mpfr_set_nan (init_expr
->value
.real
);
4615 case GFC_INIT_REAL_INF
:
4616 mpfr_set_inf (init_expr
->value
.real
, 1);
4619 case GFC_INIT_REAL_NEG_INF
:
4620 mpfr_set_inf (init_expr
->value
.real
, -1);
4623 case GFC_INIT_REAL_ZERO
:
4624 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4628 gfc_free_expr (init_expr
);
4637 case GFC_INIT_REAL_SNAN
:
4638 init_expr
->is_snan
= 1;
4640 case GFC_INIT_REAL_NAN
:
4641 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4642 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4645 case GFC_INIT_REAL_INF
:
4646 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4647 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4650 case GFC_INIT_REAL_NEG_INF
:
4651 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4652 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4655 case GFC_INIT_REAL_ZERO
:
4656 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4660 gfc_free_expr (init_expr
);
4667 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4668 init_expr
->value
.logical
= 0;
4669 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4670 init_expr
->value
.logical
= 1;
4673 gfc_free_expr (init_expr
);
4679 /* For characters, the length must be constant in order to
4680 create a default initializer. */
4681 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4683 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4685 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4686 init_expr
->value
.character
.length
= char_len
;
4687 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4688 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4689 init_expr
->value
.character
.string
[i
]
4690 = (unsigned char) gfc_option
.flag_init_character_value
;
4694 gfc_free_expr (init_expr
);
4698 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4699 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4701 gfc_actual_arglist
*arg
;
4702 init_expr
= gfc_get_expr ();
4703 init_expr
->where
= *where
;
4704 init_expr
->ts
= *ts
;
4705 init_expr
->expr_type
= EXPR_FUNCTION
;
4706 init_expr
->value
.function
.isym
=
4707 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4708 init_expr
->value
.function
.name
= "repeat";
4709 arg
= gfc_get_actual_arglist ();
4710 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4711 arg
->expr
->value
.character
.string
[0] =
4712 gfc_option
.flag_init_character_value
;
4713 arg
->next
= gfc_get_actual_arglist ();
4714 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4715 init_expr
->value
.function
.actual
= arg
;
4720 gfc_free_expr (init_expr
);
4727 /* Apply an initialization expression to a typespec. Can be used for symbols or
4728 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4729 combined with some effort. */
4732 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4734 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4737 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4738 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4740 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4742 if (init
->expr_type
== EXPR_CONSTANT
)
4743 gfc_set_constant_character_len (len
, init
, -1);
4745 && init
->ts
.type
== BT_CHARACTER
4746 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4747 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4748 init
->ts
.u
.cl
->length
->value
.integer
))
4750 gfc_constructor
*ctor
;
4751 ctor
= gfc_constructor_first (init
->value
.constructor
);
4755 bool has_ts
= (init
->ts
.u
.cl
4756 && init
->ts
.u
.cl
->length_from_typespec
);
4758 /* Remember the length of the first element for checking
4759 that all elements *in the constructor* have the same
4760 length. This need not be the length of the LHS! */
4761 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4762 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4763 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4765 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4766 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4768 gfc_set_constant_character_len (len
, ctor
->expr
,
4769 has_ts
? -1 : first_len
);
4770 if (!ctor
->expr
->ts
.u
.cl
)
4772 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4774 ctor
->expr
->ts
.u
.cl
->length
4775 = gfc_copy_expr (ts
->u
.cl
->length
);
4783 /* Check whether an expression is a structure constructor and whether it has
4784 other values than NULL. */
4787 is_non_empty_structure_constructor (gfc_expr
* e
)
4789 if (e
->expr_type
!= EXPR_STRUCTURE
)
4792 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4795 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4797 cons
= gfc_constructor_next (cons
);
4803 /* Check for default initializer; sym->value is not enough
4804 as it is also set for EXPR_NULL of allocatables. */
4807 gfc_has_default_initializer (gfc_symbol
*der
)
4811 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4812 for (c
= der
->components
; c
; c
= c
->next
)
4813 if (gfc_bt_struct (c
->ts
.type
))
4815 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4816 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4818 && is_non_empty_structure_constructor (c
->initializer
))
4819 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4821 if (c
->attr
.pointer
&& c
->initializer
)
4835 Generate an initializer expression which initializes the entirety of a union.
4836 A normal structure constructor is insufficient without undue effort, because
4837 components of maps may be oddly aligned/overlapped. (For example if a
4838 character is initialized from one map overtop a real from the other, only one
4839 byte of the real is actually initialized.) Unfortunately we don't know the
4840 size of the union right now, so we can't generate a proper initializer, but
4841 we use a NULL expr as a placeholder and do the right thing later in
4842 gfc_trans_subcomponent_assign.
4845 generate_union_initializer (gfc_component
*un
)
4847 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4850 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4851 placeholder
->ts
= un
->ts
;
4856 /* Get the user-specified initializer for a union, if any. This means the user
4857 has said to initialize component(s) of a map. For simplicity's sake we
4858 only allow the user to initialize the first map. We don't have to worry
4859 about overlapping initializers as they are released early in resolution (see
4860 resolve_fl_struct). */
4863 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4866 gfc_expr
*init
=NULL
;
4868 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4871 for (map
= union_type
->components
; map
; map
= map
->next
)
4873 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4875 init
= gfc_default_initializer (&map
->ts
);
4889 class_allocatable (gfc_component
*comp
)
4891 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4892 && CLASS_DATA (comp
)->attr
.allocatable
;
4896 class_pointer (gfc_component
*comp
)
4898 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4899 && CLASS_DATA (comp
)->attr
.pointer
;
4903 comp_allocatable (gfc_component
*comp
)
4905 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4909 comp_pointer (gfc_component
*comp
)
4911 return comp
->attr
.pointer
4912 || comp
->attr
.proc_pointer
4913 || comp
->attr
.class_pointer
4914 || class_pointer (comp
);
4917 /* Fetch or generate an initializer for the given component.
4918 Only generate an initializer if generate is true. */
4921 component_initializer (gfc_component
*c
, bool generate
)
4923 gfc_expr
*init
= NULL
;
4925 /* Allocatable components always get EXPR_NULL.
4926 Pointer components are only initialized when generating, and only if they
4927 do not already have an initializer. */
4928 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4930 init
= gfc_get_null_expr (&c
->loc
);
4935 /* See if we can find the initializer immediately. */
4936 if (c
->initializer
|| !generate
)
4937 return c
->initializer
;
4939 /* Recursively handle derived type components. */
4940 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4941 init
= gfc_generate_initializer (&c
->ts
, true);
4943 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4945 gfc_component
*map
= NULL
;
4946 gfc_constructor
*ctor
;
4947 gfc_expr
*user_init
;
4949 /* If we don't have a user initializer and we aren't generating one, this
4950 union has no initializer. */
4951 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4952 if (!user_init
&& !generate
)
4955 /* Otherwise use a structure constructor. */
4956 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4960 /* If we are to generate an initializer for the union, add a constructor
4961 which initializes the whole union first. */
4964 ctor
= gfc_constructor_get ();
4965 ctor
->expr
= generate_union_initializer (c
);
4966 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4969 /* If we found an initializer in one of our maps, apply it. Note this
4970 is applied _after_ the entire-union initializer above if any. */
4973 ctor
= gfc_constructor_get ();
4974 ctor
->expr
= user_init
;
4975 ctor
->n
.component
= map
;
4976 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4980 /* Treat simple components like locals. */
4983 /* We MUST give an initializer, so force generation. */
4984 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4985 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4992 /* Get an expression for a default initializer of a derived type. */
4995 gfc_default_initializer (gfc_typespec
*ts
)
4997 return gfc_generate_initializer (ts
, false);
5000 /* Generate an initializer expression for an iso_c_binding type
5001 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
5004 generate_isocbinding_initializer (gfc_symbol
*derived
)
5006 /* The initializers have already been built into the c_null_[fun]ptr symbols
5007 from gen_special_c_interop_ptr. */
5008 gfc_symtree
*npsym
= NULL
;
5009 if (0 == strcmp (derived
->name
, "c_ptr"))
5010 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
5011 else if (0 == strcmp (derived
->name
, "c_funptr"))
5012 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
5014 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
5015 " type, expected %<c_ptr%> or %<c_funptr%>");
5018 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
5019 init
->symtree
= npsym
;
5020 init
->ts
.is_iso_c
= true;
5027 /* Get or generate an expression for a default initializer of a derived type.
5028 If -finit-derived is specified, generate default initialization expressions
5029 for components that lack them when generate is set. */
5032 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
5034 gfc_expr
*init
, *tmp
;
5035 gfc_component
*comp
;
5037 generate
= flag_init_derived
&& generate
;
5039 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
5040 return generate_isocbinding_initializer (ts
->u
.derived
);
5042 /* See if we have a default initializer in this, but not in nested
5043 types (otherwise we could use gfc_has_default_initializer()).
5044 We don't need to check if we are going to generate them. */
5045 comp
= ts
->u
.derived
->components
;
5048 for (; comp
; comp
= comp
->next
)
5049 if (comp
->initializer
|| comp_allocatable (comp
))
5056 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
5057 &ts
->u
.derived
->declared_at
);
5060 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
5062 gfc_constructor
*ctor
= gfc_constructor_get();
5064 /* Fetch or generate an initializer for the component. */
5065 tmp
= component_initializer (comp
, generate
);
5068 /* Save the component ref for STRUCTUREs and UNIONs. */
5069 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
5070 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
5071 ctor
->n
.component
= comp
;
5073 /* If the initializer was not generated, we need a copy. */
5074 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
5075 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
5076 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
5079 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
5085 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5092 /* Given a symbol, create an expression node with that symbol as a
5093 variable. If the symbol is array valued, setup a reference of the
5097 gfc_get_variable_expr (gfc_symtree
*var
)
5101 e
= gfc_get_expr ();
5102 e
->expr_type
= EXPR_VARIABLE
;
5104 e
->ts
= var
->n
.sym
->ts
;
5106 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
5107 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
5108 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
5109 && CLASS_DATA (var
->n
.sym
)->as
)))
5111 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
5112 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
5113 e
->ref
= gfc_get_ref ();
5114 e
->ref
->type
= REF_ARRAY
;
5115 e
->ref
->u
.ar
.type
= AR_FULL
;
5116 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
5117 ? CLASS_DATA (var
->n
.sym
)->as
5125 /* Adds a full array reference to an expression, as needed. */
5128 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
5131 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5136 ref
->next
= gfc_get_ref ();
5141 e
->ref
= gfc_get_ref ();
5144 ref
->type
= REF_ARRAY
;
5145 ref
->u
.ar
.type
= AR_FULL
;
5146 ref
->u
.ar
.dimen
= e
->rank
;
5147 ref
->u
.ar
.where
= e
->where
;
5153 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
5157 lval
= gfc_get_expr ();
5158 lval
->expr_type
= EXPR_VARIABLE
;
5159 lval
->where
= sym
->declared_at
;
5161 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5163 /* It will always be a full array. */
5164 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5165 lval
->rank
= as
? as
->rank
: 0;
5167 gfc_add_full_array_ref (lval
, as
);
5172 /* Returns the array_spec of a full array expression. A NULL is
5173 returned otherwise. */
5175 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
5180 if (expr
->rank
== 0)
5183 /* Follow any component references. */
5184 if (expr
->expr_type
== EXPR_VARIABLE
5185 || expr
->expr_type
== EXPR_CONSTANT
)
5188 as
= expr
->symtree
->n
.sym
->as
;
5192 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5197 as
= ref
->u
.c
.component
->as
;
5206 switch (ref
->u
.ar
.type
)
5229 /* General expression traversal function. */
5232 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5233 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5238 gfc_actual_arglist
*args
;
5245 if ((*func
) (expr
, sym
, &f
))
5248 if (expr
->ts
.type
== BT_CHARACTER
5250 && expr
->ts
.u
.cl
->length
5251 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5252 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5255 switch (expr
->expr_type
)
5260 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5262 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5270 case EXPR_SUBSTRING
:
5273 case EXPR_STRUCTURE
:
5275 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5276 c
; c
= gfc_constructor_next (c
))
5278 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5282 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5284 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5286 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5288 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5295 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5297 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5313 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5315 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5317 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5319 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5325 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5327 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5332 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5333 && ref
->u
.c
.component
->ts
.u
.cl
5334 && ref
->u
.c
.component
->ts
.u
.cl
->length
5335 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5337 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5341 if (ref
->u
.c
.component
->as
)
5342 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5343 + ref
->u
.c
.component
->as
->corank
; i
++)
5345 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5348 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5365 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5368 expr_set_symbols_referenced (gfc_expr
*expr
,
5369 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5370 int *f ATTRIBUTE_UNUSED
)
5372 if (expr
->expr_type
!= EXPR_VARIABLE
)
5374 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5379 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5381 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5385 /* Determine if an expression is a procedure pointer component and return
5386 the component in that case. Otherwise return NULL. */
5389 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5393 if (!expr
|| !expr
->ref
)
5400 if (ref
->type
== REF_COMPONENT
5401 && ref
->u
.c
.component
->attr
.proc_pointer
)
5402 return ref
->u
.c
.component
;
5408 /* Determine if an expression is a procedure pointer component. */
5411 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5413 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5417 /* Determine if an expression is a function with an allocatable class scalar
5420 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5422 if (expr
->expr_type
== EXPR_FUNCTION
5423 && expr
->value
.function
.esym
5424 && expr
->value
.function
.esym
->result
5425 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5426 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5427 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5434 /* Determine if an expression is a function with an allocatable class array
5437 gfc_is_class_array_function (gfc_expr
*expr
)
5439 if (expr
->expr_type
== EXPR_FUNCTION
5440 && expr
->value
.function
.esym
5441 && expr
->value
.function
.esym
->result
5442 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5443 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5444 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5445 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5452 /* Walk an expression tree and check each variable encountered for being typed.
5453 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5454 mode as is a basic arithmetic expression using those; this is for things in
5457 INTEGER :: arr(n), n
5458 INTEGER :: arr(n + 1), n
5460 The namespace is needed for IMPLICIT typing. */
5462 static gfc_namespace
* check_typed_ns
;
5465 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5466 int* f ATTRIBUTE_UNUSED
)
5470 if (e
->expr_type
!= EXPR_VARIABLE
)
5473 gcc_assert (e
->symtree
);
5474 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5481 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5485 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5489 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5490 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5492 if (e
->expr_type
== EXPR_OP
)
5496 gcc_assert (e
->value
.op
.op1
);
5497 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5499 if (t
&& e
->value
.op
.op2
)
5500 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5506 /* Otherwise, walk the expression and do it strictly. */
5507 check_typed_ns
= ns
;
5508 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5510 return error_found
? false : true;
5514 /* This function returns true if it contains any references to PDT KIND
5515 or LEN parameters. */
5518 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5519 int* f ATTRIBUTE_UNUSED
)
5521 if (e
->expr_type
!= EXPR_VARIABLE
)
5524 gcc_assert (e
->symtree
);
5525 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5526 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5534 gfc_derived_parameter_expr (gfc_expr
*e
)
5536 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5540 /* This function returns the overall type of a type parameter spec list.
5541 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5542 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5543 unless derived is not NULL. In this latter case, all the LEN parameters
5544 must be either assumed or deferred for the return argument to be set to
5545 anything other than SPEC_EXPLICIT. */
5548 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5550 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5552 bool seen_assumed
= false;
5553 bool seen_deferred
= false;
5555 if (derived
== NULL
)
5557 for (; param_list
; param_list
= param_list
->next
)
5558 if (param_list
->spec_type
== SPEC_ASSUMED
5559 || param_list
->spec_type
== SPEC_DEFERRED
)
5560 return param_list
->spec_type
;
5564 for (; param_list
; param_list
= param_list
->next
)
5566 c
= gfc_find_component (derived
, param_list
->name
,
5568 gcc_assert (c
!= NULL
);
5569 if (c
->attr
.pdt_kind
)
5571 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5572 return SPEC_EXPLICIT
;
5573 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5574 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5575 if (seen_assumed
&& seen_deferred
)
5576 return SPEC_EXPLICIT
;
5578 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5585 gfc_ref_this_image (gfc_ref
*ref
)
5589 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5591 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5592 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5599 gfc_find_team_co (gfc_expr
*e
)
5603 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5604 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5605 return ref
->u
.ar
.team
;
5607 if (e
->value
.function
.actual
->expr
)
5608 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5610 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5611 return ref
->u
.ar
.team
;
5617 gfc_find_stat_co (gfc_expr
*e
)
5621 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5622 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5623 return ref
->u
.ar
.stat
;
5625 if (e
->value
.function
.actual
->expr
)
5626 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5628 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5629 return ref
->u
.ar
.stat
;
5635 gfc_is_coindexed (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 !gfc_ref_this_image (ref
);
5647 /* Coarrays are variables with a corank but not being coindexed. However, also
5648 the following is a coarray: A subobject of a coarray is a coarray if it does
5649 not have any cosubscripts, vector subscripts, allocatable component
5650 selection, or pointer component selection. (F2008, 2.4.7) */
5653 gfc_is_coarray (gfc_expr
*e
)
5657 gfc_component
*comp
;
5662 if (e
->expr_type
!= EXPR_VARIABLE
)
5666 sym
= e
->symtree
->n
.sym
;
5668 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5669 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5671 coarray
= sym
->attr
.codimension
;
5673 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5677 comp
= ref
->u
.c
.component
;
5678 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5679 && (CLASS_DATA (comp
)->attr
.class_pointer
5680 || CLASS_DATA (comp
)->attr
.allocatable
))
5683 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5685 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5688 coarray
= comp
->attr
.codimension
;
5696 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5702 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5703 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5715 return coarray
&& !coindexed
;
5720 gfc_get_corank (gfc_expr
*e
)
5725 if (!gfc_is_coarray (e
))
5728 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5729 corank
= e
->ts
.u
.derived
->components
->as
5730 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5732 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5734 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5736 if (ref
->type
== REF_ARRAY
)
5737 corank
= ref
->u
.ar
.as
->corank
;
5738 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5745 /* Check whether the expression has an ultimate allocatable component.
5746 Being itself allocatable does not count. */
5748 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5750 gfc_ref
*ref
, *last
= NULL
;
5752 if (e
->expr_type
!= EXPR_VARIABLE
)
5755 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5756 if (ref
->type
== REF_COMPONENT
)
5759 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5760 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5761 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5762 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5766 if (e
->ts
.type
== BT_CLASS
)
5767 return CLASS_DATA (e
)->attr
.alloc_comp
;
5768 else if (e
->ts
.type
== BT_DERIVED
)
5769 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5775 /* Check whether the expression has an pointer component.
5776 Being itself a pointer does not count. */
5778 gfc_has_ultimate_pointer (gfc_expr
*e
)
5780 gfc_ref
*ref
, *last
= NULL
;
5782 if (e
->expr_type
!= EXPR_VARIABLE
)
5785 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5786 if (ref
->type
== REF_COMPONENT
)
5789 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5790 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5791 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5792 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5796 if (e
->ts
.type
== BT_CLASS
)
5797 return CLASS_DATA (e
)->attr
.pointer_comp
;
5798 else if (e
->ts
.type
== BT_DERIVED
)
5799 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5805 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5806 Note: A scalar is not regarded as "simply contiguous" by the standard.
5807 if bool is not strict, some further checks are done - for instance,
5808 a "(::1)" is accepted. */
5811 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5815 gfc_array_ref
*ar
= NULL
;
5816 gfc_ref
*ref
, *part_ref
= NULL
;
5819 if (expr
->expr_type
== EXPR_ARRAY
)
5822 if (expr
->expr_type
== EXPR_FUNCTION
)
5824 if (expr
->value
.function
.esym
)
5825 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5828 /* Type-bound procedures. */
5829 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5830 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5834 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5835 if (r
->type
== REF_COMPONENT
)
5838 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5839 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5842 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5845 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5848 if (!permit_element
&& expr
->rank
== 0)
5851 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5854 return false; /* Array shall be last part-ref. */
5856 if (ref
->type
== REF_COMPONENT
)
5858 else if (ref
->type
== REF_SUBSTRING
)
5860 else if (ref
->type
== REF_INQUIRY
)
5862 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5866 sym
= expr
->symtree
->n
.sym
;
5867 if (expr
->ts
.type
!= BT_CLASS
5869 && !part_ref
->u
.c
.component
->attr
.contiguous
5870 && part_ref
->u
.c
.component
->attr
.pointer
)
5872 && !sym
->attr
.contiguous
5873 && (sym
->attr
.pointer
5874 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5875 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5878 if (!ar
|| ar
->type
== AR_FULL
)
5881 gcc_assert (ar
->type
== AR_SECTION
);
5883 /* Check for simply contiguous array */
5885 for (i
= 0; i
< ar
->dimen
; i
++)
5887 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5890 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5896 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5899 /* If the previous section was not contiguous, that's an error,
5900 unless we have effective only one element and checking is not
5902 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5903 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5904 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5905 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5906 ar
->end
[i
]->value
.integer
) != 0))
5909 /* Following the standard, "(::1)" or - if known at compile time -
5910 "(lbound:ubound)" are not simply contiguous; if strict
5911 is false, they are regarded as simply contiguous. */
5912 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5913 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5914 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5918 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5919 || !ar
->as
->lower
[i
]
5920 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5921 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5922 ar
->as
->lower
[i
]->value
.integer
) != 0))
5926 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5927 || !ar
->as
->upper
[i
]
5928 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5929 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5930 ar
->as
->upper
[i
]->value
.integer
) != 0))
5937 /* Return true if the expression is guaranteed to be non-contiguous,
5938 false if we cannot prove anything. It is probably best to call
5939 this after gfc_is_simply_contiguous. If neither of them returns
5940 true, we cannot say (at compile-time). */
5943 gfc_is_not_contiguous (gfc_expr
*array
)
5946 gfc_array_ref
*ar
= NULL
;
5948 bool previous_incomplete
;
5950 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
5952 /* Array-ref shall be last ref. */
5954 if (ar
&& ar
->type
!= AR_ELEMENT
)
5957 if (ref
->type
== REF_ARRAY
)
5961 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
5964 previous_incomplete
= false;
5966 /* Check if we can prove that the array is not contiguous. */
5968 for (i
= 0; i
< ar
->dimen
; i
++)
5970 mpz_t arr_size
, ref_size
;
5972 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
5974 if (gfc_dep_difference (ar
->as
->upper
[i
], ar
->as
->lower
[i
], &arr_size
))
5976 /* a(2:4,2:) is known to be non-contiguous, but
5977 a(2:4,i:i) can be contiguous. */
5978 mpz_add_ui (arr_size
, arr_size
, 1L);
5979 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
5981 mpz_clear (arr_size
);
5982 mpz_clear (ref_size
);
5985 else if (mpz_cmp (arr_size
, ref_size
) != 0)
5986 previous_incomplete
= true;
5988 mpz_clear (arr_size
);
5991 /* Check for a(::2), i.e. where the stride is not unity.
5992 This is only done if there is more than one element in
5993 the reference along this dimension. */
5995 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
5996 && ar
->dimen_type
[i
] == DIMEN_RANGE
5997 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5998 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
6000 mpz_clear (ref_size
);
6004 mpz_clear (ref_size
);
6007 /* We didn't find anything definitive. */
6011 /* Build call to an intrinsic procedure. The number of arguments has to be
6012 passed (rather than ending the list with a NULL value) because we may
6013 want to add arguments but with a NULL-expression. */
6016 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
6017 locus where
, unsigned numarg
, ...)
6020 gfc_actual_arglist
* atail
;
6021 gfc_intrinsic_sym
* isym
;
6024 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
6026 isym
= gfc_intrinsic_function_by_id (id
);
6029 result
= gfc_get_expr ();
6030 result
->expr_type
= EXPR_FUNCTION
;
6031 result
->ts
= isym
->ts
;
6032 result
->where
= where
;
6033 result
->value
.function
.name
= mangled_name
;
6034 result
->value
.function
.isym
= isym
;
6036 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
6037 gfc_commit_symbol (result
->symtree
->n
.sym
);
6038 gcc_assert (result
->symtree
6039 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
6040 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
6041 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
6042 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6043 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
6044 result
->symtree
->n
.sym
->attr
.artificial
= 1;
6046 va_start (ap
, numarg
);
6048 for (i
= 0; i
< numarg
; ++i
)
6052 atail
->next
= gfc_get_actual_arglist ();
6053 atail
= atail
->next
;
6056 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
6058 atail
->expr
= va_arg (ap
, gfc_expr
*);
6066 /* Check if an expression may appear in a variable definition context
6067 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
6068 This is called from the various places when resolving
6069 the pieces that make up such a context.
6070 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
6071 variables), some checks are not performed.
6073 Optionally, a possible error message can be suppressed if context is NULL
6074 and just the return status (true / false) be requested. */
6077 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
6078 bool own_scope
, const char* context
)
6080 gfc_symbol
* sym
= NULL
;
6082 bool check_intentin
;
6084 symbol_attribute attr
;
6088 if (e
->expr_type
== EXPR_VARIABLE
)
6090 gcc_assert (e
->symtree
);
6091 sym
= e
->symtree
->n
.sym
;
6093 else if (e
->expr_type
== EXPR_FUNCTION
)
6095 gcc_assert (e
->symtree
);
6096 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
6099 attr
= gfc_expr_attr (e
);
6100 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
6102 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
6105 gfc_error ("Fortran 2008: Pointer functions in variable definition"
6106 " context (%s) at %L", context
, &e
->where
);
6110 else if (e
->expr_type
!= EXPR_VARIABLE
)
6113 gfc_error ("Non-variable expression in variable definition context (%s)"
6114 " at %L", context
, &e
->where
);
6118 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
6121 gfc_error ("Named constant %qs in variable definition context (%s)"
6122 " at %L", sym
->name
, context
, &e
->where
);
6125 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
6126 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
6127 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
)
6128 && !(sym
->attr
.flavor
== FL_PROCEDURE
6129 && sym
->attr
.function
&& sym
->attr
.pointer
))
6132 gfc_error ("%qs in variable definition context (%s) at %L is not"
6133 " a variable", sym
->name
, context
, &e
->where
);
6137 /* Find out whether the expr is a pointer; this also means following
6138 component references to the last one. */
6139 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
6140 if (pointer
&& !is_pointer
)
6143 gfc_error ("Non-POINTER in pointer association context (%s)"
6144 " at %L", context
, &e
->where
);
6148 if (e
->ts
.type
== BT_DERIVED
6149 && e
->ts
.u
.derived
== NULL
)
6152 gfc_error ("Type inaccessible in variable definition context (%s) "
6153 "at %L", context
, &e
->where
);
6160 || (e
->ts
.type
== BT_DERIVED
6161 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6162 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
6165 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6166 context
, &e
->where
);
6170 /* TS18508, C702/C203. */
6173 || (e
->ts
.type
== BT_DERIVED
6174 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6175 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
6178 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6179 context
, &e
->where
);
6183 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6184 component of sub-component of a pointer; we need to distinguish
6185 assignment to a pointer component from pointer-assignment to a pointer
6186 component. Note that (normal) assignment to procedure pointers is not
6188 check_intentin
= !own_scope
;
6189 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
6190 && CLASS_DATA (sym
))
6191 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
6192 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
6194 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
6195 check_intentin
= false;
6196 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
6198 ptr_component
= true;
6200 check_intentin
= false;
6202 if (ref
->type
== REF_INQUIRY
6203 && (ref
->u
.i
== INQUIRY_KIND
|| ref
->u
.i
== INQUIRY_LEN
))
6206 gfc_error ("%qs parameter inquiry for %qs in "
6207 "variable definition context (%s) at %L",
6208 ref
->u
.i
== INQUIRY_KIND
? "KIND" : "LEN",
6209 sym
->name
, context
, &e
->where
);
6215 && (sym
->attr
.intent
== INTENT_IN
6216 || (sym
->attr
.select_type_temporary
&& sym
->assoc
6217 && sym
->assoc
->target
&& sym
->assoc
->target
->symtree
6218 && sym
->assoc
->target
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)))
6220 if (pointer
&& is_pointer
)
6223 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6224 " association context (%s) at %L",
6225 sym
->name
, context
, &e
->where
);
6228 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
6230 const char *name
= sym
->attr
.select_type_temporary
6231 ? sym
->assoc
->target
->symtree
->name
: sym
->name
;
6233 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6234 " definition context (%s) at %L",
6235 name
, context
, &e
->where
);
6240 /* PROTECTED and use-associated. */
6241 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
6243 if (pointer
&& is_pointer
)
6246 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6247 " pointer association context (%s) at %L",
6248 sym
->name
, context
, &e
->where
);
6251 if (!pointer
&& !is_pointer
)
6254 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6255 " variable definition context (%s) at %L",
6256 sym
->name
, context
, &e
->where
);
6261 /* Variable not assignable from a PURE procedure but appears in
6262 variable definition context. */
6263 own_scope
= own_scope
6264 || (sym
->attr
.result
&& sym
->ns
->proc_name
6265 && sym
== sym
->ns
->proc_name
->result
);
6266 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6269 gfc_error ("Variable %qs cannot appear in a variable definition"
6270 " context (%s) at %L in PURE procedure",
6271 sym
->name
, context
, &e
->where
);
6275 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6276 && gfc_impure_variable (sym
))
6281 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6283 sym
= ns
->proc_name
;
6286 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6288 sym
->attr
.implicit_pure
= 0;
6293 /* Check variable definition context for associate-names. */
6294 if (!pointer
&& sym
->assoc
&& !sym
->attr
.select_rank_temporary
)
6297 gfc_association_list
* assoc
;
6299 gcc_assert (sym
->assoc
->target
);
6301 /* If this is a SELECT TYPE temporary (the association is used internally
6302 for SELECT TYPE), silently go over to the target. */
6303 if (sym
->attr
.select_type_temporary
)
6305 gfc_expr
* t
= sym
->assoc
->target
;
6307 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6308 name
= t
->symtree
->name
;
6310 if (t
->symtree
->n
.sym
->assoc
)
6311 assoc
= t
->symtree
->n
.sym
->assoc
;
6320 gcc_assert (name
&& assoc
);
6322 /* Is association to a valid variable? */
6323 if (!assoc
->variable
)
6327 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6328 gfc_error ("%qs at %L associated to vector-indexed target"
6329 " cannot be used in a variable definition"
6331 name
, &e
->where
, context
);
6333 gfc_error ("%qs at %L associated to expression"
6334 " cannot be used in a variable definition"
6336 name
, &e
->where
, context
);
6341 /* Target must be allowed to appear in a variable definition context. */
6342 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6345 gfc_error ("Associate-name %qs cannot appear in a variable"
6346 " definition context (%s) at %L because its target"
6347 " at %L cannot, either",
6348 name
, context
, &e
->where
,
6349 &assoc
->target
->where
);
6354 /* Check for same value in vector expression subscript. */
6357 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6358 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6359 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6360 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6361 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6363 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6364 if (arr
->expr_type
== EXPR_ARRAY
)
6366 gfc_constructor
*c
, *n
;
6369 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6370 c
!= NULL
; c
= gfc_constructor_next (c
))
6372 if (c
== NULL
|| c
->iterator
!= NULL
)
6377 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6378 n
= gfc_constructor_next (n
))
6380 if (n
->iterator
!= NULL
)
6384 if (gfc_dep_compare_expr (ec
, en
) == 0)
6387 gfc_error_now ("Elements with the same value "
6388 "at %L and %L in vector "
6389 "subscript in a variable "
6390 "definition context (%s)",
6391 &(ec
->where
), &(en
->where
),