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 lhs_attr
= gfc_expr_attr (lvalue
);
3819 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3821 gfc_error ("Pointer assignment target is not a POINTER at %L",
3826 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3827 && !lhs_attr
.proc_pointer
)
3829 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3830 "l-value since it is a procedure",
3831 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3835 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3838 same_rank
= lvalue
->rank
== rvalue
->rank
;
3839 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3841 if (ref
->type
== REF_COMPONENT
)
3842 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3844 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3848 if (ref
->u
.ar
.type
== AR_FULL
)
3851 if (ref
->u
.ar
.type
!= AR_SECTION
)
3853 gfc_error ("Expected bounds specification for %qs at %L",
3854 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3858 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3859 "for %qs in pointer assignment at %L",
3860 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3863 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3865 * (C1017) If bounds-spec-list is specified, the number of
3866 * bounds-specs shall equal the rank of data-pointer-object.
3868 * If bounds-spec-list appears, it specifies the lower bounds.
3870 * (C1018) If bounds-remapping-list is specified, the number of
3871 * bounds-remappings shall equal the rank of data-pointer-object.
3873 * If bounds-remapping-list appears, it specifies the upper and
3874 * lower bounds of each dimension of the pointer; the pointer target
3875 * shall be simply contiguous or of rank one.
3877 * (C1019) If bounds-remapping-list is not specified, the ranks of
3878 * data-pointer-object and data-target shall be the same.
3880 * Thus when bounds are given, all lbounds are necessary and either
3881 * all or none of the upper bounds; no strides are allowed. If the
3882 * upper bounds are present, we may do rank remapping. */
3883 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3885 if (ref
->u
.ar
.stride
[dim
])
3887 gfc_error ("Stride must not be present at %L",
3891 if (!same_rank
&& (!ref
->u
.ar
.start
[dim
] ||!ref
->u
.ar
.end
[dim
]))
3893 gfc_error ("Rank remapping requires a "
3894 "list of %<lower-bound : upper-bound%> "
3895 "specifications at %L", &lvalue
->where
);
3898 if (!ref
->u
.ar
.start
[dim
]
3899 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3901 gfc_error ("Expected list of %<lower-bound :%> or "
3902 "list of %<lower-bound : upper-bound%> "
3903 "specifications at %L", &lvalue
->where
);
3908 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3911 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
]))
3913 gfc_error ("Rank remapping requires a "
3914 "list of %<lower-bound : upper-bound%> "
3915 "specifications at %L", &lvalue
->where
);
3918 if (!rank_remap
&& ref
->u
.ar
.end
[dim
])
3920 gfc_error ("Expected list of %<lower-bound :%> or "
3921 "list of %<lower-bound : upper-bound%> "
3922 "specifications at %L", &lvalue
->where
);
3930 is_pure
= gfc_pure (NULL
);
3931 is_implicit_pure
= gfc_implicit_pure (NULL
);
3933 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3934 kind, etc for lvalue and rvalue must match, and rvalue must be a
3935 pure variable if we're in a pure function. */
3936 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3939 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3940 if (lvalue
->expr_type
== EXPR_VARIABLE
3941 && gfc_is_coindexed (lvalue
))
3944 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3945 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3947 gfc_error ("Pointer object at %L shall not have a coindex",
3953 /* Checks on rvalue for procedure pointer assignments. */
3958 gfc_component
*comp1
, *comp2
;
3961 attr
= gfc_expr_attr (rvalue
);
3962 if (!((rvalue
->expr_type
== EXPR_NULL
)
3963 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3964 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3965 || (rvalue
->expr_type
== EXPR_VARIABLE
3966 && attr
.flavor
== FL_PROCEDURE
)))
3968 gfc_error ("Invalid procedure pointer assignment at %L",
3973 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3975 /* Check for intrinsics. */
3976 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3977 if (!sym
->attr
.intrinsic
3978 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3979 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3981 sym
->attr
.intrinsic
= 1;
3982 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3983 attr
= gfc_expr_attr (rvalue
);
3985 /* Check for result of embracing function. */
3986 if (sym
->attr
.function
&& sym
->result
== sym
)
3990 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3991 if (sym
== ns
->proc_name
)
3993 gfc_error ("Function result %qs is invalid as proc-target "
3994 "in procedure pointer assignment at %L",
3995 sym
->name
, &rvalue
->where
);
4002 gfc_error ("Abstract interface %qs is invalid "
4003 "in procedure pointer assignment at %L",
4004 rvalue
->symtree
->name
, &rvalue
->where
);
4007 /* Check for F08:C729. */
4008 if (attr
.flavor
== FL_PROCEDURE
)
4010 if (attr
.proc
== PROC_ST_FUNCTION
)
4012 gfc_error ("Statement function %qs is invalid "
4013 "in procedure pointer assignment at %L",
4014 rvalue
->symtree
->name
, &rvalue
->where
);
4017 if (attr
.proc
== PROC_INTERNAL
&&
4018 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
4019 "is invalid in procedure pointer assignment "
4020 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
4022 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
4023 attr
.subroutine
) == 0)
4025 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
4026 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
4030 /* Check for F08:C730. */
4031 if (attr
.elemental
&& !attr
.intrinsic
)
4033 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
4034 "in procedure pointer assignment at %L",
4035 rvalue
->symtree
->name
, &rvalue
->where
);
4039 /* Ensure that the calling convention is the same. As other attributes
4040 such as DLLEXPORT may differ, one explicitly only tests for the
4041 calling conventions. */
4042 if (rvalue
->expr_type
== EXPR_VARIABLE
4043 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
4044 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4046 symbol_attribute calls
;
4049 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
4050 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
4051 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
4053 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4054 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
4056 gfc_error ("Mismatch in the procedure pointer assignment "
4057 "at %L: mismatch in the calling convention",
4063 comp1
= gfc_get_proc_ptr_comp (lvalue
);
4065 s1
= comp1
->ts
.interface
;
4068 s1
= lvalue
->symtree
->n
.sym
;
4069 if (s1
->ts
.interface
)
4070 s1
= s1
->ts
.interface
;
4073 comp2
= gfc_get_proc_ptr_comp (rvalue
);
4076 if (rvalue
->expr_type
== EXPR_FUNCTION
)
4078 s2
= comp2
->ts
.interface
->result
;
4083 s2
= comp2
->ts
.interface
;
4087 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
4089 if (rvalue
->value
.function
.esym
)
4090 s2
= rvalue
->value
.function
.esym
->result
;
4092 s2
= rvalue
->symtree
->n
.sym
->result
;
4098 s2
= rvalue
->symtree
->n
.sym
;
4102 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
4103 s2
= s2
->ts
.interface
;
4105 /* Special check for the case of absent interface on the lvalue.
4106 * All other interface checks are done below. */
4107 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
4109 gfc_error ("Interface mismatch in procedure pointer assignment "
4110 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
4114 /* F08:7.2.2.4 (4) */
4115 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
4119 gfc_error ("Explicit interface required for component %qs at %L: %s",
4120 comp1
->name
, &lvalue
->where
, err
);
4123 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
4125 gfc_error ("Explicit interface required for %qs at %L: %s",
4126 s1
->name
, &lvalue
->where
, err
);
4130 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
4134 gfc_error ("Explicit interface required for component %qs at %L: %s",
4135 comp2
->name
, &rvalue
->where
, err
);
4138 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
4140 gfc_error ("Explicit interface required for %qs at %L: %s",
4141 s2
->name
, &rvalue
->where
, err
);
4146 if (s1
== s2
|| !s1
|| !s2
)
4149 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
4150 err
, sizeof(err
), NULL
, NULL
))
4152 gfc_error ("Interface mismatch in procedure pointer assignment "
4153 "at %L: %s", &rvalue
->where
, err
);
4157 /* Check F2008Cor2, C729. */
4158 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4159 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4161 gfc_error ("Procedure pointer target %qs at %L must be either an "
4162 "intrinsic, host or use associated, referenced or have "
4163 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4171 /* A non-proc pointer cannot point to a constant. */
4172 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4174 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4180 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4182 /* Check for F03:C717. */
4183 if (UNLIMITED_POLY (rvalue
)
4184 && !(UNLIMITED_POLY (lvalue
)
4185 || (lvalue
->ts
.type
== BT_DERIVED
4186 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4187 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4188 gfc_error ("Data-pointer-object at %L must be unlimited "
4189 "polymorphic, or of a type with the BIND or SEQUENCE "
4190 "attribute, to be compatible with an unlimited "
4191 "polymorphic target", &lvalue
->where
);
4192 else if (!suppress_type_test
)
4193 gfc_error ("Different types in pointer assignment at %L; "
4194 "attempted assignment of %s to %s", &lvalue
->where
,
4195 gfc_typename (rvalue
), gfc_typename (lvalue
));
4199 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4201 gfc_error ("Different kind type parameters in pointer "
4202 "assignment at %L", &lvalue
->where
);
4206 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4208 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4212 /* Make sure the vtab is present. */
4213 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4214 gfc_find_vtab (&rvalue
->ts
);
4216 /* Check rank remapping. */
4221 /* If this can be determined, check that the target must be at least as
4222 large as the pointer assigned to it is. */
4223 if (gfc_array_size (lvalue
, &lsize
)
4224 && gfc_array_size (rvalue
, &rsize
)
4225 && mpz_cmp (rsize
, lsize
) < 0)
4227 gfc_error ("Rank remapping target is smaller than size of the"
4228 " pointer (%ld < %ld) at %L",
4229 mpz_get_si (rsize
), mpz_get_si (lsize
),
4234 /* The target must be either rank one or it must be simply contiguous
4235 and F2008 must be allowed. */
4236 if (rvalue
->rank
!= 1)
4238 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4240 gfc_error ("Rank remapping target must be rank 1 or"
4241 " simply contiguous at %L", &rvalue
->where
);
4244 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4245 "rank 1 at %L", &rvalue
->where
))
4250 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4251 if (rvalue
->expr_type
== EXPR_NULL
)
4254 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4255 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4257 attr
= gfc_expr_attr (rvalue
);
4259 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4261 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4262 to caf_get. Map this to the same error message as below when it is
4263 still a variable expression. */
4264 if (rvalue
->value
.function
.isym
4265 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4266 /* The test above might need to be extend when F08, Note 5.4 has to be
4267 interpreted in the way that target and pointer with the same coindex
4269 gfc_error ("Data target at %L shall not have a coindex",
4272 gfc_error ("Target expression in pointer assignment "
4273 "at %L must deliver a pointer result",
4283 if (gfc_is_size_zero_array (rvalue
))
4285 gfc_error ("Zero-sized array detected at %L where an entity with "
4286 "the TARGET attribute is expected", &rvalue
->where
);
4289 else if (!rvalue
->symtree
)
4291 gfc_error ("Pointer assignment target in initialization expression "
4292 "does not have the TARGET attribute at %L",
4297 sym
= rvalue
->symtree
->n
.sym
;
4299 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4300 target
= CLASS_DATA (sym
)->attr
.target
;
4302 target
= sym
->attr
.target
;
4304 if (!target
&& !proc_pointer
)
4306 gfc_error ("Pointer assignment target in initialization expression "
4307 "does not have the TARGET attribute at %L",
4314 if (!attr
.target
&& !attr
.pointer
)
4316 gfc_error ("Pointer assignment target is neither TARGET "
4317 "nor POINTER at %L", &rvalue
->where
);
4322 if (lvalue
->ts
.type
== BT_CHARACTER
)
4324 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4329 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4331 gfc_error ("Bad target in pointer assignment in PURE "
4332 "procedure at %L", &rvalue
->where
);
4335 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4336 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4338 if (gfc_has_vector_index (rvalue
))
4340 gfc_error ("Pointer assignment with vector subscript "
4341 "on rhs at %L", &rvalue
->where
);
4345 if (attr
.is_protected
&& attr
.use_assoc
4346 && !(attr
.pointer
|| attr
.proc_pointer
))
4348 gfc_error ("Pointer assignment target has PROTECTED "
4349 "attribute at %L", &rvalue
->where
);
4353 /* F2008, C725. For PURE also C1283. */
4354 if (rvalue
->expr_type
== EXPR_VARIABLE
4355 && gfc_is_coindexed (rvalue
))
4358 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4359 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4361 gfc_error ("Data target at %L shall not have a coindex",
4367 /* Warn for assignments of contiguous pointers to targets which is not
4368 contiguous. Be lenient in the definition of what counts as
4371 if (lhs_attr
.contiguous
4372 && lhs_attr
.dimension
> 0)
4374 if (gfc_is_not_contiguous (rvalue
))
4376 gfc_error ("Assignment to contiguous pointer from "
4377 "non-contiguous target at %L", &rvalue
->where
);
4380 if (!gfc_is_simply_contiguous (rvalue
, false, true))
4381 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4382 "non-contiguous target at %L", &rvalue
->where
);
4385 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4386 if (warn_target_lifetime
4387 && rvalue
->expr_type
== EXPR_VARIABLE
4388 && !rvalue
->symtree
->n
.sym
->attr
.save
4389 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4390 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4391 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4392 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4393 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4398 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4399 || lvalue
->symtree
->n
.sym
->attr
.result
4400 || lvalue
->symtree
->n
.sym
->attr
.function
4401 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4402 && lvalue
->symtree
->n
.sym
->ns
4403 != rvalue
->symtree
->n
.sym
->ns
)
4404 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4405 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4407 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4408 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4409 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4410 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4411 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4413 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4420 gfc_warning (OPT_Wtarget_lifetime
,
4421 "Pointer at %L in pointer assignment might outlive the "
4422 "pointer target", &lvalue
->where
);
4429 /* Relative of gfc_check_assign() except that the lvalue is a single
4430 symbol. Used for initialization assignments. */
4433 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4437 bool pointer
, proc_pointer
;
4439 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4441 lvalue
.expr_type
= EXPR_VARIABLE
;
4442 lvalue
.ts
= sym
->ts
;
4444 lvalue
.rank
= sym
->as
->rank
;
4445 lvalue
.symtree
= XCNEW (gfc_symtree
);
4446 lvalue
.symtree
->n
.sym
= sym
;
4447 lvalue
.where
= sym
->declared_at
;
4451 lvalue
.ref
= gfc_get_ref ();
4452 lvalue
.ref
->type
= REF_COMPONENT
;
4453 lvalue
.ref
->u
.c
.component
= comp
;
4454 lvalue
.ref
->u
.c
.sym
= sym
;
4455 lvalue
.ts
= comp
->ts
;
4456 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4457 lvalue
.where
= comp
->loc
;
4458 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4459 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4460 proc_pointer
= comp
->attr
.proc_pointer
;
4464 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4465 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4466 proc_pointer
= sym
->attr
.proc_pointer
;
4469 if (pointer
|| proc_pointer
)
4470 r
= gfc_check_pointer_assign (&lvalue
, rvalue
, false, true);
4473 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4474 into an array constructor, we should check if it can be reduced
4475 as an initialization expression. */
4476 if (rvalue
->expr_type
== EXPR_FUNCTION
4477 && rvalue
->value
.function
.isym
4478 && (rvalue
->value
.function
.isym
->conversion
== 1))
4479 gfc_check_init_expr (rvalue
);
4481 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4484 free (lvalue
.symtree
);
4490 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
&& !proc_pointer
)
4492 /* F08:C461. Additional checks for pointer initialization. */
4493 symbol_attribute attr
;
4494 attr
= gfc_expr_attr (rvalue
);
4495 if (attr
.allocatable
)
4497 gfc_error ("Pointer initialization target at %L "
4498 "must not be ALLOCATABLE", &rvalue
->where
);
4501 if (!attr
.target
|| attr
.pointer
)
4503 gfc_error ("Pointer initialization target at %L "
4504 "must have the TARGET attribute", &rvalue
->where
);
4508 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4509 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4510 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4512 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4513 attr
.save
= SAVE_IMPLICIT
;
4518 gfc_error ("Pointer initialization target at %L "
4519 "must have the SAVE attribute", &rvalue
->where
);
4524 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4526 /* F08:C1220. Additional checks for procedure pointer initialization. */
4527 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4528 if (attr
.proc_pointer
)
4530 gfc_error ("Procedure pointer initialization target at %L "
4531 "may not be a procedure pointer", &rvalue
->where
);
4534 if (attr
.proc
== PROC_INTERNAL
)
4536 gfc_error ("Internal procedure %qs is invalid in "
4537 "procedure pointer initialization at %L",
4538 rvalue
->symtree
->name
, &rvalue
->where
);
4543 gfc_error ("Dummy procedure %qs is invalid in "
4544 "procedure pointer initialization at %L",
4545 rvalue
->symtree
->name
, &rvalue
->where
);
4553 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4554 * require that an expression be built. */
4557 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4559 return gfc_build_init_expr (ts
, where
, false);
4562 /* Build an initializer for a local integer, real, complex, logical, or
4563 character variable, based on the command line flags finit-local-zero,
4564 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4565 With force, an initializer is ALWAYS generated. */
4568 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4570 gfc_expr
*init_expr
;
4572 /* Try to build an initializer expression. */
4573 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4575 /* If we want to force generation, make sure we default to zero. */
4576 gfc_init_local_real init_real
= flag_init_real
;
4577 int init_logical
= gfc_option
.flag_init_logical
;
4580 if (init_real
== GFC_INIT_REAL_OFF
)
4581 init_real
= GFC_INIT_REAL_ZERO
;
4582 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4583 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4586 /* We will only initialize integers, reals, complex, logicals, and
4587 characters, and only if the corresponding command-line flags
4588 were set. Otherwise, we free init_expr and return null. */
4592 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4593 mpz_set_si (init_expr
->value
.integer
,
4594 gfc_option
.flag_init_integer_value
);
4597 gfc_free_expr (init_expr
);
4605 case GFC_INIT_REAL_SNAN
:
4606 init_expr
->is_snan
= 1;
4608 case GFC_INIT_REAL_NAN
:
4609 mpfr_set_nan (init_expr
->value
.real
);
4612 case GFC_INIT_REAL_INF
:
4613 mpfr_set_inf (init_expr
->value
.real
, 1);
4616 case GFC_INIT_REAL_NEG_INF
:
4617 mpfr_set_inf (init_expr
->value
.real
, -1);
4620 case GFC_INIT_REAL_ZERO
:
4621 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4625 gfc_free_expr (init_expr
);
4634 case GFC_INIT_REAL_SNAN
:
4635 init_expr
->is_snan
= 1;
4637 case GFC_INIT_REAL_NAN
:
4638 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4639 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4642 case GFC_INIT_REAL_INF
:
4643 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4644 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4647 case GFC_INIT_REAL_NEG_INF
:
4648 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4649 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4652 case GFC_INIT_REAL_ZERO
:
4653 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4657 gfc_free_expr (init_expr
);
4664 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4665 init_expr
->value
.logical
= 0;
4666 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4667 init_expr
->value
.logical
= 1;
4670 gfc_free_expr (init_expr
);
4676 /* For characters, the length must be constant in order to
4677 create a default initializer. */
4678 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4680 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4682 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4683 init_expr
->value
.character
.length
= char_len
;
4684 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4685 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4686 init_expr
->value
.character
.string
[i
]
4687 = (unsigned char) gfc_option
.flag_init_character_value
;
4691 gfc_free_expr (init_expr
);
4695 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4696 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4698 gfc_actual_arglist
*arg
;
4699 init_expr
= gfc_get_expr ();
4700 init_expr
->where
= *where
;
4701 init_expr
->ts
= *ts
;
4702 init_expr
->expr_type
= EXPR_FUNCTION
;
4703 init_expr
->value
.function
.isym
=
4704 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4705 init_expr
->value
.function
.name
= "repeat";
4706 arg
= gfc_get_actual_arglist ();
4707 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4708 arg
->expr
->value
.character
.string
[0] =
4709 gfc_option
.flag_init_character_value
;
4710 arg
->next
= gfc_get_actual_arglist ();
4711 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4712 init_expr
->value
.function
.actual
= arg
;
4717 gfc_free_expr (init_expr
);
4724 /* Apply an initialization expression to a typespec. Can be used for symbols or
4725 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4726 combined with some effort. */
4729 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4731 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4734 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4735 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4737 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4739 if (init
->expr_type
== EXPR_CONSTANT
)
4740 gfc_set_constant_character_len (len
, init
, -1);
4742 && init
->ts
.type
== BT_CHARACTER
4743 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4744 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4745 init
->ts
.u
.cl
->length
->value
.integer
))
4747 gfc_constructor
*ctor
;
4748 ctor
= gfc_constructor_first (init
->value
.constructor
);
4752 bool has_ts
= (init
->ts
.u
.cl
4753 && init
->ts
.u
.cl
->length_from_typespec
);
4755 /* Remember the length of the first element for checking
4756 that all elements *in the constructor* have the same
4757 length. This need not be the length of the LHS! */
4758 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4759 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4760 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4762 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4763 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4765 gfc_set_constant_character_len (len
, ctor
->expr
,
4766 has_ts
? -1 : first_len
);
4767 if (!ctor
->expr
->ts
.u
.cl
)
4769 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4771 ctor
->expr
->ts
.u
.cl
->length
4772 = gfc_copy_expr (ts
->u
.cl
->length
);
4780 /* Check whether an expression is a structure constructor and whether it has
4781 other values than NULL. */
4784 is_non_empty_structure_constructor (gfc_expr
* e
)
4786 if (e
->expr_type
!= EXPR_STRUCTURE
)
4789 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4792 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4794 cons
= gfc_constructor_next (cons
);
4800 /* Check for default initializer; sym->value is not enough
4801 as it is also set for EXPR_NULL of allocatables. */
4804 gfc_has_default_initializer (gfc_symbol
*der
)
4808 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4809 for (c
= der
->components
; c
; c
= c
->next
)
4810 if (gfc_bt_struct (c
->ts
.type
))
4812 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4813 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4815 && is_non_empty_structure_constructor (c
->initializer
))
4816 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4818 if (c
->attr
.pointer
&& c
->initializer
)
4832 Generate an initializer expression which initializes the entirety of a union.
4833 A normal structure constructor is insufficient without undue effort, because
4834 components of maps may be oddly aligned/overlapped. (For example if a
4835 character is initialized from one map overtop a real from the other, only one
4836 byte of the real is actually initialized.) Unfortunately we don't know the
4837 size of the union right now, so we can't generate a proper initializer, but
4838 we use a NULL expr as a placeholder and do the right thing later in
4839 gfc_trans_subcomponent_assign.
4842 generate_union_initializer (gfc_component
*un
)
4844 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4847 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4848 placeholder
->ts
= un
->ts
;
4853 /* Get the user-specified initializer for a union, if any. This means the user
4854 has said to initialize component(s) of a map. For simplicity's sake we
4855 only allow the user to initialize the first map. We don't have to worry
4856 about overlapping initializers as they are released early in resolution (see
4857 resolve_fl_struct). */
4860 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4863 gfc_expr
*init
=NULL
;
4865 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4868 for (map
= union_type
->components
; map
; map
= map
->next
)
4870 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4872 init
= gfc_default_initializer (&map
->ts
);
4886 class_allocatable (gfc_component
*comp
)
4888 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4889 && CLASS_DATA (comp
)->attr
.allocatable
;
4893 class_pointer (gfc_component
*comp
)
4895 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4896 && CLASS_DATA (comp
)->attr
.pointer
;
4900 comp_allocatable (gfc_component
*comp
)
4902 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4906 comp_pointer (gfc_component
*comp
)
4908 return comp
->attr
.pointer
4909 || comp
->attr
.proc_pointer
4910 || comp
->attr
.class_pointer
4911 || class_pointer (comp
);
4914 /* Fetch or generate an initializer for the given component.
4915 Only generate an initializer if generate is true. */
4918 component_initializer (gfc_component
*c
, bool generate
)
4920 gfc_expr
*init
= NULL
;
4922 /* Allocatable components always get EXPR_NULL.
4923 Pointer components are only initialized when generating, and only if they
4924 do not already have an initializer. */
4925 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4927 init
= gfc_get_null_expr (&c
->loc
);
4932 /* See if we can find the initializer immediately. */
4933 if (c
->initializer
|| !generate
)
4934 return c
->initializer
;
4936 /* Recursively handle derived type components. */
4937 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4938 init
= gfc_generate_initializer (&c
->ts
, true);
4940 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4942 gfc_component
*map
= NULL
;
4943 gfc_constructor
*ctor
;
4944 gfc_expr
*user_init
;
4946 /* If we don't have a user initializer and we aren't generating one, this
4947 union has no initializer. */
4948 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4949 if (!user_init
&& !generate
)
4952 /* Otherwise use a structure constructor. */
4953 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4957 /* If we are to generate an initializer for the union, add a constructor
4958 which initializes the whole union first. */
4961 ctor
= gfc_constructor_get ();
4962 ctor
->expr
= generate_union_initializer (c
);
4963 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4966 /* If we found an initializer in one of our maps, apply it. Note this
4967 is applied _after_ the entire-union initializer above if any. */
4970 ctor
= gfc_constructor_get ();
4971 ctor
->expr
= user_init
;
4972 ctor
->n
.component
= map
;
4973 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4977 /* Treat simple components like locals. */
4980 /* We MUST give an initializer, so force generation. */
4981 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4982 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4989 /* Get an expression for a default initializer of a derived type. */
4992 gfc_default_initializer (gfc_typespec
*ts
)
4994 return gfc_generate_initializer (ts
, false);
4997 /* Generate an initializer expression for an iso_c_binding type
4998 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
5001 generate_isocbinding_initializer (gfc_symbol
*derived
)
5003 /* The initializers have already been built into the c_null_[fun]ptr symbols
5004 from gen_special_c_interop_ptr. */
5005 gfc_symtree
*npsym
= NULL
;
5006 if (0 == strcmp (derived
->name
, "c_ptr"))
5007 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
5008 else if (0 == strcmp (derived
->name
, "c_funptr"))
5009 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
5011 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
5012 " type, expected %<c_ptr%> or %<c_funptr%>");
5015 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
5016 init
->symtree
= npsym
;
5017 init
->ts
.is_iso_c
= true;
5024 /* Get or generate an expression for a default initializer of a derived type.
5025 If -finit-derived is specified, generate default initialization expressions
5026 for components that lack them when generate is set. */
5029 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
5031 gfc_expr
*init
, *tmp
;
5032 gfc_component
*comp
;
5034 generate
= flag_init_derived
&& generate
;
5036 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
5037 return generate_isocbinding_initializer (ts
->u
.derived
);
5039 /* See if we have a default initializer in this, but not in nested
5040 types (otherwise we could use gfc_has_default_initializer()).
5041 We don't need to check if we are going to generate them. */
5042 comp
= ts
->u
.derived
->components
;
5045 for (; comp
; comp
= comp
->next
)
5046 if (comp
->initializer
|| comp_allocatable (comp
))
5053 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
5054 &ts
->u
.derived
->declared_at
);
5057 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
5059 gfc_constructor
*ctor
= gfc_constructor_get();
5061 /* Fetch or generate an initializer for the component. */
5062 tmp
= component_initializer (comp
, generate
);
5065 /* Save the component ref for STRUCTUREs and UNIONs. */
5066 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
5067 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
5068 ctor
->n
.component
= comp
;
5070 /* If the initializer was not generated, we need a copy. */
5071 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
5072 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
5073 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
5076 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
5082 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5089 /* Given a symbol, create an expression node with that symbol as a
5090 variable. If the symbol is array valued, setup a reference of the
5094 gfc_get_variable_expr (gfc_symtree
*var
)
5098 e
= gfc_get_expr ();
5099 e
->expr_type
= EXPR_VARIABLE
;
5101 e
->ts
= var
->n
.sym
->ts
;
5103 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
5104 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
5105 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
5106 && CLASS_DATA (var
->n
.sym
)->as
)))
5108 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
5109 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
5110 e
->ref
= gfc_get_ref ();
5111 e
->ref
->type
= REF_ARRAY
;
5112 e
->ref
->u
.ar
.type
= AR_FULL
;
5113 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
5114 ? CLASS_DATA (var
->n
.sym
)->as
5122 /* Adds a full array reference to an expression, as needed. */
5125 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
5128 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5133 ref
->next
= gfc_get_ref ();
5138 e
->ref
= gfc_get_ref ();
5141 ref
->type
= REF_ARRAY
;
5142 ref
->u
.ar
.type
= AR_FULL
;
5143 ref
->u
.ar
.dimen
= e
->rank
;
5144 ref
->u
.ar
.where
= e
->where
;
5150 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
5154 lval
= gfc_get_expr ();
5155 lval
->expr_type
= EXPR_VARIABLE
;
5156 lval
->where
= sym
->declared_at
;
5158 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5160 /* It will always be a full array. */
5161 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5162 lval
->rank
= as
? as
->rank
: 0;
5164 gfc_add_full_array_ref (lval
, as
);
5169 /* Returns the array_spec of a full array expression. A NULL is
5170 returned otherwise. */
5172 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
5177 if (expr
->rank
== 0)
5180 /* Follow any component references. */
5181 if (expr
->expr_type
== EXPR_VARIABLE
5182 || expr
->expr_type
== EXPR_CONSTANT
)
5185 as
= expr
->symtree
->n
.sym
->as
;
5189 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5194 as
= ref
->u
.c
.component
->as
;
5203 switch (ref
->u
.ar
.type
)
5226 /* General expression traversal function. */
5229 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5230 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5235 gfc_actual_arglist
*args
;
5242 if ((*func
) (expr
, sym
, &f
))
5245 if (expr
->ts
.type
== BT_CHARACTER
5247 && expr
->ts
.u
.cl
->length
5248 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5249 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5252 switch (expr
->expr_type
)
5257 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5259 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5267 case EXPR_SUBSTRING
:
5270 case EXPR_STRUCTURE
:
5272 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5273 c
; c
= gfc_constructor_next (c
))
5275 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5279 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5281 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5283 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5285 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5292 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5294 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5310 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5312 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5314 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5316 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5322 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5324 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5329 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5330 && ref
->u
.c
.component
->ts
.u
.cl
5331 && ref
->u
.c
.component
->ts
.u
.cl
->length
5332 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5334 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5338 if (ref
->u
.c
.component
->as
)
5339 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5340 + ref
->u
.c
.component
->as
->corank
; i
++)
5342 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5345 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5362 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5365 expr_set_symbols_referenced (gfc_expr
*expr
,
5366 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5367 int *f ATTRIBUTE_UNUSED
)
5369 if (expr
->expr_type
!= EXPR_VARIABLE
)
5371 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5376 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5378 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5382 /* Determine if an expression is a procedure pointer component and return
5383 the component in that case. Otherwise return NULL. */
5386 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5390 if (!expr
|| !expr
->ref
)
5397 if (ref
->type
== REF_COMPONENT
5398 && ref
->u
.c
.component
->attr
.proc_pointer
)
5399 return ref
->u
.c
.component
;
5405 /* Determine if an expression is a procedure pointer component. */
5408 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5410 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5414 /* Determine if an expression is a function with an allocatable class scalar
5417 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5419 if (expr
->expr_type
== EXPR_FUNCTION
5420 && expr
->value
.function
.esym
5421 && expr
->value
.function
.esym
->result
5422 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5423 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5424 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5431 /* Determine if an expression is a function with an allocatable class array
5434 gfc_is_class_array_function (gfc_expr
*expr
)
5436 if (expr
->expr_type
== EXPR_FUNCTION
5437 && expr
->value
.function
.esym
5438 && expr
->value
.function
.esym
->result
5439 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5440 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5441 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5442 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5449 /* Walk an expression tree and check each variable encountered for being typed.
5450 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5451 mode as is a basic arithmetic expression using those; this is for things in
5454 INTEGER :: arr(n), n
5455 INTEGER :: arr(n + 1), n
5457 The namespace is needed for IMPLICIT typing. */
5459 static gfc_namespace
* check_typed_ns
;
5462 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5463 int* f ATTRIBUTE_UNUSED
)
5467 if (e
->expr_type
!= EXPR_VARIABLE
)
5470 gcc_assert (e
->symtree
);
5471 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5478 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5482 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5486 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5487 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5489 if (e
->expr_type
== EXPR_OP
)
5493 gcc_assert (e
->value
.op
.op1
);
5494 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5496 if (t
&& e
->value
.op
.op2
)
5497 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5503 /* Otherwise, walk the expression and do it strictly. */
5504 check_typed_ns
= ns
;
5505 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5507 return error_found
? false : true;
5511 /* This function returns true if it contains any references to PDT KIND
5512 or LEN parameters. */
5515 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5516 int* f ATTRIBUTE_UNUSED
)
5518 if (e
->expr_type
!= EXPR_VARIABLE
)
5521 gcc_assert (e
->symtree
);
5522 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5523 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5531 gfc_derived_parameter_expr (gfc_expr
*e
)
5533 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5537 /* This function returns the overall type of a type parameter spec list.
5538 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5539 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5540 unless derived is not NULL. In this latter case, all the LEN parameters
5541 must be either assumed or deferred for the return argument to be set to
5542 anything other than SPEC_EXPLICIT. */
5545 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5547 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5549 bool seen_assumed
= false;
5550 bool seen_deferred
= false;
5552 if (derived
== NULL
)
5554 for (; param_list
; param_list
= param_list
->next
)
5555 if (param_list
->spec_type
== SPEC_ASSUMED
5556 || param_list
->spec_type
== SPEC_DEFERRED
)
5557 return param_list
->spec_type
;
5561 for (; param_list
; param_list
= param_list
->next
)
5563 c
= gfc_find_component (derived
, param_list
->name
,
5565 gcc_assert (c
!= NULL
);
5566 if (c
->attr
.pdt_kind
)
5568 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5569 return SPEC_EXPLICIT
;
5570 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5571 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5572 if (seen_assumed
&& seen_deferred
)
5573 return SPEC_EXPLICIT
;
5575 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5582 gfc_ref_this_image (gfc_ref
*ref
)
5586 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5588 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5589 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5596 gfc_find_team_co (gfc_expr
*e
)
5600 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5601 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5602 return ref
->u
.ar
.team
;
5604 if (e
->value
.function
.actual
->expr
)
5605 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5607 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5608 return ref
->u
.ar
.team
;
5614 gfc_find_stat_co (gfc_expr
*e
)
5618 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5619 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5620 return ref
->u
.ar
.stat
;
5622 if (e
->value
.function
.actual
->expr
)
5623 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5625 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5626 return ref
->u
.ar
.stat
;
5632 gfc_is_coindexed (gfc_expr
*e
)
5636 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5637 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5638 return !gfc_ref_this_image (ref
);
5644 /* Coarrays are variables with a corank but not being coindexed. However, also
5645 the following is a coarray: A subobject of a coarray is a coarray if it does
5646 not have any cosubscripts, vector subscripts, allocatable component
5647 selection, or pointer component selection. (F2008, 2.4.7) */
5650 gfc_is_coarray (gfc_expr
*e
)
5654 gfc_component
*comp
;
5659 if (e
->expr_type
!= EXPR_VARIABLE
)
5663 sym
= e
->symtree
->n
.sym
;
5665 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5666 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5668 coarray
= sym
->attr
.codimension
;
5670 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5674 comp
= ref
->u
.c
.component
;
5675 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5676 && (CLASS_DATA (comp
)->attr
.class_pointer
5677 || CLASS_DATA (comp
)->attr
.allocatable
))
5680 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5682 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5685 coarray
= comp
->attr
.codimension
;
5693 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5699 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5700 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5712 return coarray
&& !coindexed
;
5717 gfc_get_corank (gfc_expr
*e
)
5722 if (!gfc_is_coarray (e
))
5725 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5726 corank
= e
->ts
.u
.derived
->components
->as
5727 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5729 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5731 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5733 if (ref
->type
== REF_ARRAY
)
5734 corank
= ref
->u
.ar
.as
->corank
;
5735 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5742 /* Check whether the expression has an ultimate allocatable component.
5743 Being itself allocatable does not count. */
5745 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5747 gfc_ref
*ref
, *last
= NULL
;
5749 if (e
->expr_type
!= EXPR_VARIABLE
)
5752 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5753 if (ref
->type
== REF_COMPONENT
)
5756 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5757 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5758 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5759 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5763 if (e
->ts
.type
== BT_CLASS
)
5764 return CLASS_DATA (e
)->attr
.alloc_comp
;
5765 else if (e
->ts
.type
== BT_DERIVED
)
5766 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5772 /* Check whether the expression has an pointer component.
5773 Being itself a pointer does not count. */
5775 gfc_has_ultimate_pointer (gfc_expr
*e
)
5777 gfc_ref
*ref
, *last
= NULL
;
5779 if (e
->expr_type
!= EXPR_VARIABLE
)
5782 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5783 if (ref
->type
== REF_COMPONENT
)
5786 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5787 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5788 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5789 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5793 if (e
->ts
.type
== BT_CLASS
)
5794 return CLASS_DATA (e
)->attr
.pointer_comp
;
5795 else if (e
->ts
.type
== BT_DERIVED
)
5796 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5802 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5803 Note: A scalar is not regarded as "simply contiguous" by the standard.
5804 if bool is not strict, some further checks are done - for instance,
5805 a "(::1)" is accepted. */
5808 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5812 gfc_array_ref
*ar
= NULL
;
5813 gfc_ref
*ref
, *part_ref
= NULL
;
5816 if (expr
->expr_type
== EXPR_ARRAY
)
5819 if (expr
->expr_type
== EXPR_FUNCTION
)
5821 if (expr
->value
.function
.esym
)
5822 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5825 /* Type-bound procedures. */
5826 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5827 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5831 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5832 if (r
->type
== REF_COMPONENT
)
5835 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5836 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5839 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5842 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5845 if (!permit_element
&& expr
->rank
== 0)
5848 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5851 return false; /* Array shall be last part-ref. */
5853 if (ref
->type
== REF_COMPONENT
)
5855 else if (ref
->type
== REF_SUBSTRING
)
5857 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5861 sym
= expr
->symtree
->n
.sym
;
5862 if (expr
->ts
.type
!= BT_CLASS
5864 && !part_ref
->u
.c
.component
->attr
.contiguous
5865 && part_ref
->u
.c
.component
->attr
.pointer
)
5867 && !sym
->attr
.contiguous
5868 && (sym
->attr
.pointer
5869 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5870 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5873 if (!ar
|| ar
->type
== AR_FULL
)
5876 gcc_assert (ar
->type
== AR_SECTION
);
5878 /* Check for simply contiguous array */
5880 for (i
= 0; i
< ar
->dimen
; i
++)
5882 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5885 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5891 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5894 /* If the previous section was not contiguous, that's an error,
5895 unless we have effective only one element and checking is not
5897 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5898 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5899 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5900 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5901 ar
->end
[i
]->value
.integer
) != 0))
5904 /* Following the standard, "(::1)" or - if known at compile time -
5905 "(lbound:ubound)" are not simply contiguous; if strict
5906 is false, they are regarded as simply contiguous. */
5907 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5908 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5909 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5913 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5914 || !ar
->as
->lower
[i
]
5915 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5916 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5917 ar
->as
->lower
[i
]->value
.integer
) != 0))
5921 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5922 || !ar
->as
->upper
[i
]
5923 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5924 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5925 ar
->as
->upper
[i
]->value
.integer
) != 0))
5932 /* Return true if the expression is guaranteed to be non-contiguous,
5933 false if we cannot prove anything. It is probably best to call
5934 this after gfc_is_simply_contiguous. If neither of them returns
5935 true, we cannot say (at compile-time). */
5938 gfc_is_not_contiguous (gfc_expr
*array
)
5941 gfc_array_ref
*ar
= NULL
;
5943 bool previous_incomplete
;
5945 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
5947 /* Array-ref shall be last ref. */
5949 if (ar
&& ar
->type
!= AR_ELEMENT
)
5952 if (ref
->type
== REF_ARRAY
)
5956 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
5959 previous_incomplete
= false;
5961 /* Check if we can prove that the array is not contiguous. */
5963 for (i
= 0; i
< ar
->dimen
; i
++)
5965 mpz_t arr_size
, ref_size
;
5967 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
5969 if (gfc_dep_difference (ar
->as
->upper
[i
], ar
->as
->lower
[i
], &arr_size
))
5971 /* a(2:4,2:) is known to be non-contiguous, but
5972 a(2:4,i:i) can be contiguous. */
5973 mpz_add_ui (arr_size
, arr_size
, 1L);
5974 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
5976 mpz_clear (arr_size
);
5977 mpz_clear (ref_size
);
5980 else if (mpz_cmp (arr_size
, ref_size
) != 0)
5981 previous_incomplete
= true;
5983 mpz_clear (arr_size
);
5986 /* Check for a(::2), i.e. where the stride is not unity.
5987 This is only done if there is more than one element in
5988 the reference along this dimension. */
5990 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
5991 && ar
->dimen_type
[i
] == DIMEN_RANGE
5992 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5993 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
5995 mpz_clear (ref_size
);
5999 mpz_clear (ref_size
);
6002 /* We didn't find anything definitive. */
6006 /* Build call to an intrinsic procedure. The number of arguments has to be
6007 passed (rather than ending the list with a NULL value) because we may
6008 want to add arguments but with a NULL-expression. */
6011 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
6012 locus where
, unsigned numarg
, ...)
6015 gfc_actual_arglist
* atail
;
6016 gfc_intrinsic_sym
* isym
;
6019 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
6021 isym
= gfc_intrinsic_function_by_id (id
);
6024 result
= gfc_get_expr ();
6025 result
->expr_type
= EXPR_FUNCTION
;
6026 result
->ts
= isym
->ts
;
6027 result
->where
= where
;
6028 result
->value
.function
.name
= mangled_name
;
6029 result
->value
.function
.isym
= isym
;
6031 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
6032 gfc_commit_symbol (result
->symtree
->n
.sym
);
6033 gcc_assert (result
->symtree
6034 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
6035 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
6036 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
6037 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6038 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
6039 result
->symtree
->n
.sym
->attr
.artificial
= 1;
6041 va_start (ap
, numarg
);
6043 for (i
= 0; i
< numarg
; ++i
)
6047 atail
->next
= gfc_get_actual_arglist ();
6048 atail
= atail
->next
;
6051 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
6053 atail
->expr
= va_arg (ap
, gfc_expr
*);
6061 /* Check if an expression may appear in a variable definition context
6062 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
6063 This is called from the various places when resolving
6064 the pieces that make up such a context.
6065 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
6066 variables), some checks are not performed.
6068 Optionally, a possible error message can be suppressed if context is NULL
6069 and just the return status (true / false) be requested. */
6072 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
6073 bool own_scope
, const char* context
)
6075 gfc_symbol
* sym
= NULL
;
6077 bool check_intentin
;
6079 symbol_attribute attr
;
6083 if (e
->expr_type
== EXPR_VARIABLE
)
6085 gcc_assert (e
->symtree
);
6086 sym
= e
->symtree
->n
.sym
;
6088 else if (e
->expr_type
== EXPR_FUNCTION
)
6090 gcc_assert (e
->symtree
);
6091 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
6094 attr
= gfc_expr_attr (e
);
6095 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
6097 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
6100 gfc_error ("Fortran 2008: Pointer functions in variable definition"
6101 " context (%s) at %L", context
, &e
->where
);
6105 else if (e
->expr_type
!= EXPR_VARIABLE
)
6108 gfc_error ("Non-variable expression in variable definition context (%s)"
6109 " at %L", context
, &e
->where
);
6113 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
6116 gfc_error ("Named constant %qs in variable definition context (%s)"
6117 " at %L", sym
->name
, context
, &e
->where
);
6120 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
6121 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
6122 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
6125 gfc_error ("%qs in variable definition context (%s) at %L is not"
6126 " a variable", sym
->name
, context
, &e
->where
);
6130 /* Find out whether the expr is a pointer; this also means following
6131 component references to the last one. */
6132 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
6133 if (pointer
&& !is_pointer
)
6136 gfc_error ("Non-POINTER in pointer association context (%s)"
6137 " at %L", context
, &e
->where
);
6141 if (e
->ts
.type
== BT_DERIVED
6142 && e
->ts
.u
.derived
== NULL
)
6145 gfc_error ("Type inaccessible in variable definition context (%s) "
6146 "at %L", context
, &e
->where
);
6153 || (e
->ts
.type
== BT_DERIVED
6154 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6155 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
6158 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6159 context
, &e
->where
);
6163 /* TS18508, C702/C203. */
6166 || (e
->ts
.type
== BT_DERIVED
6167 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6168 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
6171 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6172 context
, &e
->where
);
6176 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6177 component of sub-component of a pointer; we need to distinguish
6178 assignment to a pointer component from pointer-assignment to a pointer
6179 component. Note that (normal) assignment to procedure pointers is not
6181 check_intentin
= !own_scope
;
6182 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
6183 && CLASS_DATA (sym
))
6184 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
6185 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
6187 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
6188 check_intentin
= false;
6189 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
6191 ptr_component
= true;
6193 check_intentin
= false;
6198 && (sym
->attr
.intent
== INTENT_IN
6199 || (sym
->attr
.select_type_temporary
&& sym
->assoc
6200 && sym
->assoc
->target
&& sym
->assoc
->target
->symtree
6201 && sym
->assoc
->target
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)))
6203 if (pointer
&& is_pointer
)
6206 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6207 " association context (%s) at %L",
6208 sym
->name
, context
, &e
->where
);
6211 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
6213 const char *name
= sym
->attr
.select_type_temporary
6214 ? sym
->assoc
->target
->symtree
->name
: sym
->name
;
6216 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6217 " definition context (%s) at %L",
6218 name
, context
, &e
->where
);
6223 /* PROTECTED and use-associated. */
6224 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
6226 if (pointer
&& is_pointer
)
6229 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6230 " pointer association context (%s) at %L",
6231 sym
->name
, context
, &e
->where
);
6234 if (!pointer
&& !is_pointer
)
6237 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6238 " variable definition context (%s) at %L",
6239 sym
->name
, context
, &e
->where
);
6244 /* Variable not assignable from a PURE procedure but appears in
6245 variable definition context. */
6246 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6249 gfc_error ("Variable %qs cannot appear in a variable definition"
6250 " context (%s) at %L in PURE procedure",
6251 sym
->name
, context
, &e
->where
);
6255 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6256 && gfc_impure_variable (sym
))
6261 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6263 sym
= ns
->proc_name
;
6266 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6268 sym
->attr
.implicit_pure
= 0;
6273 /* Check variable definition context for associate-names. */
6274 if (!pointer
&& sym
->assoc
&& !sym
->attr
.select_rank_temporary
)
6277 gfc_association_list
* assoc
;
6279 gcc_assert (sym
->assoc
->target
);
6281 /* If this is a SELECT TYPE temporary (the association is used internally
6282 for SELECT TYPE), silently go over to the target. */
6283 if (sym
->attr
.select_type_temporary
)
6285 gfc_expr
* t
= sym
->assoc
->target
;
6287 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6288 name
= t
->symtree
->name
;
6290 if (t
->symtree
->n
.sym
->assoc
)
6291 assoc
= t
->symtree
->n
.sym
->assoc
;
6300 gcc_assert (name
&& assoc
);
6302 /* Is association to a valid variable? */
6303 if (!assoc
->variable
)
6307 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6308 gfc_error ("%qs at %L associated to vector-indexed target"
6309 " cannot be used in a variable definition"
6311 name
, &e
->where
, context
);
6313 gfc_error ("%qs at %L associated to expression"
6314 " cannot be used in a variable definition"
6316 name
, &e
->where
, context
);
6321 /* Target must be allowed to appear in a variable definition context. */
6322 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6325 gfc_error ("Associate-name %qs cannot appear in a variable"
6326 " definition context (%s) at %L because its target"
6327 " at %L cannot, either",
6328 name
, context
, &e
->where
,
6329 &assoc
->target
->where
);
6334 /* Check for same value in vector expression subscript. */
6337 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6338 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6339 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6340 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6341 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6343 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6344 if (arr
->expr_type
== EXPR_ARRAY
)
6346 gfc_constructor
*c
, *n
;
6349 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6350 c
!= NULL
; c
= gfc_constructor_next (c
))
6352 if (c
== NULL
|| c
->iterator
!= NULL
)
6357 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6358 n
= gfc_constructor_next (n
))
6360 if (n
->iterator
!= NULL
)
6364 if (gfc_dep_compare_expr (ec
, en
) == 0)
6367 gfc_error_now ("Elements with the same value "
6368 "at %L and %L in vector "
6369 "subscript in a variable "
6370 "definition context (%s)",
6371 &(ec
->where
), &(en
->where
),