1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2023 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.cc (gfc_get_variable_expr)
39 symbol.cc (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 && p
->ts
.kind
== gfc_default_character_kind
)
317 q
->value
.character
.string
318 = gfc_char_to_widechar (q
->representation
.string
);
321 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
322 q
->value
.character
.string
= s
;
324 /* This is the case for the C_NULL_CHAR named constant. */
325 if (p
->value
.character
.length
== 0
326 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
329 /* Need to set the length to 1 to make sure the NUL
330 terminator is copied. */
331 q
->value
.character
.length
= 1;
334 memcpy (s
, p
->value
.character
.string
,
335 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
344 break; /* Already done. */
347 q
->boz
.len
= p
->boz
.len
;
348 q
->boz
.rdx
= p
->boz
.rdx
;
349 q
->boz
.str
= XCNEWVEC (char, q
->boz
.len
+ 1);
350 strncpy (q
->boz
.str
, p
->boz
.str
, p
->boz
.len
);
355 /* Should never be reached. */
357 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
364 switch (q
->value
.op
.op
)
367 case INTRINSIC_PARENTHESES
:
368 case INTRINSIC_UPLUS
:
369 case INTRINSIC_UMINUS
:
370 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
373 default: /* Binary operators. */
374 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
375 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
382 q
->value
.function
.actual
=
383 gfc_copy_actual_arglist (p
->value
.function
.actual
);
388 q
->value
.compcall
.actual
=
389 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
390 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
395 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
406 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
408 q
->ref
= gfc_copy_ref (p
->ref
);
411 q
->param_list
= gfc_copy_actual_arglist (p
->param_list
);
418 gfc_clear_shape (mpz_t
*shape
, int rank
)
422 for (i
= 0; i
< rank
; i
++)
423 mpz_clear (shape
[i
]);
428 gfc_free_shape (mpz_t
**shape
, int rank
)
433 gfc_clear_shape (*shape
, rank
);
439 /* Workhorse function for gfc_free_expr() that frees everything
440 beneath an expression node, but not the node itself. This is
441 useful when we want to simplify a node and replace it with
442 something else or the expression node belongs to another structure. */
445 free_expr0 (gfc_expr
*e
)
447 switch (e
->expr_type
)
450 /* Free any parts of the value that need freeing. */
454 mpz_clear (e
->value
.integer
);
458 mpfr_clear (e
->value
.real
);
462 free (e
->value
.character
.string
);
466 mpc_clear (e
->value
.complex);
477 /* Free the representation. */
478 free (e
->representation
.string
);
483 if (e
->value
.op
.op1
!= NULL
)
484 gfc_free_expr (e
->value
.op
.op1
);
485 if (e
->value
.op
.op2
!= NULL
)
486 gfc_free_expr (e
->value
.op
.op2
);
490 gfc_free_actual_arglist (e
->value
.function
.actual
);
495 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
503 gfc_constructor_free (e
->value
.constructor
);
507 free (e
->value
.character
.string
);
514 gfc_internal_error ("free_expr0(): Bad expr type");
517 /* Free a shape array. */
518 gfc_free_shape (&e
->shape
, e
->rank
);
520 gfc_free_ref_list (e
->ref
);
522 gfc_free_actual_arglist (e
->param_list
);
524 memset (e
, '\0', sizeof (gfc_expr
));
528 /* Free an expression node and everything beneath it. */
531 gfc_free_expr (gfc_expr
*e
)
540 /* Free an argument list and everything below it. */
543 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
545 gfc_actual_arglist
*a2
;
551 gfc_free_expr (a1
->expr
);
552 free (a1
->associated_dummy
);
559 /* Copy an arglist structure and all of the arguments. */
562 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
564 gfc_actual_arglist
*head
, *tail
, *new_arg
;
568 for (; p
; p
= p
->next
)
570 new_arg
= gfc_get_actual_arglist ();
573 if (p
->associated_dummy
!= NULL
)
575 new_arg
->associated_dummy
= gfc_get_dummy_arg ();
576 *new_arg
->associated_dummy
= *p
->associated_dummy
;
579 new_arg
->expr
= gfc_copy_expr (p
->expr
);
580 new_arg
->next
= NULL
;
585 tail
->next
= new_arg
;
594 /* Free a list of reference structures. */
597 gfc_free_ref_list (gfc_ref
*p
)
609 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
611 gfc_free_expr (p
->u
.ar
.start
[i
]);
612 gfc_free_expr (p
->u
.ar
.end
[i
]);
613 gfc_free_expr (p
->u
.ar
.stride
[i
]);
619 gfc_free_expr (p
->u
.ss
.start
);
620 gfc_free_expr (p
->u
.ss
.end
);
633 /* Graft the *src expression onto the *dest subexpression. */
636 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
644 /* Try to extract an integer constant from the passed expression node.
645 Return true if some error occurred, false on success. If REPORT_ERROR
646 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
647 for negative using gfc_error_now. */
650 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
654 /* A KIND component is a parameter too. The expression for it
655 is stored in the initializer and should be consistent with
657 if (gfc_expr_attr(expr
).pdt_kind
)
659 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
661 if (ref
->u
.c
.component
->attr
.pdt_kind
)
662 expr
= ref
->u
.c
.component
->initializer
;
666 if (expr
->expr_type
!= EXPR_CONSTANT
)
668 if (report_error
> 0)
669 gfc_error ("Constant expression required at %C");
670 else if (report_error
< 0)
671 gfc_error_now ("Constant expression required at %C");
675 if (expr
->ts
.type
!= BT_INTEGER
)
677 if (report_error
> 0)
678 gfc_error ("Integer expression required at %C");
679 else if (report_error
< 0)
680 gfc_error_now ("Integer expression required at %C");
684 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
685 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
687 if (report_error
> 0)
688 gfc_error ("Integer value too large in expression at %C");
689 else if (report_error
< 0)
690 gfc_error_now ("Integer value too large in expression at %C");
694 *result
= (int) mpz_get_si (expr
->value
.integer
);
700 /* Same as gfc_extract_int, but use a HWI. */
703 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
, int report_error
)
707 /* A KIND component is a parameter too. The expression for it is
708 stored in the initializer and should be consistent with the tests
710 if (gfc_expr_attr(expr
).pdt_kind
)
712 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
714 if (ref
->u
.c
.component
->attr
.pdt_kind
)
715 expr
= ref
->u
.c
.component
->initializer
;
719 if (expr
->expr_type
!= EXPR_CONSTANT
)
721 if (report_error
> 0)
722 gfc_error ("Constant expression required at %C");
723 else if (report_error
< 0)
724 gfc_error_now ("Constant expression required at %C");
728 if (expr
->ts
.type
!= BT_INTEGER
)
730 if (report_error
> 0)
731 gfc_error ("Integer expression required at %C");
732 else if (report_error
< 0)
733 gfc_error_now ("Integer expression required at %C");
737 /* Use long_long_integer_type_node to determine when to saturate. */
738 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
739 expr
->value
.integer
, false);
741 if (!wi::fits_shwi_p (val
))
743 if (report_error
> 0)
744 gfc_error ("Integer value too large in expression at %C");
745 else if (report_error
< 0)
746 gfc_error_now ("Integer value too large in expression at %C");
750 *result
= val
.to_shwi ();
756 /* Recursively copy a list of reference structures. */
759 gfc_copy_ref (gfc_ref
*src
)
767 dest
= gfc_get_ref ();
768 dest
->type
= src
->type
;
773 ar
= gfc_copy_array_ref (&src
->u
.ar
);
779 dest
->u
.c
= src
->u
.c
;
783 dest
->u
.i
= src
->u
.i
;
787 dest
->u
.ss
= src
->u
.ss
;
788 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
789 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
793 dest
->next
= gfc_copy_ref (src
->next
);
799 /* Detect whether an expression has any vector index array references. */
802 gfc_has_vector_index (gfc_expr
*e
)
806 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
807 if (ref
->type
== REF_ARRAY
)
808 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
809 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
816 gfc_is_ptr_fcn (gfc_expr
*e
)
818 return e
!= NULL
&& e
->expr_type
== EXPR_FUNCTION
819 && gfc_expr_attr (e
).pointer
;
823 /* Copy a shape array. */
826 gfc_copy_shape (mpz_t
*shape
, int rank
)
834 new_shape
= gfc_get_shape (rank
);
836 for (n
= 0; n
< rank
; n
++)
837 mpz_init_set (new_shape
[n
], shape
[n
]);
843 /* Copy a shape array excluding dimension N, where N is an integer
844 constant expression. Dimensions are numbered in Fortran style --
847 So, if the original shape array contains R elements
848 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
849 the result contains R-1 elements:
850 { s1 ... sN-1 sN+1 ... sR-1}
852 If anything goes wrong -- N is not a constant, its value is out
853 of range -- or anything else, just returns NULL. */
856 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
858 mpz_t
*new_shape
, *s
;
864 || dim
->expr_type
!= EXPR_CONSTANT
865 || dim
->ts
.type
!= BT_INTEGER
)
868 n
= mpz_get_si (dim
->value
.integer
);
869 n
--; /* Convert to zero based index. */
870 if (n
< 0 || n
>= rank
)
873 s
= new_shape
= gfc_get_shape (rank
- 1);
875 for (i
= 0; i
< rank
; i
++)
879 mpz_init_set (*s
, shape
[i
]);
887 /* Return the maximum kind of two expressions. In general, higher
888 kind numbers mean more precision for numeric types. */
891 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
893 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
897 /* Returns nonzero if the type is numeric, zero otherwise. */
900 numeric_type (bt type
)
902 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
906 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
909 gfc_numeric_ts (gfc_typespec
*ts
)
911 return numeric_type (ts
->type
);
915 /* Return an expression node with an optional argument list attached.
916 A variable number of gfc_expr pointers are strung together in an
917 argument list with a NULL pointer terminating the list. */
920 gfc_build_conversion (gfc_expr
*e
)
925 p
->expr_type
= EXPR_FUNCTION
;
927 p
->value
.function
.actual
= gfc_get_actual_arglist ();
928 p
->value
.function
.actual
->expr
= e
;
934 /* Given an expression node with some sort of numeric binary
935 expression, insert type conversions required to make the operands
936 have the same type. Conversion warnings are disabled if wconversion
939 The exception is that the operands of an exponential don't have to
940 have the same type. If possible, the base is promoted to the type
941 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
942 1.0**2 stays as it is. */
945 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
949 op1
= e
->value
.op
.op1
;
950 op2
= e
->value
.op
.op2
;
952 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
954 gfc_clear_ts (&e
->ts
);
958 /* Kind conversions of same type. */
959 if (op1
->ts
.type
== op2
->ts
.type
)
961 if (op1
->ts
.kind
== op2
->ts
.kind
)
963 /* No type conversions. */
968 if (op1
->ts
.kind
> op2
->ts
.kind
)
969 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
971 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
977 /* Integer combined with real or complex. */
978 if (op2
->ts
.type
== BT_INTEGER
)
982 /* Special case for ** operator. */
983 if (e
->value
.op
.op
== INTRINSIC_POWER
)
986 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
990 if (op1
->ts
.type
== BT_INTEGER
)
993 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
997 /* Real combined with complex. */
998 e
->ts
.type
= BT_COMPLEX
;
999 if (op1
->ts
.kind
> op2
->ts
.kind
)
1000 e
->ts
.kind
= op1
->ts
.kind
;
1002 e
->ts
.kind
= op2
->ts
.kind
;
1003 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
1004 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
1005 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
1006 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
1013 /* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in
1014 constant expressions, except TRANSFER (c.f. item (8)), which would need
1015 separate treatment. */
1018 is_non_constant_intrinsic (gfc_expr
*e
)
1020 if (e
->expr_type
== EXPR_FUNCTION
1021 && e
->value
.function
.isym
)
1023 switch (e
->value
.function
.isym
->id
)
1025 case GFC_ISYM_COMMAND_ARGUMENT_COUNT
:
1026 case GFC_ISYM_GET_TEAM
:
1028 case GFC_ISYM_NUM_IMAGES
:
1029 case GFC_ISYM_TEAM_NUMBER
:
1030 case GFC_ISYM_THIS_IMAGE
:
1041 /* Determine if an expression is constant in the sense of F08:7.1.12.
1042 * This function expects that the expression has already been simplified. */
1045 gfc_is_constant_expr (gfc_expr
*e
)
1048 gfc_actual_arglist
*arg
;
1053 switch (e
->expr_type
)
1056 return (gfc_is_constant_expr (e
->value
.op
.op1
)
1057 && (e
->value
.op
.op2
== NULL
1058 || gfc_is_constant_expr (e
->value
.op
.op2
)));
1061 /* The only context in which this can occur is in a parameterized
1062 derived type declaration, so returning true is OK. */
1063 if (e
->symtree
->n
.sym
->attr
.pdt_len
1064 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1071 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1072 || e
->value
.function
.isym
);
1074 /* Check for intrinsics excluded in constant expressions. */
1075 if (e
->value
.function
.isym
&& is_non_constant_intrinsic (e
))
1078 /* Call to intrinsic with at least one argument. */
1079 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1081 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1082 if (!gfc_is_constant_expr (arg
->expr
))
1086 if (e
->value
.function
.isym
1087 && (e
->value
.function
.isym
->elemental
1088 || e
->value
.function
.isym
->pure
1089 || e
->value
.function
.isym
->inquiry
1090 || e
->value
.function
.isym
->transformational
))
1099 case EXPR_SUBSTRING
:
1100 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1101 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1104 case EXPR_STRUCTURE
:
1105 c
= gfc_constructor_first (e
->value
.constructor
);
1106 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1107 return gfc_constant_ac (e
);
1109 for (; c
; c
= gfc_constructor_next (c
))
1110 if (!gfc_is_constant_expr (c
->expr
))
1117 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1123 /* Is true if the expression or symbol is a passed CFI descriptor. */
1125 is_CFI_desc (gfc_symbol
*sym
, gfc_expr
*e
)
1128 && e
&& e
->expr_type
== EXPR_VARIABLE
)
1129 sym
= e
->symtree
->n
.sym
;
1131 if (sym
&& sym
->attr
.dummy
1132 && sym
->ns
->proc_name
->attr
.is_bind_c
1133 && (sym
->attr
.pointer
1134 || sym
->attr
.allocatable
1135 || (sym
->attr
.dimension
1136 && (sym
->as
->type
== AS_ASSUMED_SHAPE
1137 || sym
->as
->type
== AS_ASSUMED_RANK
))
1138 || (sym
->ts
.type
== BT_CHARACTER
1139 && (!sym
->ts
.u
.cl
|| !sym
->ts
.u
.cl
->length
))))
1146 /* Is true if an array reference is followed by a component or substring
1149 is_subref_array (gfc_expr
* e
)
1155 if (e
->expr_type
!= EXPR_VARIABLE
)
1158 sym
= e
->symtree
->n
.sym
;
1160 if (sym
->attr
.subref_array_pointer
)
1165 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1167 /* If we haven't seen the array reference and this is an intrinsic,
1168 what follows cannot be a subreference array, unless there is a
1169 substring reference. */
1170 if (!seen_array
&& ref
->type
== REF_COMPONENT
1171 && ref
->u
.c
.component
->ts
.type
!= BT_CHARACTER
1172 && ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1173 && !gfc_bt_struct (ref
->u
.c
.component
->ts
.type
))
1176 if (ref
->type
== REF_ARRAY
1177 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1181 && ref
->type
!= REF_ARRAY
)
1185 if (sym
->ts
.type
== BT_CLASS
1187 && CLASS_DATA (sym
)->attr
.dimension
1188 && CLASS_DATA (sym
)->attr
.class_pointer
)
1195 /* Try to collapse intrinsic expressions. */
1198 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1200 gfc_intrinsic_op op
;
1201 gfc_expr
*op1
, *op2
, *result
;
1203 if (p
->value
.op
.op
== INTRINSIC_USER
)
1206 op1
= p
->value
.op
.op1
;
1207 op2
= p
->value
.op
.op2
;
1208 op
= p
->value
.op
.op
;
1210 if (!gfc_simplify_expr (op1
, type
))
1212 if (!gfc_simplify_expr (op2
, type
))
1215 if (!gfc_is_constant_expr (op1
)
1216 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1220 p
->value
.op
.op1
= NULL
;
1221 p
->value
.op
.op2
= NULL
;
1225 case INTRINSIC_PARENTHESES
:
1226 result
= gfc_parentheses (op1
);
1229 case INTRINSIC_UPLUS
:
1230 result
= gfc_uplus (op1
);
1233 case INTRINSIC_UMINUS
:
1234 result
= gfc_uminus (op1
);
1237 case INTRINSIC_PLUS
:
1238 result
= gfc_add (op1
, op2
);
1241 case INTRINSIC_MINUS
:
1242 result
= gfc_subtract (op1
, op2
);
1245 case INTRINSIC_TIMES
:
1246 result
= gfc_multiply (op1
, op2
);
1249 case INTRINSIC_DIVIDE
:
1250 result
= gfc_divide (op1
, op2
);
1253 case INTRINSIC_POWER
:
1254 result
= gfc_power (op1
, op2
);
1257 case INTRINSIC_CONCAT
:
1258 result
= gfc_concat (op1
, op2
);
1262 case INTRINSIC_EQ_OS
:
1263 result
= gfc_eq (op1
, op2
, op
);
1267 case INTRINSIC_NE_OS
:
1268 result
= gfc_ne (op1
, op2
, op
);
1272 case INTRINSIC_GT_OS
:
1273 result
= gfc_gt (op1
, op2
, op
);
1277 case INTRINSIC_GE_OS
:
1278 result
= gfc_ge (op1
, op2
, op
);
1282 case INTRINSIC_LT_OS
:
1283 result
= gfc_lt (op1
, op2
, op
);
1287 case INTRINSIC_LE_OS
:
1288 result
= gfc_le (op1
, op2
, op
);
1292 result
= gfc_not (op1
);
1296 result
= gfc_and (op1
, op2
);
1300 result
= gfc_or (op1
, op2
);
1304 result
= gfc_eqv (op1
, op2
);
1307 case INTRINSIC_NEQV
:
1308 result
= gfc_neqv (op1
, op2
);
1312 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1317 gfc_free_expr (op1
);
1318 gfc_free_expr (op2
);
1322 result
->rank
= p
->rank
;
1323 result
->where
= p
->where
;
1324 gfc_replace_expr (p
, result
);
1330 /* Subroutine to simplify constructor expressions. Mutually recursive
1331 with gfc_simplify_expr(). */
1334 simplify_constructor (gfc_constructor_base base
, int type
)
1339 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1342 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1343 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1344 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1349 /* Try and simplify a copy. Replace the original if successful
1350 but keep going through the constructor at all costs. Not
1351 doing so can make a dog's dinner of complicated things. */
1352 p
= gfc_copy_expr (c
->expr
);
1354 if (!gfc_simplify_expr (p
, type
))
1360 gfc_replace_expr (c
->expr
, p
);
1368 /* Pull a single array element out of an array constructor. */
1371 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1372 gfc_constructor
**rval
)
1374 unsigned long nelemen
;
1380 gfc_constructor
*cons
;
1387 mpz_init_set_ui (offset
, 0);
1390 mpz_init_set_ui (span
, 1);
1391 for (i
= 0; i
< ar
->dimen
; i
++)
1393 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1394 || !gfc_reduce_init_expr (ar
->as
->upper
[i
])
1395 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
1396 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
)
1404 if (e
->expr_type
!= EXPR_CONSTANT
)
1410 /* Check the bounds. */
1411 if ((ar
->as
->upper
[i
]
1412 && mpz_cmp (e
->value
.integer
,
1413 ar
->as
->upper
[i
]->value
.integer
) > 0)
1414 || (mpz_cmp (e
->value
.integer
,
1415 ar
->as
->lower
[i
]->value
.integer
) < 0))
1417 gfc_error ("Index in dimension %d is out of bounds "
1418 "at %L", i
+ 1, &ar
->c_where
[i
]);
1424 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1425 mpz_mul (delta
, delta
, span
);
1426 mpz_add (offset
, offset
, delta
);
1428 mpz_set_ui (tmp
, 1);
1429 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1430 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1431 mpz_mul (span
, span
, tmp
);
1434 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1435 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1454 /* Find a component of a structure constructor. */
1456 static gfc_constructor
*
1457 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1459 gfc_component
*pick
= ref
->u
.c
.component
;
1460 gfc_constructor
*c
= gfc_constructor_first (base
);
1462 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1463 int ext
= dt
->attr
.extension
;
1465 /* For extended types, check if the desired component is in one of the
1467 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1468 pick
->name
, true, true, NULL
))
1470 dt
= dt
->components
->ts
.u
.derived
;
1471 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1475 gfc_component
*comp
= dt
->components
;
1476 while (comp
!= pick
)
1479 c
= gfc_constructor_next (c
);
1486 /* Replace an expression with the contents of a constructor, removing
1487 the subobject reference in the process. */
1490 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1500 e
= gfc_copy_expr (p
);
1501 e
->ref
= p
->ref
->next
;
1502 p
->ref
->next
= NULL
;
1503 gfc_replace_expr (p
, e
);
1507 /* Pull an array section out of an array constructor. */
1510 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1517 long unsigned one
= 1;
1519 mpz_t start
[GFC_MAX_DIMENSIONS
];
1520 mpz_t end
[GFC_MAX_DIMENSIONS
];
1521 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1522 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1523 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1528 gfc_constructor_base base
;
1529 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1539 base
= expr
->value
.constructor
;
1540 expr
->value
.constructor
= NULL
;
1542 rank
= ref
->u
.ar
.as
->rank
;
1544 if (expr
->shape
== NULL
)
1545 expr
->shape
= gfc_get_shape (rank
);
1547 mpz_init_set_ui (delta_mpz
, one
);
1548 mpz_init_set_ui (nelts
, one
);
1552 /* Do the initialization now, so that we can cleanup without
1553 keeping track of where we were. */
1554 for (d
= 0; d
< rank
; d
++)
1556 mpz_init (delta
[d
]);
1557 mpz_init (start
[d
]);
1560 mpz_init (stride
[d
]);
1564 /* Build the counters to clock through the array reference. */
1566 for (d
= 0; d
< rank
; d
++)
1568 /* Make this stretch of code easier on the eye! */
1569 begin
= ref
->u
.ar
.start
[d
];
1570 finish
= ref
->u
.ar
.end
[d
];
1571 step
= ref
->u
.ar
.stride
[d
];
1572 lower
= ref
->u
.ar
.as
->lower
[d
];
1573 upper
= ref
->u
.ar
.as
->upper
[d
];
1575 if (!lower
|| !upper
1576 || lower
->expr_type
!= EXPR_CONSTANT
1577 || upper
->expr_type
!= EXPR_CONSTANT
1578 || lower
->ts
.type
!= BT_INTEGER
1579 || upper
->ts
.type
!= BT_INTEGER
)
1585 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1587 gfc_constructor
*ci
;
1590 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1596 gcc_assert (begin
->rank
== 1);
1597 /* Zero-sized arrays have no shape and no elements, stop early. */
1600 mpz_init_set_ui (nelts
, 0);
1604 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1605 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1606 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1607 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1610 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1612 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1613 || mpz_cmp (ci
->expr
->value
.integer
,
1614 lower
->value
.integer
) < 0)
1616 gfc_error ("index in dimension %d is out of bounds "
1617 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1625 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1626 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1627 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1633 /* Obtain the stride. */
1635 mpz_set (stride
[d
], step
->value
.integer
);
1637 mpz_set_ui (stride
[d
], one
);
1639 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1640 mpz_set_ui (stride
[d
], one
);
1642 /* Obtain the start value for the index. */
1644 mpz_set (start
[d
], begin
->value
.integer
);
1646 mpz_set (start
[d
], lower
->value
.integer
);
1648 mpz_set (ctr
[d
], start
[d
]);
1650 /* Obtain the end value for the index. */
1652 mpz_set (end
[d
], finish
->value
.integer
);
1654 mpz_set (end
[d
], upper
->value
.integer
);
1656 /* Separate 'if' because elements sometimes arrive with
1658 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1659 mpz_set (end
[d
], begin
->value
.integer
);
1661 /* Check the bounds. */
1662 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1663 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1664 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1665 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1667 gfc_error ("index in dimension %d is out of bounds "
1668 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1673 /* Calculate the number of elements and the shape. */
1674 mpz_set (tmp_mpz
, stride
[d
]);
1675 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1676 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1677 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1678 mpz_mul (nelts
, nelts
, tmp_mpz
);
1680 /* An element reference reduces the rank of the expression; don't
1681 add anything to the shape array. */
1682 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1683 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1686 /* Calculate the 'stride' (=delta) for conversion of the
1687 counter values into the index along the constructor. */
1688 mpz_set (delta
[d
], delta_mpz
);
1689 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1690 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1691 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1694 cons
= gfc_constructor_first (base
);
1696 /* Now clock through the array reference, calculating the index in
1697 the source constructor and transferring the elements to the new
1699 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1701 mpz_init_set_ui (ptr
, 0);
1704 for (d
= 0; d
< rank
; d
++)
1706 mpz_set (tmp_mpz
, ctr
[d
]);
1707 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1708 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1709 mpz_add (ptr
, ptr
, tmp_mpz
);
1711 if (!incr_ctr
) continue;
1713 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1715 gcc_assert(vecsub
[d
]);
1717 if (!gfc_constructor_next (vecsub
[d
]))
1718 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1721 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1724 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1728 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1730 if (mpz_cmp_ui (stride
[d
], 0) > 0
1731 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1732 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1733 mpz_set (ctr
[d
], start
[d
]);
1739 limit
= mpz_get_ui (ptr
);
1740 if (limit
>= flag_max_array_constructor
)
1742 gfc_error ("The number of elements in the array constructor "
1743 "at %L requires an increase of the allowed %d "
1744 "upper limit. See %<-fmax-array-constructor%> "
1745 "option", &expr
->where
, flag_max_array_constructor
);
1750 cons
= gfc_constructor_lookup (base
, limit
);
1753 gfc_error ("Error in array constructor referenced at %L",
1758 gfc_constructor_append_expr (&expr
->value
.constructor
,
1759 gfc_copy_expr (cons
->expr
), NULL
);
1764 mpz_clear (delta_mpz
);
1765 mpz_clear (tmp_mpz
);
1767 for (d
= 0; d
< rank
; d
++)
1769 mpz_clear (delta
[d
]);
1770 mpz_clear (start
[d
]);
1773 mpz_clear (stride
[d
]);
1776 gfc_constructor_free (base
);
1780 /* Pull a substring out of an expression. */
1783 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1786 gfc_charlen_t start
;
1787 gfc_charlen_t length
;
1790 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1791 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1794 *newp
= gfc_copy_expr (p
);
1795 free ((*newp
)->value
.character
.string
);
1797 end
= (gfc_charlen_t
) mpz_get_si (p
->ref
->u
.ss
.end
->value
.integer
);
1798 start
= (gfc_charlen_t
) mpz_get_si (p
->ref
->u
.ss
.start
->value
.integer
);
1800 length
= end
- start
+ 1;
1804 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1805 (*newp
)->value
.character
.length
= length
;
1806 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1807 length
* sizeof (gfc_char_t
));
1813 /* Pull an inquiry result out of an expression. */
1816 find_inquiry_ref (gfc_expr
*p
, gfc_expr
**newp
)
1819 gfc_ref
*inquiry
= NULL
;
1822 tmp
= gfc_copy_expr (p
);
1824 if (tmp
->ref
&& tmp
->ref
->type
== REF_INQUIRY
)
1831 for (ref
= tmp
->ref
; ref
; ref
= ref
->next
)
1832 if (ref
->next
&& ref
->next
->type
== REF_INQUIRY
)
1834 inquiry
= ref
->next
;
1841 gfc_free_expr (tmp
);
1845 gfc_resolve_expr (tmp
);
1847 /* In principle there can be more than one inquiry reference. */
1848 for (; inquiry
; inquiry
= inquiry
->next
)
1850 switch (inquiry
->u
.i
)
1853 if (tmp
->ts
.type
!= BT_CHARACTER
)
1856 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1859 if (tmp
->ts
.u
.cl
->length
1860 && tmp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1861 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1862 else if (tmp
->expr_type
== EXPR_CONSTANT
)
1863 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1864 NULL
, tmp
->value
.character
.length
);
1865 else if (gfc_init_expr_flag
1866 && tmp
->ts
.u
.cl
->length
->symtree
->n
.sym
->attr
.pdt_len
)
1867 *newp
= gfc_pdt_find_component_copy_initializer (tmp
->symtree
->n
1878 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1881 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1884 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1885 NULL
, tmp
->ts
.kind
);
1889 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1892 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1895 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1896 mpfr_set ((*newp
)->value
.real
,
1897 mpc_realref (tmp
->value
.complex), GFC_RND_MODE
);
1901 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1904 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1907 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1908 mpfr_set ((*newp
)->value
.real
,
1909 mpc_imagref (tmp
->value
.complex), GFC_RND_MODE
);
1912 // TODO: Fix leaking expr tmp, when simplify is done twice.
1914 gfc_replace_expr (tmp
, *newp
);
1919 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1921 gfc_free_expr (*newp
);
1925 gfc_free_expr (tmp
);
1929 gfc_free_expr (tmp
);
1935 /* Simplify a subobject reference of a constructor. This occurs when
1936 parameter variable values are substituted. */
1939 simplify_const_ref (gfc_expr
*p
)
1941 gfc_constructor
*cons
, *c
;
1942 gfc_expr
*newp
= NULL
;
1947 switch (p
->ref
->type
)
1950 switch (p
->ref
->u
.ar
.type
)
1953 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1954 will generate this. */
1955 if (p
->expr_type
!= EXPR_ARRAY
)
1957 remove_subobject_ref (p
, NULL
);
1960 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1966 remove_subobject_ref (p
, cons
);
1970 if (!find_array_section (p
, p
->ref
))
1972 p
->ref
->u
.ar
.type
= AR_FULL
;
1977 if (p
->ref
->next
!= NULL
1978 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1980 for (c
= gfc_constructor_first (p
->value
.constructor
);
1981 c
; c
= gfc_constructor_next (c
))
1983 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1984 if (!simplify_const_ref (c
->expr
))
1988 if (gfc_bt_struct (p
->ts
.type
)
1990 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1992 /* There may have been component references. */
1993 p
->ts
= c
->expr
->ts
;
1997 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1999 if (p
->ts
.type
== BT_CHARACTER
2000 && last_ref
->type
== REF_SUBSTRING
)
2002 /* If this is a CHARACTER array and we possibly took
2003 a substring out of it, update the type-spec's
2004 character length according to the first element
2005 (as all should have the same length). */
2006 gfc_charlen_t string_len
;
2007 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
2009 const gfc_expr
* first
= c
->expr
;
2010 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
2011 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
2012 string_len
= first
->value
.character
.length
;
2020 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
2023 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
,
2027 gfc_free_expr (p
->ts
.u
.cl
->length
);
2030 = gfc_get_int_expr (gfc_charlen_int_kind
,
2034 gfc_free_ref_list (p
->ref
);
2045 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
2046 remove_subobject_ref (p
, cons
);
2050 if (!find_inquiry_ref (p
, &newp
))
2053 gfc_replace_expr (p
, newp
);
2054 gfc_free_ref_list (p
->ref
);
2059 if (!find_substring_ref (p
, &newp
))
2062 gfc_replace_expr (p
, newp
);
2063 gfc_free_ref_list (p
->ref
);
2073 /* Simplify a chain of references. */
2076 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
2079 gfc_expr
*newp
= NULL
;
2081 for (; ref
; ref
= ref
->next
)
2086 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2088 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
2090 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
2092 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
2098 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
2100 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
2105 if (!find_inquiry_ref (*p
, &newp
))
2108 gfc_replace_expr (*p
, newp
);
2109 gfc_free_ref_list ((*p
)->ref
);
2121 /* Try to substitute the value of a parameter variable. */
2124 simplify_parameter_variable (gfc_expr
*p
, int type
)
2129 /* Set rank and check array ref; as resolve_variable calls
2130 gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */
2131 if (!gfc_resolve_ref (p
))
2136 gfc_expression_rank (p
);
2138 /* Is this an inquiry? */
2139 bool inquiry
= false;
2140 gfc_ref
* ref
= p
->ref
;
2143 if (ref
->type
== REF_INQUIRY
)
2147 if (ref
&& ref
->type
== REF_INQUIRY
)
2148 inquiry
= ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
;
2150 if (gfc_is_size_zero_array (p
))
2152 if (p
->expr_type
== EXPR_ARRAY
)
2155 e
= gfc_get_expr ();
2156 e
->expr_type
= EXPR_ARRAY
;
2159 e
->value
.constructor
= NULL
;
2160 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2161 e
->where
= p
->where
;
2162 /* If %kind and %len are not used then we're done, otherwise
2163 drop through for simplification. */
2166 gfc_replace_expr (p
, e
);
2172 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2176 gfc_free_shape (&e
->shape
, e
->rank
);
2177 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2180 if (e
->ts
.type
== BT_CHARACTER
&& p
->ts
.u
.cl
)
2184 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
)
2185 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, p
->ts
.u
.cl
);
2187 /* Do not copy subobject refs for constant. */
2188 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2189 e
->ref
= gfc_copy_ref (p
->ref
);
2190 t
= gfc_simplify_expr (e
, type
);
2191 e
->where
= p
->where
;
2193 /* Only use the simplification if it eliminated all subobject references. */
2195 gfc_replace_expr (p
, e
);
2204 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2206 /* Given an expression, simplify it by collapsing constant
2207 expressions. Most simplification takes place when the expression
2208 tree is being constructed. If an intrinsic function is simplified
2209 at some point, we get called again to collapse the result against
2212 We work by recursively simplifying expression nodes, simplifying
2213 intrinsic functions where possible, which can lead to further
2214 constant collapsing. If an operator has constant operand(s), we
2215 rip the expression apart, and rebuild it, hoping that it becomes
2218 The expression type is defined for:
2219 0 Basic expression parsing
2220 1 Simplifying array constructors -- will substitute
2222 Returns false on error, true otherwise.
2223 NOTE: Will return true even if the expression cannot be simplified. */
2226 gfc_simplify_expr (gfc_expr
*p
, int type
)
2228 gfc_actual_arglist
*ap
;
2229 gfc_intrinsic_sym
* isym
= NULL
;
2235 switch (p
->expr_type
)
2238 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2239 simplify_ref_chain (p
->ref
, type
, &p
);
2245 // For array-bound functions, we don't need to optimize
2246 // the 'array' argument. In particular, if the argument
2247 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2248 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2249 // can have any lbound.
2250 ap
= p
->value
.function
.actual
;
2251 if (p
->value
.function
.isym
&&
2252 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2253 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2254 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2255 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
2256 || p
->value
.function
.isym
->id
== GFC_ISYM_SHAPE
))
2259 for ( ; ap
; ap
= ap
->next
)
2260 if (!gfc_simplify_expr (ap
->expr
, type
))
2263 if (p
->value
.function
.isym
!= NULL
2264 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2267 if (p
->symtree
&& (p
->value
.function
.isym
|| p
->ts
.type
== BT_UNKNOWN
))
2269 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2270 if (isym
&& isym
->elemental
)
2271 scalarize_intrinsic_call (p
, false);
2276 case EXPR_SUBSTRING
:
2277 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2280 if (gfc_is_constant_expr (p
))
2283 HOST_WIDE_INT start
, end
;
2286 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2288 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2289 start
--; /* Convert from one-based to zero-based. */
2292 end
= p
->value
.character
.length
;
2293 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2294 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2299 s
= gfc_get_wide_string (end
- start
+ 2);
2300 memcpy (s
, p
->value
.character
.string
+ start
,
2301 (end
- start
) * sizeof (gfc_char_t
));
2302 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2303 free (p
->value
.character
.string
);
2304 p
->value
.character
.string
= s
;
2305 p
->value
.character
.length
= end
- start
;
2306 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2307 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2309 p
->value
.character
.length
);
2310 gfc_free_ref_list (p
->ref
);
2312 p
->expr_type
= EXPR_CONSTANT
;
2317 if (!simplify_intrinsic_op (p
, type
))
2322 /* Only substitute array parameter variables if we are in an
2323 initialization expression, or we want a subsection. */
2324 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2325 && (gfc_init_expr_flag
|| p
->ref
2326 || (p
->symtree
->n
.sym
->value
2327 && p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
)))
2329 if (!simplify_parameter_variable (p
, type
))
2336 gfc_simplify_iterator_var (p
);
2339 /* Simplify subcomponent references. */
2340 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2345 case EXPR_STRUCTURE
:
2347 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2350 /* If the following conditions hold, we found something like kind type
2351 inquiry of the form a(2)%kind while simplify the ref chain. */
2352 if (p
->expr_type
== EXPR_CONSTANT
&& !p
->ref
&& !p
->rank
&& !p
->shape
)
2355 if (!simplify_constructor (p
->value
.constructor
, type
))
2358 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2359 && p
->ref
->u
.ar
.type
== AR_FULL
)
2360 gfc_expand_constructor (p
, false);
2362 if (!simplify_const_ref (p
))
2379 /* Try simplification of an expression via gfc_simplify_expr.
2380 When an error occurs (arithmetic or otherwise), roll back. */
2383 gfc_try_simplify_expr (gfc_expr
*e
, int type
)
2388 if (e
== NULL
|| e
->expr_type
== EXPR_CONSTANT
)
2391 saved_div0
= gfc_seen_div0
;
2392 gfc_seen_div0
= false;
2393 n
= gfc_copy_expr (e
);
2394 t
= gfc_simplify_expr (n
, type
) && !gfc_seen_div0
;
2396 gfc_replace_expr (e
, n
);
2399 gfc_seen_div0
= saved_div0
;
2404 /* Returns the type of an expression with the exception that iterator
2405 variables are automatically integers no matter what else they may
2411 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2418 /* Scalarize an expression for an elemental intrinsic call. */
2421 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2423 gfc_actual_arglist
*a
, *b
;
2424 gfc_constructor_base ctor
;
2425 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2426 gfc_constructor
*ci
, *new_ctor
;
2427 gfc_expr
*expr
, *old
, *p
;
2428 int n
, i
, rank
[5], array_arg
;
2433 a
= e
->value
.function
.actual
;
2434 for (; a
; a
= a
->next
)
2435 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2438 /* Find which, if any, arguments are arrays. Assume that the old
2439 expression carries the type information and that the first arg
2440 that is an array expression carries all the shape information.*/
2442 a
= e
->value
.function
.actual
;
2443 for (; a
; a
= a
->next
)
2446 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2449 expr
= gfc_copy_expr (a
->expr
);
2456 old
= gfc_copy_expr (e
);
2458 gfc_constructor_free (expr
->value
.constructor
);
2459 expr
->value
.constructor
= NULL
;
2461 expr
->where
= old
->where
;
2462 expr
->expr_type
= EXPR_ARRAY
;
2464 /* Copy the array argument constructors into an array, with nulls
2467 a
= old
->value
.function
.actual
;
2468 for (; a
; a
= a
->next
)
2470 /* Check that this is OK for an initialization expression. */
2471 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2475 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2477 rank
[n
] = a
->expr
->rank
;
2478 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2479 args
[n
] = gfc_constructor_first (ctor
);
2481 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2484 rank
[n
] = a
->expr
->rank
;
2487 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2488 args
[n
] = gfc_constructor_first (ctor
);
2496 /* Using the array argument as the master, step through the array
2497 calling the function for each element and advancing the array
2498 constructors together. */
2499 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2501 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2502 gfc_copy_expr (old
), NULL
);
2504 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2506 b
= old
->value
.function
.actual
;
2507 for (i
= 0; i
< n
; i
++)
2510 new_ctor
->expr
->value
.function
.actual
2511 = a
= gfc_get_actual_arglist ();
2514 a
->next
= gfc_get_actual_arglist ();
2519 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2521 a
->expr
= gfc_copy_expr (b
->expr
);
2526 /* Simplify the function calls. If the simplification fails, the
2527 error will be flagged up down-stream or the library will deal
2529 p
= gfc_copy_expr (new_ctor
->expr
);
2531 if (!gfc_simplify_expr (p
, init_flag
))
2534 gfc_replace_expr (new_ctor
->expr
, p
);
2536 for (i
= 0; i
< n
; i
++)
2538 args
[i
] = gfc_constructor_next (args
[i
]);
2540 for (i
= 1; i
< n
; i
++)
2541 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2542 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2548 /* Free "expr" but not the pointers it contains. */
2550 gfc_free_expr (old
);
2554 gfc_error_now ("elemental function arguments at %C are not compliant");
2557 gfc_free_expr (expr
);
2558 gfc_free_expr (old
);
2564 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2566 gfc_expr
*op1
= e
->value
.op
.op1
;
2567 gfc_expr
*op2
= e
->value
.op
.op2
;
2569 if (!(*check_function
)(op1
))
2572 switch (e
->value
.op
.op
)
2574 case INTRINSIC_UPLUS
:
2575 case INTRINSIC_UMINUS
:
2576 if (!numeric_type (et0 (op1
)))
2581 case INTRINSIC_EQ_OS
:
2583 case INTRINSIC_NE_OS
:
2585 case INTRINSIC_GT_OS
:
2587 case INTRINSIC_GE_OS
:
2589 case INTRINSIC_LT_OS
:
2591 case INTRINSIC_LE_OS
:
2592 if (!(*check_function
)(op2
))
2595 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2596 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2598 gfc_error ("Numeric or CHARACTER operands are required in "
2599 "expression at %L", &e
->where
);
2604 case INTRINSIC_PLUS
:
2605 case INTRINSIC_MINUS
:
2606 case INTRINSIC_TIMES
:
2607 case INTRINSIC_DIVIDE
:
2608 case INTRINSIC_POWER
:
2609 if (!(*check_function
)(op2
))
2612 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2617 case INTRINSIC_CONCAT
:
2618 if (!(*check_function
)(op2
))
2621 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2623 gfc_error ("Concatenation operator in expression at %L "
2624 "must have two CHARACTER operands", &op1
->where
);
2628 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2630 gfc_error ("Concat operator at %L must concatenate strings of the "
2631 "same kind", &e
->where
);
2638 if (et0 (op1
) != BT_LOGICAL
)
2640 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2641 "operand", &op1
->where
);
2650 case INTRINSIC_NEQV
:
2651 if (!(*check_function
)(op2
))
2654 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2656 gfc_error ("LOGICAL operands are required in expression at %L",
2663 case INTRINSIC_PARENTHESES
:
2667 gfc_error ("Only intrinsic operators can be used in expression at %L",
2675 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2680 /* F2003, 7.1.7 (3): In init expression, allocatable components
2681 must not be data-initialized. */
2683 check_alloc_comp_init (gfc_expr
*e
)
2685 gfc_component
*comp
;
2686 gfc_constructor
*ctor
;
2688 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2689 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2691 for (comp
= e
->ts
.u
.derived
->components
,
2692 ctor
= gfc_constructor_first (e
->value
.constructor
);
2693 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2695 if (comp
->attr
.allocatable
&& ctor
->expr
2696 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2698 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2699 "component %qs in structure constructor at %L",
2700 comp
->name
, &ctor
->expr
->where
);
2709 check_init_expr_arguments (gfc_expr
*e
)
2711 gfc_actual_arglist
*ap
;
2713 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2714 if (!gfc_check_init_expr (ap
->expr
))
2720 static bool check_restricted (gfc_expr
*);
2722 /* F95, 7.1.6.1, Initialization expressions, (7)
2723 F2003, 7.1.7 Initialization expression, (8)
2724 F2008, 7.1.12 Constant expression, (4) */
2727 check_inquiry (gfc_expr
*e
, int not_restricted
)
2730 const char *const *functions
;
2732 static const char *const inquiry_func_f95
[] = {
2733 "lbound", "shape", "size", "ubound",
2734 "bit_size", "len", "kind",
2735 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2736 "precision", "radix", "range", "tiny",
2740 static const char *const inquiry_func_f2003
[] = {
2741 "lbound", "shape", "size", "ubound",
2742 "bit_size", "len", "kind",
2743 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2744 "precision", "radix", "range", "tiny",
2748 /* std=f2008+ or -std=gnu */
2749 static const char *const inquiry_func_gnu
[] = {
2750 "lbound", "shape", "size", "ubound",
2751 "bit_size", "len", "kind",
2752 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2753 "precision", "radix", "range", "tiny",
2754 "new_line", "storage_size", NULL
2758 gfc_actual_arglist
*ap
;
2762 if (!e
->value
.function
.isym
2763 || !e
->value
.function
.isym
->inquiry
)
2766 /* An undeclared parameter will get us here (PR25018). */
2767 if (e
->symtree
== NULL
)
2770 sym
= e
->symtree
->n
.sym
;
2772 if (sym
->from_intmod
)
2774 if (sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2775 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2776 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2779 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2780 && sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2787 functions
= inquiry_func_gnu
;
2788 if (gfc_option
.warn_std
& GFC_STD_F2003
)
2789 functions
= inquiry_func_f2003
;
2790 if (gfc_option
.warn_std
& GFC_STD_F95
)
2791 functions
= inquiry_func_f95
;
2793 for (i
= 0; functions
[i
]; i
++)
2794 if (strcmp (functions
[i
], name
) == 0)
2797 if (functions
[i
] == NULL
)
2801 /* At this point we have an inquiry function with a variable argument. The
2802 type of the variable might be undefined, but we need it now, because the
2803 arguments of these functions are not allowed to be undefined. */
2805 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2810 asym
= ap
->expr
->symtree
? ap
->expr
->symtree
->n
.sym
: NULL
;
2812 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2814 if (asym
&& asym
->ts
.type
== BT_UNKNOWN
2815 && !gfc_set_default_type (asym
, 0, gfc_current_ns
))
2818 ap
->expr
->ts
= asym
->ts
;
2821 if (asym
&& asym
->assoc
&& asym
->assoc
->target
2822 && asym
->assoc
->target
->expr_type
== EXPR_CONSTANT
)
2824 gfc_free_expr (ap
->expr
);
2825 ap
->expr
= gfc_copy_expr (asym
->assoc
->target
);
2828 /* Assumed character length will not reduce to a constant expression
2829 with LEN, as required by the standard. */
2830 if (i
== 5 && not_restricted
&& asym
2831 && asym
->ts
.type
== BT_CHARACTER
2832 && ((asym
->ts
.u
.cl
&& asym
->ts
.u
.cl
->length
== NULL
)
2833 || asym
->ts
.deferred
))
2835 gfc_error ("Assumed or deferred character length variable %qs "
2836 "in constant expression at %L",
2837 asym
->name
, &ap
->expr
->where
);
2840 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2843 if (not_restricted
== 0
2844 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2845 && !check_restricted (ap
->expr
))
2848 if (not_restricted
== 0
2849 && ap
->expr
->expr_type
== EXPR_VARIABLE
2850 && asym
->attr
.dummy
&& asym
->attr
.optional
)
2858 /* F95, 7.1.6.1, Initialization expressions, (5)
2859 F2003, 7.1.7 Initialization expression, (5) */
2862 check_transformational (gfc_expr
*e
)
2864 static const char * const trans_func_f95
[] = {
2865 "repeat", "reshape", "selected_int_kind",
2866 "selected_real_kind", "transfer", "trim", NULL
2869 static const char * const trans_func_f2003
[] = {
2870 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2871 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2872 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2873 "trim", "unpack", NULL
2876 static const char * const trans_func_f2008
[] = {
2877 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2878 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2879 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2880 "trim", "unpack", "findloc", NULL
2885 const char *const *functions
;
2887 if (!e
->value
.function
.isym
2888 || !e
->value
.function
.isym
->transformational
)
2891 name
= e
->symtree
->n
.sym
->name
;
2893 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2894 functions
= trans_func_f2008
;
2895 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2896 functions
= trans_func_f2003
;
2898 functions
= trans_func_f95
;
2900 /* NULL() is dealt with below. */
2901 if (strcmp ("null", name
) == 0)
2904 for (i
= 0; functions
[i
]; i
++)
2905 if (strcmp (functions
[i
], name
) == 0)
2908 if (functions
[i
] == NULL
)
2910 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2911 "in an initialization expression", name
, &e
->where
);
2915 return check_init_expr_arguments (e
);
2919 /* F95, 7.1.6.1, Initialization expressions, (6)
2920 F2003, 7.1.7 Initialization expression, (6) */
2923 check_null (gfc_expr
*e
)
2925 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2928 return check_init_expr_arguments (e
);
2933 check_elemental (gfc_expr
*e
)
2935 if (!e
->value
.function
.isym
2936 || !e
->value
.function
.isym
->elemental
)
2939 if (e
->ts
.type
!= BT_INTEGER
2940 && e
->ts
.type
!= BT_CHARACTER
2941 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2942 "initialization expression at %L", &e
->where
))
2945 return check_init_expr_arguments (e
);
2950 check_conversion (gfc_expr
*e
)
2952 if (!e
->value
.function
.isym
2953 || !e
->value
.function
.isym
->conversion
)
2956 return check_init_expr_arguments (e
);
2960 /* Verify that an expression is an initialization expression. A side
2961 effect is that the expression tree is reduced to a single constant
2962 node if all goes well. This would normally happen when the
2963 expression is constructed but function references are assumed to be
2964 intrinsics in the context of initialization expressions. If
2965 false is returned an error message has been generated. */
2968 gfc_check_init_expr (gfc_expr
*e
)
2976 switch (e
->expr_type
)
2979 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2981 t
= gfc_simplify_expr (e
, 0);
2990 gfc_intrinsic_sym
* isym
= NULL
;
2991 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2993 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2994 IEEE_EXCEPTIONS modules. */
2995 int mod
= sym
->from_intmod
;
2996 if (mod
== INTMOD_NONE
&& sym
->generic
)
2997 mod
= sym
->generic
->sym
->from_intmod
;
2998 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
3000 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
3003 gfc_replace_expr (e
, new_expr
);
3009 /* If a conversion function, e.g., __convert_i8_i4, was inserted
3010 into an array constructor, we need to skip the error check here.
3011 Conversion errors are caught below in scalarize_intrinsic_call. */
3012 conversion
= e
->value
.function
.isym
3013 && (e
->value
.function
.isym
->conversion
== 1);
3015 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
3016 || (m
= gfc_intrinsic_func_interface (e
, 0)) == MATCH_NO
))
3018 gfc_error ("Function %qs in initialization expression at %L "
3019 "must be an intrinsic function",
3020 e
->symtree
->n
.sym
->name
, &e
->where
);
3024 if ((m
= check_conversion (e
)) == MATCH_NO
3025 && (m
= check_inquiry (e
, 1)) == MATCH_NO
3026 && (m
= check_null (e
)) == MATCH_NO
3027 && (m
= check_transformational (e
)) == MATCH_NO
3028 && (m
= check_elemental (e
)) == MATCH_NO
)
3030 gfc_error ("Intrinsic function %qs at %L is not permitted "
3031 "in an initialization expression",
3032 e
->symtree
->n
.sym
->name
, &e
->where
);
3036 if (m
== MATCH_ERROR
)
3039 /* Try to scalarize an elemental intrinsic function that has an
3041 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
3042 if (isym
&& isym
->elemental
3043 && (t
= scalarize_intrinsic_call (e
, true)))
3048 t
= gfc_simplify_expr (e
, 0);
3055 /* This occurs when parsing pdt templates. */
3056 if (gfc_expr_attr (e
).pdt_kind
)
3059 if (gfc_check_iter_variable (e
))
3062 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
3064 /* A PARAMETER shall not be used to define itself, i.e.
3065 REAL, PARAMETER :: x = transfer(0, x)
3067 if (!e
->symtree
->n
.sym
->value
)
3069 gfc_error ("PARAMETER %qs is used at %L before its definition "
3070 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
3074 t
= simplify_parameter_variable (e
, 0);
3079 if (gfc_in_match_data ())
3084 if (e
->symtree
->n
.sym
->as
)
3086 switch (e
->symtree
->n
.sym
->as
->type
)
3088 case AS_ASSUMED_SIZE
:
3089 gfc_error ("Assumed size array %qs at %L is not permitted "
3090 "in an initialization expression",
3091 e
->symtree
->n
.sym
->name
, &e
->where
);
3094 case AS_ASSUMED_SHAPE
:
3095 gfc_error ("Assumed shape array %qs at %L is not permitted "
3096 "in an initialization expression",
3097 e
->symtree
->n
.sym
->name
, &e
->where
);
3101 if (!e
->symtree
->n
.sym
->attr
.allocatable
3102 && !e
->symtree
->n
.sym
->attr
.pointer
3103 && e
->symtree
->n
.sym
->attr
.dummy
)
3104 gfc_error ("Assumed-shape array %qs at %L is not permitted "
3105 "in an initialization expression",
3106 e
->symtree
->n
.sym
->name
, &e
->where
);
3108 gfc_error ("Deferred array %qs at %L is not permitted "
3109 "in an initialization expression",
3110 e
->symtree
->n
.sym
->name
, &e
->where
);
3114 gfc_error ("Array %qs at %L is a variable, which does "
3115 "not reduce to a constant expression",
3116 e
->symtree
->n
.sym
->name
, &e
->where
);
3119 case AS_ASSUMED_RANK
:
3120 gfc_error ("Assumed-rank array %qs at %L is not permitted "
3121 "in an initialization expression",
3122 e
->symtree
->n
.sym
->name
, &e
->where
);
3130 gfc_error ("Parameter %qs at %L has not been declared or is "
3131 "a variable, which does not reduce to a constant "
3132 "expression", e
->symtree
->name
, &e
->where
);
3141 case EXPR_SUBSTRING
:
3144 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
3148 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
3150 t
= gfc_simplify_expr (e
, 0);
3156 case EXPR_STRUCTURE
:
3157 t
= e
->ts
.is_iso_c
? true : false;
3161 t
= check_alloc_comp_init (e
);
3165 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3172 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3176 t
= gfc_expand_constructor (e
, true);
3180 t
= gfc_check_constructor_type (e
);
3184 gfc_internal_error ("check_init_expr(): Unknown expression type");
3190 /* Reduces a general expression to an initialization expression (a constant).
3191 This used to be part of gfc_match_init_expr.
3192 Note that this function doesn't free the given expression on false. */
3195 gfc_reduce_init_expr (gfc_expr
*expr
)
3199 gfc_init_expr_flag
= true;
3200 t
= gfc_resolve_expr (expr
);
3202 t
= gfc_check_init_expr (expr
);
3203 gfc_init_expr_flag
= false;
3208 if (expr
->expr_type
== EXPR_ARRAY
)
3210 if (!gfc_check_constructor_type (expr
))
3212 if (!gfc_expand_constructor (expr
, true))
3220 /* Match an initialization expression. We work by first matching an
3221 expression, then reducing it to a constant. */
3224 gfc_match_init_expr (gfc_expr
**result
)
3232 gfc_init_expr_flag
= true;
3234 m
= gfc_match_expr (&expr
);
3237 gfc_init_expr_flag
= false;
3241 if (expr
->expr_type
!= EXPR_FUNCTION
&& gfc_derived_parameter_expr (expr
))
3244 gfc_init_expr_flag
= false;
3248 t
= gfc_reduce_init_expr (expr
);
3251 gfc_free_expr (expr
);
3252 gfc_init_expr_flag
= false;
3257 gfc_init_expr_flag
= false;
3263 /* Given an actual argument list, test to see that each argument is a
3264 restricted expression and optionally if the expression type is
3265 integer or character. */
3268 restricted_args (gfc_actual_arglist
*a
)
3270 for (; a
; a
= a
->next
)
3272 if (!check_restricted (a
->expr
))
3280 /************* Restricted/specification expressions *************/
3283 /* Make sure a non-intrinsic function is a specification function,
3284 * see F08:7.1.11.5. */
3287 external_spec_function (gfc_expr
*e
)
3291 f
= e
->value
.function
.esym
;
3293 /* IEEE functions allowed are "a reference to a transformational function
3294 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3295 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3296 IEEE_EXCEPTIONS". */
3297 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3298 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3300 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3301 || !strcmp (f
->name
, "ieee_support_rounding")
3302 || !strcmp (f
->name
, "ieee_support_flag")
3303 || !strcmp (f
->name
, "ieee_support_halting")
3304 || !strcmp (f
->name
, "ieee_support_datatype")
3305 || !strcmp (f
->name
, "ieee_support_denormal")
3306 || !strcmp (f
->name
, "ieee_support_subnormal")
3307 || !strcmp (f
->name
, "ieee_support_divide")
3308 || !strcmp (f
->name
, "ieee_support_inf")
3309 || !strcmp (f
->name
, "ieee_support_io")
3310 || !strcmp (f
->name
, "ieee_support_nan")
3311 || !strcmp (f
->name
, "ieee_support_sqrt")
3312 || !strcmp (f
->name
, "ieee_support_standard")
3313 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3314 goto function_allowed
;
3317 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3319 gfc_error ("Specification function %qs at %L cannot be a statement "
3320 "function", f
->name
, &e
->where
);
3324 if (f
->attr
.proc
== PROC_INTERNAL
)
3326 gfc_error ("Specification function %qs at %L cannot be an internal "
3327 "function", f
->name
, &e
->where
);
3331 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3333 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3339 if (f
->attr
.recursive
3340 && !gfc_notify_std (GFC_STD_F2003
,
3341 "Specification function %qs "
3342 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3346 return restricted_args (e
->value
.function
.actual
);
3350 /* Check to see that a function reference to an intrinsic is a
3351 restricted expression. */
3354 restricted_intrinsic (gfc_expr
*e
)
3356 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3357 if (check_inquiry (e
, 0) == MATCH_YES
)
3360 return restricted_args (e
->value
.function
.actual
);
3364 /* Check the expressions of an actual arglist. Used by check_restricted. */
3367 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3369 for (; arg
; arg
= arg
->next
)
3370 if (!checker (arg
->expr
))
3377 /* Check the subscription expressions of a reference chain with a checking
3378 function; used by check_restricted. */
3381 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3391 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3393 if (!checker (ref
->u
.ar
.start
[dim
]))
3395 if (!checker (ref
->u
.ar
.end
[dim
]))
3397 if (!checker (ref
->u
.ar
.stride
[dim
]))
3403 /* Nothing needed, just proceed to next reference. */
3407 if (!checker (ref
->u
.ss
.start
))
3409 if (!checker (ref
->u
.ss
.end
))
3418 return check_references (ref
->next
, checker
);
3421 /* Return true if ns is a parent of the current ns. */
3424 is_parent_of_current_ns (gfc_namespace
*ns
)
3427 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3434 /* Verify that an expression is a restricted expression. Like its
3435 cousin check_init_expr(), an error message is generated if we
3439 check_restricted (gfc_expr
*e
)
3447 switch (e
->expr_type
)
3450 t
= check_intrinsic_op (e
, check_restricted
);
3452 t
= gfc_simplify_expr (e
, 0);
3457 if (e
->value
.function
.esym
)
3459 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3461 t
= external_spec_function (e
);
3465 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3468 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3471 t
= restricted_intrinsic (e
);
3476 sym
= e
->symtree
->n
.sym
;
3479 /* If a dummy argument appears in a context that is valid for a
3480 restricted expression in an elemental procedure, it will have
3481 already been simplified away once we get here. Therefore we
3482 don't need to jump through hoops to distinguish valid from
3483 invalid cases. Allowed in F2008 and F2018. */
3484 if (gfc_notification_std (GFC_STD_F2008
)
3485 && sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3486 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3488 gfc_error_now ("Dummy argument %qs not "
3489 "allowed in expression at %L",
3490 sym
->name
, &e
->where
);
3494 if (sym
->attr
.optional
)
3496 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3497 sym
->name
, &e
->where
);
3501 if (sym
->attr
.intent
== INTENT_OUT
)
3503 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3504 sym
->name
, &e
->where
);
3508 /* Check reference chain if any. */
3509 if (!check_references (e
->ref
, &check_restricted
))
3512 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3513 processed in resolve.cc(resolve_formal_arglist). This is done so
3514 that host associated dummy array indices are accepted (PR23446).
3515 This mechanism also does the same for the specification expressions
3516 of array-valued functions. */
3518 || sym
->attr
.in_common
3519 || sym
->attr
.use_assoc
3521 || sym
->attr
.implied_index
3522 || sym
->attr
.flavor
== FL_PARAMETER
3523 || is_parent_of_current_ns (sym
->ns
)
3524 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3530 gfc_error ("Variable %qs cannot appear in the expression at %L",
3531 sym
->name
, &e
->where
);
3532 /* Prevent a repetition of the error. */
3541 case EXPR_SUBSTRING
:
3542 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3546 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3548 t
= gfc_simplify_expr (e
, 0);
3552 case EXPR_STRUCTURE
:
3553 t
= gfc_check_constructor (e
, check_restricted
);
3557 t
= gfc_check_constructor (e
, check_restricted
);
3561 gfc_internal_error ("check_restricted(): Unknown expression type");
3568 /* Check to see that an expression is a specification expression. If
3569 we return false, an error has been generated. */
3572 gfc_specification_expr (gfc_expr
*e
)
3574 gfc_component
*comp
;
3579 if (e
->ts
.type
!= BT_INTEGER
)
3581 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3582 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3586 comp
= gfc_get_proc_ptr_comp (e
);
3587 if (e
->expr_type
== EXPR_FUNCTION
3588 && !e
->value
.function
.isym
3589 && !e
->value
.function
.esym
3590 && !gfc_pure (e
->symtree
->n
.sym
)
3591 && (!comp
|| !comp
->attr
.pure
))
3593 gfc_error ("Function %qs at %L must be PURE",
3594 e
->symtree
->n
.sym
->name
, &e
->where
);
3595 /* Prevent repeat error messages. */
3596 e
->symtree
->n
.sym
->attr
.pure
= 1;
3602 gfc_error ("Expression at %L must be scalar", &e
->where
);
3606 if (!gfc_simplify_expr (e
, 0))
3609 return check_restricted (e
);
3613 /************** Expression conformance checks. *************/
3615 /* Given two expressions, make sure that the arrays are conformable. */
3618 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3620 int op1_flag
, op2_flag
, d
;
3621 mpz_t op1_size
, op2_size
;
3627 if (op1
->rank
== 0 || op2
->rank
== 0)
3630 va_start (argp
, optype_msgid
);
3631 d
= vsnprintf (buffer
, sizeof (buffer
), optype_msgid
, argp
);
3633 if (d
< 1 || d
>= (int) sizeof (buffer
)) /* Reject truncation. */
3634 gfc_internal_error ("optype_msgid overflow: %d", d
);
3636 if (op1
->rank
!= op2
->rank
)
3638 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3639 op1
->rank
, op2
->rank
, &op1
->where
);
3645 for (d
= 0; d
< op1
->rank
; d
++)
3647 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3648 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3650 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3652 gfc_error ("Different shape for %s at %L on dimension %d "
3653 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3654 (int) mpz_get_si (op1_size
),
3655 (int) mpz_get_si (op2_size
));
3661 mpz_clear (op1_size
);
3663 mpz_clear (op2_size
);
3673 /* Given an assignable expression and an arbitrary expression, make
3674 sure that the assignment can take place. Only add a call to the intrinsic
3675 conversion routines, when allow_convert is set. When this assign is a
3676 coarray call, then the convert is done by the coarray routine implicitly and
3677 adding the intrinsic conversion would do harm in most cases. */
3680 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3687 sym
= lvalue
->symtree
->n
.sym
;
3689 /* See if this is the component or subcomponent of a pointer and guard
3690 against assignment to LEN or KIND part-refs. */
3691 has_pointer
= sym
->attr
.pointer
;
3692 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3694 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3695 && ref
->u
.c
.component
->attr
.pointer
)
3697 else if (ref
->type
== REF_INQUIRY
3698 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3700 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3701 "allowed", &lvalue
->where
);
3706 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3707 variable local to a function subprogram. Its existence begins when
3708 execution of the function is initiated and ends when execution of the
3709 function is terminated...
3710 Therefore, the left hand side is no longer a variable, when it is: */
3711 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3712 && !sym
->attr
.external
)
3717 /* (i) Use associated; */
3718 if (sym
->attr
.use_assoc
)
3721 /* (ii) The assignment is in the main program; or */
3722 if (gfc_current_ns
->proc_name
3723 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3726 /* (iii) A module or internal procedure... */
3727 if (gfc_current_ns
->proc_name
3728 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3729 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3730 && gfc_current_ns
->parent
3731 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3732 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3733 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3735 /* ... that is not a function... */
3736 if (gfc_current_ns
->proc_name
3737 && !gfc_current_ns
->proc_name
->attr
.function
)
3740 /* ... or is not an entry and has a different name. */
3741 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3745 /* (iv) Host associated and not the function symbol or the
3746 parent result. This picks up sibling references, which
3747 cannot be entries. */
3748 if (!sym
->attr
.entry
3749 && sym
->ns
== gfc_current_ns
->parent
3750 && sym
!= gfc_current_ns
->proc_name
3751 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3756 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3762 /* Reject assigning to an external symbol. For initializers, this
3763 was already done before, in resolve_fl_procedure. */
3764 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
3765 && sym
->attr
.proc
!= PROC_MODULE
&& !rvalue
->error
)
3767 gfc_error ("Illegal assignment to external procedure at %L",
3773 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3775 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3776 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3780 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3782 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3787 if (rvalue
->expr_type
== EXPR_NULL
)
3789 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3790 && lvalue
->symtree
->n
.sym
->attr
.data
)
3794 gfc_error ("NULL appears on right-hand side in assignment at %L",
3800 /* This is possibly a typo: x = f() instead of x => f(). */
3802 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3803 gfc_warning (OPT_Wsurprising
,
3804 "POINTER-valued function appears on right-hand side of "
3805 "assignment at %L", &rvalue
->where
);
3807 /* Check size of array assignments. */
3808 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3809 && !gfc_check_conformance (lvalue
, rvalue
, _("array assignment")))
3812 /* Handle the case of a BOZ literal on the RHS. */
3813 if (rvalue
->ts
.type
== BT_BOZ
)
3815 if (lvalue
->symtree
->n
.sym
->attr
.data
)
3817 if (lvalue
->ts
.type
== BT_INTEGER
3818 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3821 if (lvalue
->ts
.type
== BT_REAL
3822 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3824 if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
3825 "be assigned to a REAL variable",
3832 if (!lvalue
->symtree
->n
.sym
->attr
.data
3833 && gfc_invalid_boz ("BOZ literal constant at %L is neither a "
3834 "data-stmt-constant nor an actual argument to "
3835 "INT, REAL, DBLE, or CMPLX intrinsic function",
3839 if (lvalue
->ts
.type
== BT_INTEGER
3840 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3843 if (lvalue
->ts
.type
== BT_REAL
3844 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3847 gfc_error ("BOZ literal constant near %L cannot be assigned to a "
3848 "%qs variable", &rvalue
->where
, gfc_typename (lvalue
));
3852 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3854 gfc_error ("The assignment to a KIND or LEN component of a "
3855 "parameterized type at %L is not allowed",
3860 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3863 /* Only DATA Statements come here. */
3868 /* Numeric can be converted to any other numeric. And Hollerith can be
3869 converted to any other type. */
3870 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3871 || rvalue
->ts
.type
== BT_HOLLERITH
)
3874 if (flag_dec_char_conversions
&& (gfc_numeric_ts (&lvalue
->ts
)
3875 || lvalue
->ts
.type
== BT_LOGICAL
)
3876 && rvalue
->ts
.type
== BT_CHARACTER
3877 && rvalue
->ts
.kind
== gfc_default_character_kind
)
3880 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3883 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3884 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3885 "conversion of %s to %s", where
,
3886 gfc_typename (rvalue
), gfc_typename (lvalue
));
3891 /* Assignment is the only case where character variables of different
3892 kind values can be converted into one another. */
3893 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3895 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3896 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3904 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3908 /* Check that a pointer assignment is OK. We first check lvalue, and
3909 we only check rvalue if it's not an assignment to NULL() or a
3910 NULLIFY statement. */
3913 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
3914 bool suppress_type_test
, bool is_init_expr
)
3916 symbol_attribute attr
, lhs_attr
;
3918 bool is_pure
, is_implicit_pure
, rank_remap
;
3922 if (!lvalue
->symtree
)
3925 lhs_attr
= gfc_expr_attr (lvalue
);
3926 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3928 gfc_error ("Pointer assignment target is not a POINTER at %L",
3933 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3934 && !lhs_attr
.proc_pointer
)
3936 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3937 "l-value since it is a procedure",
3938 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3942 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3945 same_rank
= lvalue
->rank
== rvalue
->rank
;
3946 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3948 if (ref
->type
== REF_COMPONENT
)
3949 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3951 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3955 if (ref
->u
.ar
.type
== AR_FULL
)
3958 if (ref
->u
.ar
.type
!= AR_SECTION
)
3960 gfc_error ("Expected bounds specification for %qs at %L",
3961 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3965 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3966 "for %qs in pointer assignment at %L",
3967 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3970 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3972 * (C1017) If bounds-spec-list is specified, the number of
3973 * bounds-specs shall equal the rank of data-pointer-object.
3975 * If bounds-spec-list appears, it specifies the lower bounds.
3977 * (C1018) If bounds-remapping-list is specified, the number of
3978 * bounds-remappings shall equal the rank of data-pointer-object.
3980 * If bounds-remapping-list appears, it specifies the upper and
3981 * lower bounds of each dimension of the pointer; the pointer target
3982 * shall be simply contiguous or of rank one.
3984 * (C1019) If bounds-remapping-list is not specified, the ranks of
3985 * data-pointer-object and data-target shall be the same.
3987 * Thus when bounds are given, all lbounds are necessary and either
3988 * all or none of the upper bounds; no strides are allowed. If the
3989 * upper bounds are present, we may do rank remapping. */
3990 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3992 if (ref
->u
.ar
.stride
[dim
])
3994 gfc_error ("Stride must not be present at %L",
3998 if (!same_rank
&& (!ref
->u
.ar
.start
[dim
] ||!ref
->u
.ar
.end
[dim
]))
4000 gfc_error ("Rank remapping requires a "
4001 "list of %<lower-bound : upper-bound%> "
4002 "specifications at %L", &lvalue
->where
);
4005 if (!ref
->u
.ar
.start
[dim
]
4006 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
4008 gfc_error ("Expected list of %<lower-bound :%> or "
4009 "list of %<lower-bound : upper-bound%> "
4010 "specifications at %L", &lvalue
->where
);
4015 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
4018 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
]))
4020 gfc_error ("Rank remapping requires a "
4021 "list of %<lower-bound : upper-bound%> "
4022 "specifications at %L", &lvalue
->where
);
4025 if (!rank_remap
&& ref
->u
.ar
.end
[dim
])
4027 gfc_error ("Expected list of %<lower-bound :%> or "
4028 "list of %<lower-bound : upper-bound%> "
4029 "specifications at %L", &lvalue
->where
);
4037 is_pure
= gfc_pure (NULL
);
4038 is_implicit_pure
= gfc_implicit_pure (NULL
);
4040 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
4041 kind, etc for lvalue and rvalue must match, and rvalue must be a
4042 pure variable if we're in a pure function. */
4043 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
4046 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
4047 if (lvalue
->expr_type
== EXPR_VARIABLE
4048 && gfc_is_coindexed (lvalue
))
4051 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
4052 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4054 gfc_error ("Pointer object at %L shall not have a coindex",
4060 /* Checks on rvalue for procedure pointer assignments. */
4065 gfc_component
*comp1
, *comp2
;
4068 attr
= gfc_expr_attr (rvalue
);
4069 if (!((rvalue
->expr_type
== EXPR_NULL
)
4070 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
4071 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
4072 || (rvalue
->expr_type
== EXPR_VARIABLE
4073 && attr
.flavor
== FL_PROCEDURE
)))
4075 gfc_error ("Invalid procedure pointer assignment at %L",
4080 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
4082 /* Check for intrinsics. */
4083 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
4084 if (!sym
->attr
.intrinsic
4085 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
4086 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
4088 sym
->attr
.intrinsic
= 1;
4089 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
4090 attr
= gfc_expr_attr (rvalue
);
4092 /* Check for result of embracing function. */
4093 if (sym
->attr
.function
&& sym
->result
== sym
)
4097 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4098 if (sym
== ns
->proc_name
)
4100 gfc_error ("Function result %qs is invalid as proc-target "
4101 "in procedure pointer assignment at %L",
4102 sym
->name
, &rvalue
->where
);
4109 gfc_error ("Abstract interface %qs is invalid "
4110 "in procedure pointer assignment at %L",
4111 rvalue
->symtree
->name
, &rvalue
->where
);
4114 /* Check for F08:C729. */
4115 if (attr
.flavor
== FL_PROCEDURE
)
4117 if (attr
.proc
== PROC_ST_FUNCTION
)
4119 gfc_error ("Statement function %qs is invalid "
4120 "in procedure pointer assignment at %L",
4121 rvalue
->symtree
->name
, &rvalue
->where
);
4124 if (attr
.proc
== PROC_INTERNAL
&&
4125 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
4126 "is invalid in procedure pointer assignment "
4127 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
4129 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
4130 attr
.subroutine
) == 0)
4132 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
4133 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
4137 /* Check for F08:C730. */
4138 if (attr
.elemental
&& !attr
.intrinsic
)
4140 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
4141 "in procedure pointer assignment at %L",
4142 rvalue
->symtree
->name
, &rvalue
->where
);
4146 /* Ensure that the calling convention is the same. As other attributes
4147 such as DLLEXPORT may differ, one explicitly only tests for the
4148 calling conventions. */
4149 if (rvalue
->expr_type
== EXPR_VARIABLE
4150 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
4151 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4153 symbol_attribute calls
;
4156 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
4157 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
4158 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
4160 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4161 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
4163 gfc_error ("Mismatch in the procedure pointer assignment "
4164 "at %L: mismatch in the calling convention",
4170 comp1
= gfc_get_proc_ptr_comp (lvalue
);
4172 s1
= comp1
->ts
.interface
;
4175 s1
= lvalue
->symtree
->n
.sym
;
4176 if (s1
->ts
.interface
)
4177 s1
= s1
->ts
.interface
;
4180 comp2
= gfc_get_proc_ptr_comp (rvalue
);
4183 if (rvalue
->expr_type
== EXPR_FUNCTION
)
4185 s2
= comp2
->ts
.interface
->result
;
4190 s2
= comp2
->ts
.interface
;
4194 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
4196 if (rvalue
->value
.function
.esym
)
4197 s2
= rvalue
->value
.function
.esym
->result
;
4199 s2
= rvalue
->symtree
->n
.sym
->result
;
4205 s2
= rvalue
->symtree
->n
.sym
;
4209 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
4210 s2
= s2
->ts
.interface
;
4212 /* Special check for the case of absent interface on the lvalue.
4213 * All other interface checks are done below. */
4214 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
4216 gfc_error ("Interface mismatch in procedure pointer assignment "
4217 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
4221 /* F08:7.2.2.4 (4) */
4222 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
4226 gfc_error ("Explicit interface required for component %qs at %L: %s",
4227 comp1
->name
, &lvalue
->where
, err
);
4230 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
4232 gfc_error ("Explicit interface required for %qs at %L: %s",
4233 s1
->name
, &lvalue
->where
, err
);
4237 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
4241 gfc_error ("Explicit interface required for component %qs at %L: %s",
4242 comp2
->name
, &rvalue
->where
, err
);
4245 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
4247 gfc_error ("Explicit interface required for %qs at %L: %s",
4248 s2
->name
, &rvalue
->where
, err
);
4253 if (s1
== s2
|| !s1
|| !s2
)
4256 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
4257 err
, sizeof(err
), NULL
, NULL
))
4259 gfc_error ("Interface mismatch in procedure pointer assignment "
4260 "at %L: %s", &rvalue
->where
, err
);
4264 /* Check F2008Cor2, C729. */
4265 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4266 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4268 gfc_error ("Procedure pointer target %qs at %L must be either an "
4269 "intrinsic, host or use associated, referenced or have "
4270 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4278 /* A non-proc pointer cannot point to a constant. */
4279 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4281 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4287 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4289 /* Check for F03:C717. */
4290 if (UNLIMITED_POLY (rvalue
)
4291 && !(UNLIMITED_POLY (lvalue
)
4292 || (lvalue
->ts
.type
== BT_DERIVED
4293 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4294 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4295 gfc_error ("Data-pointer-object at %L must be unlimited "
4296 "polymorphic, or of a type with the BIND or SEQUENCE "
4297 "attribute, to be compatible with an unlimited "
4298 "polymorphic target", &lvalue
->where
);
4299 else if (!suppress_type_test
)
4300 gfc_error ("Different types in pointer assignment at %L; "
4301 "attempted assignment of %s to %s", &lvalue
->where
,
4302 gfc_typename (rvalue
), gfc_typename (lvalue
));
4306 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4308 gfc_error ("Different kind type parameters in pointer "
4309 "assignment at %L", &lvalue
->where
);
4313 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4315 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4319 /* Make sure the vtab is present. */
4320 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4321 gfc_find_vtab (&rvalue
->ts
);
4323 /* Check rank remapping. */
4328 /* If this can be determined, check that the target must be at least as
4329 large as the pointer assigned to it is. */
4330 if (gfc_array_size (lvalue
, &lsize
)
4331 && gfc_array_size (rvalue
, &rsize
)
4332 && mpz_cmp (rsize
, lsize
) < 0)
4334 gfc_error ("Rank remapping target is smaller than size of the"
4335 " pointer (%ld < %ld) at %L",
4336 mpz_get_si (rsize
), mpz_get_si (lsize
),
4341 /* The target must be either rank one or it must be simply contiguous
4342 and F2008 must be allowed. */
4343 if (rvalue
->rank
!= 1)
4345 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4347 gfc_error ("Rank remapping target must be rank 1 or"
4348 " simply contiguous at %L", &rvalue
->where
);
4351 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4352 "rank 1 at %L", &rvalue
->where
))
4357 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4358 if (rvalue
->expr_type
== EXPR_NULL
)
4361 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4362 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4364 attr
= gfc_expr_attr (rvalue
);
4366 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4368 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4369 to caf_get. Map this to the same error message as below when it is
4370 still a variable expression. */
4371 if (rvalue
->value
.function
.isym
4372 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4373 /* The test above might need to be extend when F08, Note 5.4 has to be
4374 interpreted in the way that target and pointer with the same coindex
4376 gfc_error ("Data target at %L shall not have a coindex",
4379 gfc_error ("Target expression in pointer assignment "
4380 "at %L must deliver a pointer result",
4391 if (gfc_is_size_zero_array (rvalue
))
4393 gfc_error ("Zero-sized array detected at %L where an entity with "
4394 "the TARGET attribute is expected", &rvalue
->where
);
4397 else if (!rvalue
->symtree
)
4399 gfc_error ("Pointer assignment target in initialization expression "
4400 "does not have the TARGET attribute at %L",
4405 sym
= rvalue
->symtree
->n
.sym
;
4407 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4408 target
= CLASS_DATA (sym
)->attr
.target
;
4410 target
= sym
->attr
.target
;
4412 if (!target
&& !proc_pointer
)
4414 gfc_error ("Pointer assignment target in initialization expression "
4415 "does not have the TARGET attribute at %L",
4420 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4425 for (int n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
4426 if (!gfc_is_constant_expr (ref
->u
.ar
.start
[n
])
4427 || !gfc_is_constant_expr (ref
->u
.ar
.end
[n
])
4428 || !gfc_is_constant_expr (ref
->u
.ar
.stride
[n
]))
4430 gfc_error ("Every subscript of target specification "
4431 "at %L must be a constant expression",
4438 if (!gfc_is_constant_expr (ref
->u
.ss
.start
)
4439 || !gfc_is_constant_expr (ref
->u
.ss
.end
))
4441 gfc_error ("Substring starting and ending points of target "
4442 "specification at %L must be constant expressions",
4443 &ref
->u
.ss
.start
->where
);
4455 if (!attr
.target
&& !attr
.pointer
)
4457 gfc_error ("Pointer assignment target is neither TARGET "
4458 "nor POINTER at %L", &rvalue
->where
);
4463 if (lvalue
->ts
.type
== BT_CHARACTER
)
4465 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4470 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4472 gfc_error ("Bad target in pointer assignment in PURE "
4473 "procedure at %L", &rvalue
->where
);
4476 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4477 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4479 if (gfc_has_vector_index (rvalue
))
4481 gfc_error ("Pointer assignment with vector subscript "
4482 "on rhs at %L", &rvalue
->where
);
4486 if (attr
.is_protected
&& attr
.use_assoc
4487 && !(attr
.pointer
|| attr
.proc_pointer
))
4489 gfc_error ("Pointer assignment target has PROTECTED "
4490 "attribute at %L", &rvalue
->where
);
4494 /* F2008, C725. For PURE also C1283. */
4495 if (rvalue
->expr_type
== EXPR_VARIABLE
4496 && gfc_is_coindexed (rvalue
))
4499 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4500 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4502 gfc_error ("Data target at %L shall not have a coindex",
4508 /* Warn for assignments of contiguous pointers to targets which is not
4509 contiguous. Be lenient in the definition of what counts as
4512 if (lhs_attr
.contiguous
4513 && lhs_attr
.dimension
> 0)
4515 if (gfc_is_not_contiguous (rvalue
))
4517 gfc_error ("Assignment to contiguous pointer from "
4518 "non-contiguous target at %L", &rvalue
->where
);
4521 if (!gfc_is_simply_contiguous (rvalue
, false, true))
4522 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4523 "non-contiguous target at %L", &rvalue
->where
);
4526 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4527 if (warn_target_lifetime
4528 && rvalue
->expr_type
== EXPR_VARIABLE
4529 && !rvalue
->symtree
->n
.sym
->attr
.save
4530 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4531 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4532 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4533 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4534 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4539 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4540 || lvalue
->symtree
->n
.sym
->attr
.result
4541 || lvalue
->symtree
->n
.sym
->attr
.function
4542 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4543 && lvalue
->symtree
->n
.sym
->ns
4544 != rvalue
->symtree
->n
.sym
->ns
)
4545 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4546 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4548 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4549 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4550 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4551 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4552 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4554 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4561 gfc_warning (OPT_Wtarget_lifetime
,
4562 "Pointer at %L in pointer assignment might outlive the "
4563 "pointer target", &lvalue
->where
);
4570 /* Relative of gfc_check_assign() except that the lvalue is a single
4571 symbol. Used for initialization assignments. */
4574 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4578 bool pointer
, proc_pointer
;
4580 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4582 lvalue
.expr_type
= EXPR_VARIABLE
;
4583 lvalue
.ts
= sym
->ts
;
4585 lvalue
.rank
= sym
->as
->rank
;
4586 lvalue
.symtree
= XCNEW (gfc_symtree
);
4587 lvalue
.symtree
->n
.sym
= sym
;
4588 lvalue
.where
= sym
->declared_at
;
4592 lvalue
.ref
= gfc_get_ref ();
4593 lvalue
.ref
->type
= REF_COMPONENT
;
4594 lvalue
.ref
->u
.c
.component
= comp
;
4595 lvalue
.ref
->u
.c
.sym
= sym
;
4596 lvalue
.ts
= comp
->ts
;
4597 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4598 lvalue
.where
= comp
->loc
;
4599 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4600 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4601 proc_pointer
= comp
->attr
.proc_pointer
;
4605 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4606 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4607 proc_pointer
= sym
->attr
.proc_pointer
;
4610 if (pointer
|| proc_pointer
)
4611 r
= gfc_check_pointer_assign (&lvalue
, rvalue
, false, true);
4614 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4615 into an array constructor, we should check if it can be reduced
4616 as an initialization expression. */
4617 if (rvalue
->expr_type
== EXPR_FUNCTION
4618 && rvalue
->value
.function
.isym
4619 && (rvalue
->value
.function
.isym
->conversion
== 1))
4620 gfc_check_init_expr (rvalue
);
4622 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4625 free (lvalue
.symtree
);
4631 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
&& !proc_pointer
)
4633 /* F08:C461. Additional checks for pointer initialization. */
4634 symbol_attribute attr
;
4635 attr
= gfc_expr_attr (rvalue
);
4636 if (attr
.allocatable
)
4638 gfc_error ("Pointer initialization target at %L "
4639 "must not be ALLOCATABLE", &rvalue
->where
);
4642 if (!attr
.target
|| attr
.pointer
)
4644 gfc_error ("Pointer initialization target at %L "
4645 "must have the TARGET attribute", &rvalue
->where
);
4649 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4650 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4651 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4653 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4654 attr
.save
= SAVE_IMPLICIT
;
4659 gfc_error ("Pointer initialization target at %L "
4660 "must have the SAVE attribute", &rvalue
->where
);
4665 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4667 /* F08:C1220. Additional checks for procedure pointer initialization. */
4668 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4669 if (attr
.proc_pointer
)
4671 gfc_error ("Procedure pointer initialization target at %L "
4672 "may not be a procedure pointer", &rvalue
->where
);
4675 if (attr
.proc
== PROC_INTERNAL
)
4677 gfc_error ("Internal procedure %qs is invalid in "
4678 "procedure pointer initialization at %L",
4679 rvalue
->symtree
->name
, &rvalue
->where
);
4684 gfc_error ("Dummy procedure %qs is invalid in "
4685 "procedure pointer initialization at %L",
4686 rvalue
->symtree
->name
, &rvalue
->where
);
4694 /* Build an initializer for a local integer, real, complex, logical, or
4695 character variable, based on the command line flags finit-local-zero,
4696 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4697 With force, an initializer is ALWAYS generated. */
4700 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4702 gfc_expr
*init_expr
;
4704 /* Try to build an initializer expression. */
4705 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4707 /* If we want to force generation, make sure we default to zero. */
4708 gfc_init_local_real init_real
= flag_init_real
;
4709 int init_logical
= gfc_option
.flag_init_logical
;
4712 if (init_real
== GFC_INIT_REAL_OFF
)
4713 init_real
= GFC_INIT_REAL_ZERO
;
4714 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4715 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4718 /* We will only initialize integers, reals, complex, logicals, and
4719 characters, and only if the corresponding command-line flags
4720 were set. Otherwise, we free init_expr and return null. */
4724 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4725 mpz_set_si (init_expr
->value
.integer
,
4726 gfc_option
.flag_init_integer_value
);
4729 gfc_free_expr (init_expr
);
4737 case GFC_INIT_REAL_SNAN
:
4738 init_expr
->is_snan
= 1;
4740 case GFC_INIT_REAL_NAN
:
4741 mpfr_set_nan (init_expr
->value
.real
);
4744 case GFC_INIT_REAL_INF
:
4745 mpfr_set_inf (init_expr
->value
.real
, 1);
4748 case GFC_INIT_REAL_NEG_INF
:
4749 mpfr_set_inf (init_expr
->value
.real
, -1);
4752 case GFC_INIT_REAL_ZERO
:
4753 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4757 gfc_free_expr (init_expr
);
4766 case GFC_INIT_REAL_SNAN
:
4767 init_expr
->is_snan
= 1;
4769 case GFC_INIT_REAL_NAN
:
4770 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4771 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4774 case GFC_INIT_REAL_INF
:
4775 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4776 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4779 case GFC_INIT_REAL_NEG_INF
:
4780 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4781 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4784 case GFC_INIT_REAL_ZERO
:
4785 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4789 gfc_free_expr (init_expr
);
4796 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4797 init_expr
->value
.logical
= 0;
4798 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4799 init_expr
->value
.logical
= 1;
4802 gfc_free_expr (init_expr
);
4808 /* For characters, the length must be constant in order to
4809 create a default initializer. */
4810 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4812 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4814 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4815 init_expr
->value
.character
.length
= char_len
;
4816 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4817 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4818 init_expr
->value
.character
.string
[i
]
4819 = (unsigned char) gfc_option
.flag_init_character_value
;
4823 gfc_free_expr (init_expr
);
4827 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4828 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4830 gfc_actual_arglist
*arg
;
4831 init_expr
= gfc_get_expr ();
4832 init_expr
->where
= *where
;
4833 init_expr
->ts
= *ts
;
4834 init_expr
->expr_type
= EXPR_FUNCTION
;
4835 init_expr
->value
.function
.isym
=
4836 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4837 init_expr
->value
.function
.name
= "repeat";
4838 arg
= gfc_get_actual_arglist ();
4839 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4840 arg
->expr
->value
.character
.string
[0] =
4841 gfc_option
.flag_init_character_value
;
4842 arg
->next
= gfc_get_actual_arglist ();
4843 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4844 init_expr
->value
.function
.actual
= arg
;
4849 gfc_free_expr (init_expr
);
4856 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4857 * require that an expression be built. */
4860 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4862 return gfc_build_init_expr (ts
, where
, false);
4865 /* Apply an initialization expression to a typespec. Can be used for symbols or
4866 components. Similar to add_init_expr_to_sym in decl.cc; could probably be
4867 combined with some effort. */
4870 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4872 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4875 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4876 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4878 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4880 if (init
->expr_type
== EXPR_CONSTANT
)
4881 gfc_set_constant_character_len (len
, init
, -1);
4883 && init
->ts
.type
== BT_CHARACTER
4884 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4885 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4886 init
->ts
.u
.cl
->length
->value
.integer
))
4888 gfc_constructor
*ctor
;
4889 ctor
= gfc_constructor_first (init
->value
.constructor
);
4893 bool has_ts
= (init
->ts
.u
.cl
4894 && init
->ts
.u
.cl
->length_from_typespec
);
4896 /* Remember the length of the first element for checking
4897 that all elements *in the constructor* have the same
4898 length. This need not be the length of the LHS! */
4899 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4900 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4901 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4903 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4904 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4906 gfc_set_constant_character_len (len
, ctor
->expr
,
4907 has_ts
? -1 : first_len
);
4908 if (!ctor
->expr
->ts
.u
.cl
)
4910 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4912 ctor
->expr
->ts
.u
.cl
->length
4913 = gfc_copy_expr (ts
->u
.cl
->length
);
4921 /* Check whether an expression is a structure constructor and whether it has
4922 other values than NULL. */
4925 is_non_empty_structure_constructor (gfc_expr
* e
)
4927 if (e
->expr_type
!= EXPR_STRUCTURE
)
4930 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4933 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4935 cons
= gfc_constructor_next (cons
);
4941 /* Check for default initializer; sym->value is not enough
4942 as it is also set for EXPR_NULL of allocatables. */
4945 gfc_has_default_initializer (gfc_symbol
*der
)
4949 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4950 for (c
= der
->components
; c
; c
= c
->next
)
4951 if (gfc_bt_struct (c
->ts
.type
))
4953 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4954 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4956 && is_non_empty_structure_constructor (c
->initializer
))
4957 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4959 if (c
->attr
.pointer
&& c
->initializer
)
4973 Generate an initializer expression which initializes the entirety of a union.
4974 A normal structure constructor is insufficient without undue effort, because
4975 components of maps may be oddly aligned/overlapped. (For example if a
4976 character is initialized from one map overtop a real from the other, only one
4977 byte of the real is actually initialized.) Unfortunately we don't know the
4978 size of the union right now, so we can't generate a proper initializer, but
4979 we use a NULL expr as a placeholder and do the right thing later in
4980 gfc_trans_subcomponent_assign.
4983 generate_union_initializer (gfc_component
*un
)
4985 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4988 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4989 placeholder
->ts
= un
->ts
;
4994 /* Get the user-specified initializer for a union, if any. This means the user
4995 has said to initialize component(s) of a map. For simplicity's sake we
4996 only allow the user to initialize the first map. We don't have to worry
4997 about overlapping initializers as they are released early in resolution (see
4998 resolve_fl_struct). */
5001 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
5004 gfc_expr
*init
=NULL
;
5006 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
5009 for (map
= union_type
->components
; map
; map
= map
->next
)
5011 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
5013 init
= gfc_default_initializer (&map
->ts
);
5027 class_allocatable (gfc_component
*comp
)
5029 return comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
&& CLASS_DATA (comp
)
5030 && CLASS_DATA (comp
)->attr
.allocatable
;
5034 class_pointer (gfc_component
*comp
)
5036 return comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
&& CLASS_DATA (comp
)
5037 && CLASS_DATA (comp
)->attr
.pointer
;
5041 comp_allocatable (gfc_component
*comp
)
5043 return comp
->attr
.allocatable
|| class_allocatable (comp
);
5047 comp_pointer (gfc_component
*comp
)
5049 return comp
->attr
.pointer
5050 || comp
->attr
.proc_pointer
5051 || comp
->attr
.class_pointer
5052 || class_pointer (comp
);
5055 /* Fetch or generate an initializer for the given component.
5056 Only generate an initializer if generate is true. */
5059 component_initializer (gfc_component
*c
, bool generate
)
5061 gfc_expr
*init
= NULL
;
5063 /* Allocatable components always get EXPR_NULL.
5064 Pointer components are only initialized when generating, and only if they
5065 do not already have an initializer. */
5066 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
5068 init
= gfc_get_null_expr (&c
->loc
);
5073 /* See if we can find the initializer immediately. */
5074 if (c
->initializer
|| !generate
)
5075 return c
->initializer
;
5077 /* Recursively handle derived type components. */
5078 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
5079 init
= gfc_generate_initializer (&c
->ts
, true);
5081 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
5083 gfc_component
*map
= NULL
;
5084 gfc_constructor
*ctor
;
5085 gfc_expr
*user_init
;
5087 /* If we don't have a user initializer and we aren't generating one, this
5088 union has no initializer. */
5089 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
5090 if (!user_init
&& !generate
)
5093 /* Otherwise use a structure constructor. */
5094 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
5098 /* If we are to generate an initializer for the union, add a constructor
5099 which initializes the whole union first. */
5102 ctor
= gfc_constructor_get ();
5103 ctor
->expr
= generate_union_initializer (c
);
5104 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5107 /* If we found an initializer in one of our maps, apply it. Note this
5108 is applied _after_ the entire-union initializer above if any. */
5111 ctor
= gfc_constructor_get ();
5112 ctor
->expr
= user_init
;
5113 ctor
->n
.component
= map
;
5114 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5118 /* Treat simple components like locals. */
5121 /* We MUST give an initializer, so force generation. */
5122 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
5123 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
5130 /* Get an expression for a default initializer of a derived type. */
5133 gfc_default_initializer (gfc_typespec
*ts
)
5135 return gfc_generate_initializer (ts
, false);
5138 /* Generate an initializer expression for an iso_c_binding type
5139 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
5142 generate_isocbinding_initializer (gfc_symbol
*derived
)
5144 /* The initializers have already been built into the c_null_[fun]ptr symbols
5145 from gen_special_c_interop_ptr. */
5146 gfc_symtree
*npsym
= NULL
;
5147 if (0 == strcmp (derived
->name
, "c_ptr"))
5148 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
5149 else if (0 == strcmp (derived
->name
, "c_funptr"))
5150 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
5152 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
5153 " type, expected %<c_ptr%> or %<c_funptr%>");
5156 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
5157 init
->symtree
= npsym
;
5158 init
->ts
.is_iso_c
= true;
5165 /* Get or generate an expression for a default initializer of a derived type.
5166 If -finit-derived is specified, generate default initialization expressions
5167 for components that lack them when generate is set. */
5170 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
5172 gfc_expr
*init
, *tmp
;
5173 gfc_component
*comp
;
5175 generate
= flag_init_derived
&& generate
;
5177 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
5178 return generate_isocbinding_initializer (ts
->u
.derived
);
5180 /* See if we have a default initializer in this, but not in nested
5181 types (otherwise we could use gfc_has_default_initializer()).
5182 We don't need to check if we are going to generate them. */
5183 comp
= ts
->u
.derived
->components
;
5186 for (; comp
; comp
= comp
->next
)
5187 if (comp
->initializer
|| comp_allocatable (comp
))
5194 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
5195 &ts
->u
.derived
->declared_at
);
5198 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
5200 gfc_constructor
*ctor
= gfc_constructor_get();
5202 /* Fetch or generate an initializer for the component. */
5203 tmp
= component_initializer (comp
, generate
);
5206 /* Save the component ref for STRUCTUREs and UNIONs. */
5207 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
5208 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
5209 ctor
->n
.component
= comp
;
5211 /* If the initializer was not generated, we need a copy. */
5212 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
5213 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
5214 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
5217 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
5223 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5230 /* Given a symbol, create an expression node with that symbol as a
5231 variable. If the symbol is array valued, setup a reference of the
5235 gfc_get_variable_expr (gfc_symtree
*var
)
5239 e
= gfc_get_expr ();
5240 e
->expr_type
= EXPR_VARIABLE
;
5242 e
->ts
= var
->n
.sym
->ts
;
5244 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
5245 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
5246 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& var
->n
.sym
->ts
.u
.derived
5247 && CLASS_DATA (var
->n
.sym
)
5248 && CLASS_DATA (var
->n
.sym
)->as
)))
5250 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
5251 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
5252 e
->ref
= gfc_get_ref ();
5253 e
->ref
->type
= REF_ARRAY
;
5254 e
->ref
->u
.ar
.type
= AR_FULL
;
5255 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
5256 ? CLASS_DATA (var
->n
.sym
)->as
5264 /* Adds a full array reference to an expression, as needed. */
5267 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
5270 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5275 ref
->next
= gfc_get_ref ();
5280 e
->ref
= gfc_get_ref ();
5283 ref
->type
= REF_ARRAY
;
5284 ref
->u
.ar
.type
= AR_FULL
;
5285 ref
->u
.ar
.dimen
= e
->rank
;
5286 ref
->u
.ar
.where
= e
->where
;
5292 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
5296 lval
= gfc_get_expr ();
5297 lval
->expr_type
= EXPR_VARIABLE
;
5298 lval
->where
= sym
->declared_at
;
5300 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5302 /* It will always be a full array. */
5303 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5304 lval
->rank
= as
? as
->rank
: 0;
5306 gfc_add_full_array_ref (lval
, as
);
5311 /* Returns the array_spec of a full array expression. A NULL is
5312 returned otherwise. */
5314 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
5319 if (expr
->rank
== 0)
5322 /* Follow any component references. */
5323 if (expr
->expr_type
== EXPR_VARIABLE
5324 || expr
->expr_type
== EXPR_CONSTANT
)
5327 as
= expr
->symtree
->n
.sym
->as
;
5331 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5336 as
= ref
->u
.c
.component
->as
;
5345 switch (ref
->u
.ar
.type
)
5368 /* General expression traversal function. */
5371 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5372 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5377 gfc_actual_arglist
*args
;
5384 if ((*func
) (expr
, sym
, &f
))
5387 if (expr
->ts
.type
== BT_CHARACTER
5389 && expr
->ts
.u
.cl
->length
5390 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5391 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5394 switch (expr
->expr_type
)
5399 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5401 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5409 case EXPR_SUBSTRING
:
5412 case EXPR_STRUCTURE
:
5414 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5415 c
; c
= gfc_constructor_next (c
))
5417 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5421 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5423 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5425 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5427 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5434 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5436 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5452 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5454 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5456 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5458 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5464 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5466 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5471 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5472 && ref
->u
.c
.component
->ts
.u
.cl
5473 && ref
->u
.c
.component
->ts
.u
.cl
->length
5474 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5476 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5480 if (ref
->u
.c
.component
->as
)
5481 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5482 + ref
->u
.c
.component
->as
->corank
; i
++)
5484 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5487 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5504 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5507 expr_set_symbols_referenced (gfc_expr
*expr
,
5508 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5509 int *f ATTRIBUTE_UNUSED
)
5511 if (expr
->expr_type
!= EXPR_VARIABLE
)
5513 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5518 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5520 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5524 /* Determine if an expression is a procedure pointer component and return
5525 the component in that case. Otherwise return NULL. */
5528 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5532 if (!expr
|| !expr
->ref
)
5539 if (ref
->type
== REF_COMPONENT
5540 && ref
->u
.c
.component
->attr
.proc_pointer
)
5541 return ref
->u
.c
.component
;
5547 /* Determine if an expression is a procedure pointer component. */
5550 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5552 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5556 /* Determine if an expression is a function with an allocatable class scalar
5559 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5561 if (expr
->expr_type
== EXPR_FUNCTION
5562 && expr
->value
.function
.esym
5563 && expr
->value
.function
.esym
->result
5564 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5565 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5566 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5573 /* Determine if an expression is a function with an allocatable class array
5576 gfc_is_class_array_function (gfc_expr
*expr
)
5578 if (expr
->expr_type
== EXPR_FUNCTION
5579 && expr
->value
.function
.esym
5580 && expr
->value
.function
.esym
->result
5581 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5582 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5583 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5584 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5591 /* Walk an expression tree and check each variable encountered for being typed.
5592 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5593 mode as is a basic arithmetic expression using those; this is for things in
5596 INTEGER :: arr(n), n
5597 INTEGER :: arr(n + 1), n
5599 The namespace is needed for IMPLICIT typing. */
5601 static gfc_namespace
* check_typed_ns
;
5604 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5605 int* f ATTRIBUTE_UNUSED
)
5609 if (e
->expr_type
!= EXPR_VARIABLE
)
5612 gcc_assert (e
->symtree
);
5613 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5620 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5624 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5628 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5629 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5631 if (e
->expr_type
== EXPR_OP
)
5635 gcc_assert (e
->value
.op
.op1
);
5636 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5638 if (t
&& e
->value
.op
.op2
)
5639 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5645 /* Otherwise, walk the expression and do it strictly. */
5646 check_typed_ns
= ns
;
5647 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5649 return error_found
? false : true;
5653 /* This function returns true if it contains any references to PDT KIND
5654 or LEN parameters. */
5657 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5658 int* f ATTRIBUTE_UNUSED
)
5660 if (e
->expr_type
!= EXPR_VARIABLE
)
5663 gcc_assert (e
->symtree
);
5664 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5665 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5673 gfc_derived_parameter_expr (gfc_expr
*e
)
5675 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5679 /* This function returns the overall type of a type parameter spec list.
5680 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5681 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5682 unless derived is not NULL. In this latter case, all the LEN parameters
5683 must be either assumed or deferred for the return argument to be set to
5684 anything other than SPEC_EXPLICIT. */
5687 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5689 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5691 bool seen_assumed
= false;
5692 bool seen_deferred
= false;
5694 if (derived
== NULL
)
5696 for (; param_list
; param_list
= param_list
->next
)
5697 if (param_list
->spec_type
== SPEC_ASSUMED
5698 || param_list
->spec_type
== SPEC_DEFERRED
)
5699 return param_list
->spec_type
;
5703 for (; param_list
; param_list
= param_list
->next
)
5705 c
= gfc_find_component (derived
, param_list
->name
,
5707 gcc_assert (c
!= NULL
);
5708 if (c
->attr
.pdt_kind
)
5710 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5711 return SPEC_EXPLICIT
;
5712 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5713 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5714 if (seen_assumed
&& seen_deferred
)
5715 return SPEC_EXPLICIT
;
5717 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5724 gfc_ref_this_image (gfc_ref
*ref
)
5728 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5730 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5731 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5738 gfc_find_team_co (gfc_expr
*e
)
5742 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5743 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5744 return ref
->u
.ar
.team
;
5746 if (e
->value
.function
.actual
->expr
)
5747 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5749 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5750 return ref
->u
.ar
.team
;
5756 gfc_find_stat_co (gfc_expr
*e
)
5760 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5761 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5762 return ref
->u
.ar
.stat
;
5764 if (e
->value
.function
.actual
->expr
)
5765 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5767 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5768 return ref
->u
.ar
.stat
;
5774 gfc_is_coindexed (gfc_expr
*e
)
5778 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5779 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5780 return !gfc_ref_this_image (ref
);
5786 /* Coarrays are variables with a corank but not being coindexed. However, also
5787 the following is a coarray: A subobject of a coarray is a coarray if it does
5788 not have any cosubscripts, vector subscripts, allocatable component
5789 selection, or pointer component selection. (F2008, 2.4.7) */
5792 gfc_is_coarray (gfc_expr
*e
)
5796 gfc_component
*comp
;
5801 if (e
->expr_type
!= EXPR_VARIABLE
)
5805 sym
= e
->symtree
->n
.sym
;
5807 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5808 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5810 coarray
= sym
->attr
.codimension
;
5812 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5816 comp
= ref
->u
.c
.component
;
5817 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5818 && (CLASS_DATA (comp
)->attr
.class_pointer
5819 || CLASS_DATA (comp
)->attr
.allocatable
))
5822 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5824 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5827 coarray
= comp
->attr
.codimension
;
5835 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5841 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5842 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5854 return coarray
&& !coindexed
;
5859 gfc_get_corank (gfc_expr
*e
)
5864 if (!gfc_is_coarray (e
))
5867 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
))
5868 corank
= CLASS_DATA (e
)->as
5869 ? CLASS_DATA (e
)->as
->corank
: 0;
5871 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5873 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5875 if (ref
->type
== REF_ARRAY
)
5876 corank
= ref
->u
.ar
.as
->corank
;
5877 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5884 /* Check whether the expression has an ultimate allocatable component.
5885 Being itself allocatable does not count. */
5887 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5889 gfc_ref
*ref
, *last
= NULL
;
5891 if (e
->expr_type
!= EXPR_VARIABLE
)
5894 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5895 if (ref
->type
== REF_COMPONENT
)
5898 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5899 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5900 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5901 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5905 if (e
->ts
.type
== BT_CLASS
)
5906 return CLASS_DATA (e
)->attr
.alloc_comp
;
5907 else if (e
->ts
.type
== BT_DERIVED
)
5908 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5914 /* Check whether the expression has an pointer component.
5915 Being itself a pointer does not count. */
5917 gfc_has_ultimate_pointer (gfc_expr
*e
)
5919 gfc_ref
*ref
, *last
= NULL
;
5921 if (e
->expr_type
!= EXPR_VARIABLE
)
5924 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5925 if (ref
->type
== REF_COMPONENT
)
5928 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5929 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5930 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5931 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5935 if (e
->ts
.type
== BT_CLASS
)
5936 return CLASS_DATA (e
)->attr
.pointer_comp
;
5937 else if (e
->ts
.type
== BT_DERIVED
)
5938 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5944 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5945 Note: A scalar is not regarded as "simply contiguous" by the standard.
5946 if bool is not strict, some further checks are done - for instance,
5947 a "(::1)" is accepted. */
5950 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5954 gfc_array_ref
*ar
= NULL
;
5955 gfc_ref
*ref
, *part_ref
= NULL
;
5958 if (expr
->expr_type
== EXPR_ARRAY
)
5961 if (expr
->expr_type
== EXPR_FUNCTION
)
5963 if (expr
->value
.function
.isym
)
5964 /* TRANSPOSE is the only intrinsic that may return a
5965 non-contiguous array. It's treated as a special case in
5966 gfc_conv_expr_descriptor too. */
5967 return (expr
->value
.function
.isym
->id
!= GFC_ISYM_TRANSPOSE
);
5968 else if (expr
->value
.function
.esym
)
5969 /* Only a pointer to an array without the contiguous attribute
5970 can be non-contiguous as a result value. */
5971 return (expr
->value
.function
.esym
->result
->attr
.contiguous
5972 || !expr
->value
.function
.esym
->result
->attr
.pointer
);
5975 /* Type-bound procedures. */
5976 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5977 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5981 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5982 if (r
->type
== REF_COMPONENT
)
5985 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5986 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5989 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5992 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5995 if (!permit_element
&& expr
->rank
== 0)
5998 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6001 return false; /* Array shall be last part-ref. */
6003 if (ref
->type
== REF_COMPONENT
)
6005 else if (ref
->type
== REF_SUBSTRING
)
6007 else if (ref
->type
== REF_INQUIRY
)
6009 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
6013 sym
= expr
->symtree
->n
.sym
;
6014 if (expr
->ts
.type
!= BT_CLASS
6016 && !part_ref
->u
.c
.component
->attr
.contiguous
6017 && part_ref
->u
.c
.component
->attr
.pointer
)
6019 && !sym
->attr
.contiguous
6020 && (sym
->attr
.pointer
6021 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
6022 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
6025 if (!ar
|| ar
->type
== AR_FULL
)
6028 gcc_assert (ar
->type
== AR_SECTION
);
6030 /* Check for simply contiguous array */
6032 for (i
= 0; i
< ar
->dimen
; i
++)
6034 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
6037 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
6043 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
6046 /* If the previous section was not contiguous, that's an error,
6047 unless we have effective only one element and checking is not
6049 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
6050 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
6051 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
6052 || mpz_cmp (ar
->start
[i
]->value
.integer
,
6053 ar
->end
[i
]->value
.integer
) != 0))
6056 /* Following the standard, "(::1)" or - if known at compile time -
6057 "(lbound:ubound)" are not simply contiguous; if strict
6058 is false, they are regarded as simply contiguous. */
6059 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
6060 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
6061 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
6065 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
6066 || !ar
->as
->lower
[i
]
6067 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
6068 || mpz_cmp (ar
->start
[i
]->value
.integer
,
6069 ar
->as
->lower
[i
]->value
.integer
) != 0))
6073 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
6074 || !ar
->as
->upper
[i
]
6075 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
6076 || mpz_cmp (ar
->end
[i
]->value
.integer
,
6077 ar
->as
->upper
[i
]->value
.integer
) != 0))
6084 /* Return true if the expression is guaranteed to be non-contiguous,
6085 false if we cannot prove anything. It is probably best to call
6086 this after gfc_is_simply_contiguous. If neither of them returns
6087 true, we cannot say (at compile-time). */
6090 gfc_is_not_contiguous (gfc_expr
*array
)
6093 gfc_array_ref
*ar
= NULL
;
6095 bool previous_incomplete
;
6097 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
6099 /* Array-ref shall be last ref. */
6101 if (ar
&& ar
->type
!= AR_ELEMENT
)
6104 if (ref
->type
== REF_ARRAY
)
6108 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
6111 previous_incomplete
= false;
6113 /* Check if we can prove that the array is not contiguous. */
6115 for (i
= 0; i
< ar
->dimen
; i
++)
6117 mpz_t arr_size
, ref_size
;
6119 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
6121 if (gfc_dep_difference (ar
->as
->upper
[i
], ar
->as
->lower
[i
], &arr_size
))
6123 /* a(2:4,2:) is known to be non-contiguous, but
6124 a(2:4,i:i) can be contiguous. */
6125 mpz_add_ui (arr_size
, arr_size
, 1L);
6126 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
6128 mpz_clear (arr_size
);
6129 mpz_clear (ref_size
);
6132 else if (mpz_cmp (arr_size
, ref_size
) != 0)
6133 previous_incomplete
= true;
6135 mpz_clear (arr_size
);
6138 /* Check for a(::2), i.e. where the stride is not unity.
6139 This is only done if there is more than one element in
6140 the reference along this dimension. */
6142 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
6143 && ar
->dimen_type
[i
] == DIMEN_RANGE
6144 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
6145 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
6147 mpz_clear (ref_size
);
6151 mpz_clear (ref_size
);
6154 /* We didn't find anything definitive. */
6158 /* Build call to an intrinsic procedure. The number of arguments has to be
6159 passed (rather than ending the list with a NULL value) because we may
6160 want to add arguments but with a NULL-expression. */
6163 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
6164 locus where
, unsigned numarg
, ...)
6167 gfc_actual_arglist
* atail
;
6168 gfc_intrinsic_sym
* isym
;
6171 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
6173 isym
= gfc_intrinsic_function_by_id (id
);
6176 result
= gfc_get_expr ();
6177 result
->expr_type
= EXPR_FUNCTION
;
6178 result
->ts
= isym
->ts
;
6179 result
->where
= where
;
6180 result
->value
.function
.name
= mangled_name
;
6181 result
->value
.function
.isym
= isym
;
6183 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
6184 gfc_commit_symbol (result
->symtree
->n
.sym
);
6185 gcc_assert (result
->symtree
6186 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
6187 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
6188 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
6189 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
6190 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
6191 result
->symtree
->n
.sym
->attr
.artificial
= 1;
6193 va_start (ap
, numarg
);
6195 for (i
= 0; i
< numarg
; ++i
)
6199 atail
->next
= gfc_get_actual_arglist ();
6200 atail
= atail
->next
;
6203 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
6205 atail
->expr
= va_arg (ap
, gfc_expr
*);
6213 /* Check if an expression may appear in a variable definition context
6214 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
6215 This is called from the various places when resolving
6216 the pieces that make up such a context.
6217 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
6218 variables), some checks are not performed.
6220 Optionally, a possible error message can be suppressed if context is NULL
6221 and just the return status (true / false) be requested. */
6224 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
6225 bool own_scope
, const char* context
)
6227 gfc_symbol
* sym
= NULL
;
6229 bool check_intentin
;
6231 symbol_attribute attr
;
6235 if (e
->expr_type
== EXPR_VARIABLE
)
6237 gcc_assert (e
->symtree
);
6238 sym
= e
->symtree
->n
.sym
;
6240 else if (e
->expr_type
== EXPR_FUNCTION
)
6242 gcc_assert (e
->symtree
);
6243 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
6246 attr
= gfc_expr_attr (e
);
6247 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
6249 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
6252 gfc_error ("Fortran 2008: Pointer functions in variable definition"
6253 " context (%s) at %L", context
, &e
->where
);
6257 else if (e
->expr_type
!= EXPR_VARIABLE
)
6260 gfc_error ("Non-variable expression in variable definition context (%s)"
6261 " at %L", context
, &e
->where
);
6265 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
6268 gfc_error ("Named constant %qs in variable definition context (%s)"
6269 " at %L", sym
->name
, context
, &e
->where
);
6272 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
6273 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
6274 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
)
6275 && !(sym
->attr
.flavor
== FL_PROCEDURE
6276 && sym
->attr
.function
&& attr
.pointer
))
6279 gfc_error ("%qs in variable definition context (%s) at %L is not"
6280 " a variable", sym
->name
, context
, &e
->where
);
6284 /* Find out whether the expr is a pointer; this also means following
6285 component references to the last one. */
6286 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
6287 if (pointer
&& !is_pointer
)
6290 gfc_error ("Non-POINTER in pointer association context (%s)"
6291 " at %L", context
, &e
->where
);
6295 if (e
->ts
.type
== BT_DERIVED
6296 && e
->ts
.u
.derived
== NULL
)
6299 gfc_error ("Type inaccessible in variable definition context (%s) "
6300 "at %L", context
, &e
->where
);
6307 || (e
->ts
.type
== BT_DERIVED
6308 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6309 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
6312 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6313 context
, &e
->where
);
6317 /* TS18508, C702/C203. */
6320 || (e
->ts
.type
== BT_DERIVED
6321 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6322 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
6325 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6326 context
, &e
->where
);
6330 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6331 component of sub-component of a pointer; we need to distinguish
6332 assignment to a pointer component from pointer-assignment to a pointer
6333 component. Note that (normal) assignment to procedure pointers is not
6335 check_intentin
= !own_scope
;
6336 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
6337 && CLASS_DATA (sym
))
6338 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
6339 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
6341 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
6342 check_intentin
= false;
6343 if (ref
->type
== REF_COMPONENT
)
6345 gfc_component
*comp
= ref
->u
.c
.component
;
6346 ptr_component
= (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
)
6347 ? CLASS_DATA (comp
)->attr
.class_pointer
6348 : comp
->attr
.pointer
;
6349 if (ptr_component
&& !pointer
)
6350 check_intentin
= false;
6352 if (ref
->type
== REF_INQUIRY
6353 && (ref
->u
.i
== INQUIRY_KIND
|| ref
->u
.i
== INQUIRY_LEN
))
6356 gfc_error ("%qs parameter inquiry for %qs in "
6357 "variable definition context (%s) at %L",
6358 ref
->u
.i
== INQUIRY_KIND
? "KIND" : "LEN",
6359 sym
->name
, context
, &e
->where
);
6365 && (sym
->attr
.intent
== INTENT_IN
6366 || (sym
->attr
.select_type_temporary
&& sym
->assoc
6367 && sym
->assoc
->target
&& sym
->assoc
->target
->symtree
6368 && sym
->assoc
->target
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)))
6370 if (pointer
&& is_pointer
)
6373 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6374 " association context (%s) at %L",
6375 sym
->name
, context
, &e
->where
);
6378 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
6380 const char *name
= sym
->attr
.select_type_temporary
6381 ? sym
->assoc
->target
->symtree
->name
: sym
->name
;
6383 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6384 " definition context (%s) at %L",
6385 name
, context
, &e
->where
);
6390 /* PROTECTED and use-associated. */
6391 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
6393 if (pointer
&& is_pointer
)
6396 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6397 " pointer association context (%s) at %L",
6398 sym
->name
, context
, &e
->where
);
6401 if (!pointer
&& !is_pointer
)
6404 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6405 " variable definition context (%s) at %L",
6406 sym
->name
, context
, &e
->where
);
6411 /* Variable not assignable from a PURE procedure but appears in
6412 variable definition context. */
6413 own_scope
= own_scope
6414 || (sym
->attr
.result
&& sym
->ns
->proc_name
6415 && sym
== sym
->ns
->proc_name
->result
);
6416 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6419 gfc_error ("Variable %qs cannot appear in a variable definition"
6420 " context (%s) at %L in PURE procedure",
6421 sym
->name
, context
, &e
->where
);
6425 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6426 && gfc_impure_variable (sym
))
6431 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6433 sym
= ns
->proc_name
;
6436 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6438 sym
->attr
.implicit_pure
= 0;
6443 /* Check variable definition context for associate-names. */
6444 if (!pointer
&& sym
->assoc
&& !sym
->attr
.select_rank_temporary
)
6447 gfc_association_list
* assoc
;
6449 gcc_assert (sym
->assoc
->target
);
6451 /* If this is a SELECT TYPE temporary (the association is used internally
6452 for SELECT TYPE), silently go over to the target. */
6453 if (sym
->attr
.select_type_temporary
)
6455 gfc_expr
* t
= sym
->assoc
->target
;
6457 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6458 name
= t
->symtree
->name
;
6460 if (t
->symtree
->n
.sym
->assoc
)
6461 assoc
= t
->symtree
->n
.sym
->assoc
;
6470 gcc_assert (name
&& assoc
);
6472 /* Is association to a valid variable? */
6473 if (!assoc
->variable
)
6477 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6478 gfc_error ("%qs at %L associated to vector-indexed target"
6479 " cannot be used in a variable definition"
6481 name
, &e
->where
, context
);
6483 gfc_error ("%qs at %L associated to expression"
6484 " cannot be used in a variable definition"
6486 name
, &e
->where
, context
);
6490 else if (context
&& gfc_is_ptr_fcn (assoc
->target
))
6492 if (!gfc_notify_std (GFC_STD_F2018
, "%qs at %L associated to "
6493 "pointer function target being used in a "
6494 "variable definition context (%s)", name
,
6495 &e
->where
, context
))
6497 else if (gfc_has_vector_index (e
))
6499 gfc_error ("%qs at %L associated to vector-indexed target"
6500 " cannot be used in a variable definition"
6502 name
, &e
->where
, context
);
6507 /* Target must be allowed to appear in a variable definition context. */
6508 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6511 gfc_error ("Associate-name %qs cannot appear in a variable"
6512 " definition context (%s) at %L because its target"
6513 " at %L cannot, either",
6514 name
, context
, &e
->where
,
6515 &assoc
->target
->where
);
6520 /* Check for same value in vector expression subscript. */
6523 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6524 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6525 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6526 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6527 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6529 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6530 if (arr
->expr_type
== EXPR_ARRAY
)
6532 gfc_constructor
*c
, *n
;
6535 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6536 c
!= NULL
; c
= gfc_constructor_next (c
))
6538 if (c
== NULL
|| c
->iterator
!= NULL
)
6543 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6544 n
= gfc_constructor_next (n
))
6546 if (n
->iterator
!= NULL
)
6550 if (gfc_dep_compare_expr (ec
, en
) == 0)
6553 gfc_error_now ("Elements with the same value "
6554 "at %L and %L in vector "
6555 "subscript in a variable "
6556 "definition context (%s)",
6557 &(ec
->where
), &(en
->where
),
6570 gfc_pdt_find_component_copy_initializer (gfc_symbol
*sym
, const char *name
)
6572 /* The actual length of a pdt is in its components. In the
6573 initializer of the current ref is only the default value.
6574 Therefore traverse the chain of components and pick the correct
6575 one's initializer expressions. */
6576 for (gfc_component
*comp
= sym
->ts
.u
.derived
->components
; comp
!= NULL
;
6579 if (!strcmp (comp
->name
, name
))
6580 return gfc_copy_expr (comp
->initializer
);