1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #include "constructor.h"
33 /* The following set of functions provide access to gfc_expr* of
34 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
36 There are two functions available elsewhere that provide
37 slightly different flavours of variables. Namely:
38 expr.c (gfc_get_variable_expr)
39 symbol.c (gfc_lval_expr_from_sym)
40 TODO: Merge these functions, if possible. */
42 /* Get a new expression node. */
50 gfc_clear_ts (&e
->ts
);
58 /* Get a new expression node that is an array constructor
59 of given type and kind. */
62 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
67 e
->expr_type
= EXPR_ARRAY
;
68 e
->value
.constructor
= NULL
;
81 /* Get a new expression node that is the NULL expression. */
84 gfc_get_null_expr (locus
*where
)
89 e
->expr_type
= EXPR_NULL
;
90 e
->ts
.type
= BT_UNKNOWN
;
99 /* Get a new expression node that is an operator expression node. */
102 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
103 gfc_expr
*op1
, gfc_expr
*op2
)
108 e
->expr_type
= EXPR_OP
;
110 e
->value
.op
.op1
= op1
;
111 e
->value
.op
.op2
= op2
;
120 /* Get a new expression node that is an structure constructor
121 of given type and kind. */
124 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
129 e
->expr_type
= EXPR_STRUCTURE
;
130 e
->value
.constructor
= NULL
;
141 /* Get a new expression node that is an constant of given type and kind. */
144 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
149 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
154 e
->expr_type
= EXPR_CONSTANT
;
162 mpz_init (e
->value
.integer
);
166 gfc_set_model_kind (kind
);
167 mpfr_init (e
->value
.real
);
171 gfc_set_model_kind (kind
);
172 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
183 /* Get a new expression node that is an string constant.
184 If no string is passed, a string of len is allocated,
185 blanked and null-terminated. */
188 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, gfc_charlen_t len
)
195 dest
= gfc_get_wide_string (len
+ 1);
196 gfc_wide_memset (dest
, ' ', len
);
200 dest
= gfc_char_to_widechar (src
);
202 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
203 where
? where
: &gfc_current_locus
);
204 e
->value
.character
.string
= dest
;
205 e
->value
.character
.length
= len
;
211 /* Get a new expression node that is an integer constant. */
214 gfc_get_int_expr (int kind
, locus
*where
, HOST_WIDE_INT value
)
217 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
218 where
? where
: &gfc_current_locus
);
220 const wide_int w
= wi::shwi (value
, kind
* BITS_PER_UNIT
);
221 wi::to_mpz (w
, p
->value
.integer
, SIGNED
);
227 /* Get a new expression node that is a logical constant. */
230 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
233 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
234 where
? where
: &gfc_current_locus
);
236 p
->value
.logical
= value
;
243 gfc_get_iokind_expr (locus
*where
, io_kind k
)
247 /* Set the types to something compatible with iokind. This is needed to
248 get through gfc_free_expr later since iokind really has no Basic Type,
252 e
->expr_type
= EXPR_CONSTANT
;
253 e
->ts
.type
= BT_LOGICAL
;
261 /* Given an expression pointer, return a copy of the expression. This
262 subroutine is recursive. */
265 gfc_copy_expr (gfc_expr
*p
)
277 switch (q
->expr_type
)
280 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
281 q
->value
.character
.string
= s
;
282 memcpy (s
, p
->value
.character
.string
,
283 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
287 /* Copy target representation, if it exists. */
288 if (p
->representation
.string
)
290 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
291 q
->representation
.string
= c
;
292 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
295 /* Copy the values of any pointer components of p->value. */
299 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
303 gfc_set_model_kind (q
->ts
.kind
);
304 mpfr_init (q
->value
.real
);
305 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
309 gfc_set_model_kind (q
->ts
.kind
);
310 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
311 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
315 if (p
->representation
.string
)
316 q
->value
.character
.string
317 = gfc_char_to_widechar (q
->representation
.string
);
320 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
321 q
->value
.character
.string
= s
;
323 /* This is the case for the C_NULL_CHAR named constant. */
324 if (p
->value
.character
.length
== 0
325 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
328 /* Need to set the length to 1 to make sure the NUL
329 terminator is copied. */
330 q
->value
.character
.length
= 1;
333 memcpy (s
, p
->value
.character
.string
,
334 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
343 break; /* Already done. */
346 q
->boz
.len
= p
->boz
.len
;
347 q
->boz
.rdx
= p
->boz
.rdx
;
348 q
->boz
.str
= XCNEWVEC (char, q
->boz
.len
+ 1);
349 strncpy (q
->boz
.str
, p
->boz
.str
, p
->boz
.len
);
354 /* Should never be reached. */
356 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
363 switch (q
->value
.op
.op
)
366 case INTRINSIC_PARENTHESES
:
367 case INTRINSIC_UPLUS
:
368 case INTRINSIC_UMINUS
:
369 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
372 default: /* Binary operators. */
373 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
374 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
381 q
->value
.function
.actual
=
382 gfc_copy_actual_arglist (p
->value
.function
.actual
);
387 q
->value
.compcall
.actual
=
388 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
389 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
394 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
405 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
407 q
->ref
= gfc_copy_ref (p
->ref
);
410 q
->param_list
= gfc_copy_actual_arglist (p
->param_list
);
417 gfc_clear_shape (mpz_t
*shape
, int rank
)
421 for (i
= 0; i
< rank
; i
++)
422 mpz_clear (shape
[i
]);
427 gfc_free_shape (mpz_t
**shape
, int rank
)
432 gfc_clear_shape (*shape
, rank
);
438 /* Workhorse function for gfc_free_expr() that frees everything
439 beneath an expression node, but not the node itself. This is
440 useful when we want to simplify a node and replace it with
441 something else or the expression node belongs to another structure. */
444 free_expr0 (gfc_expr
*e
)
446 switch (e
->expr_type
)
449 /* Free any parts of the value that need freeing. */
453 mpz_clear (e
->value
.integer
);
457 mpfr_clear (e
->value
.real
);
461 free (e
->value
.character
.string
);
465 mpc_clear (e
->value
.complex);
472 /* Free the representation. */
473 free (e
->representation
.string
);
478 if (e
->value
.op
.op1
!= NULL
)
479 gfc_free_expr (e
->value
.op
.op1
);
480 if (e
->value
.op
.op2
!= NULL
)
481 gfc_free_expr (e
->value
.op
.op2
);
485 gfc_free_actual_arglist (e
->value
.function
.actual
);
490 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
498 gfc_constructor_free (e
->value
.constructor
);
502 free (e
->value
.character
.string
);
509 gfc_internal_error ("free_expr0(): Bad expr type");
512 /* Free a shape array. */
513 gfc_free_shape (&e
->shape
, e
->rank
);
515 gfc_free_ref_list (e
->ref
);
517 gfc_free_actual_arglist (e
->param_list
);
519 memset (e
, '\0', sizeof (gfc_expr
));
523 /* Free an expression node and everything beneath it. */
526 gfc_free_expr (gfc_expr
*e
)
535 /* Free an argument list and everything below it. */
538 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
540 gfc_actual_arglist
*a2
;
546 gfc_free_expr (a1
->expr
);
553 /* Copy an arglist structure and all of the arguments. */
556 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
558 gfc_actual_arglist
*head
, *tail
, *new_arg
;
562 for (; p
; p
= p
->next
)
564 new_arg
= gfc_get_actual_arglist ();
567 new_arg
->expr
= gfc_copy_expr (p
->expr
);
568 new_arg
->next
= NULL
;
573 tail
->next
= new_arg
;
582 /* Free a list of reference structures. */
585 gfc_free_ref_list (gfc_ref
*p
)
597 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
599 gfc_free_expr (p
->u
.ar
.start
[i
]);
600 gfc_free_expr (p
->u
.ar
.end
[i
]);
601 gfc_free_expr (p
->u
.ar
.stride
[i
]);
607 gfc_free_expr (p
->u
.ss
.start
);
608 gfc_free_expr (p
->u
.ss
.end
);
621 /* Graft the *src expression onto the *dest subexpression. */
624 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
632 /* Try to extract an integer constant from the passed expression node.
633 Return true if some error occurred, false on success. If REPORT_ERROR
634 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
635 for negative using gfc_error_now. */
638 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
642 /* A KIND component is a parameter too. The expression for it
643 is stored in the initializer and should be consistent with
645 if (gfc_expr_attr(expr
).pdt_kind
)
647 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
649 if (ref
->u
.c
.component
->attr
.pdt_kind
)
650 expr
= ref
->u
.c
.component
->initializer
;
654 if (expr
->expr_type
!= EXPR_CONSTANT
)
656 if (report_error
> 0)
657 gfc_error ("Constant expression required at %C");
658 else if (report_error
< 0)
659 gfc_error_now ("Constant expression required at %C");
663 if (expr
->ts
.type
!= BT_INTEGER
)
665 if (report_error
> 0)
666 gfc_error ("Integer expression required at %C");
667 else if (report_error
< 0)
668 gfc_error_now ("Integer expression required at %C");
672 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
673 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
675 if (report_error
> 0)
676 gfc_error ("Integer value too large in expression at %C");
677 else if (report_error
< 0)
678 gfc_error_now ("Integer value too large in expression at %C");
682 *result
= (int) mpz_get_si (expr
->value
.integer
);
688 /* Same as gfc_extract_int, but use a HWI. */
691 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
, int report_error
)
695 /* A KIND component is a parameter too. The expression for it is
696 stored in the initializer and should be consistent with the tests
698 if (gfc_expr_attr(expr
).pdt_kind
)
700 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
702 if (ref
->u
.c
.component
->attr
.pdt_kind
)
703 expr
= ref
->u
.c
.component
->initializer
;
707 if (expr
->expr_type
!= EXPR_CONSTANT
)
709 if (report_error
> 0)
710 gfc_error ("Constant expression required at %C");
711 else if (report_error
< 0)
712 gfc_error_now ("Constant expression required at %C");
716 if (expr
->ts
.type
!= BT_INTEGER
)
718 if (report_error
> 0)
719 gfc_error ("Integer expression required at %C");
720 else if (report_error
< 0)
721 gfc_error_now ("Integer expression required at %C");
725 /* Use long_long_integer_type_node to determine when to saturate. */
726 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
727 expr
->value
.integer
, false);
729 if (!wi::fits_shwi_p (val
))
731 if (report_error
> 0)
732 gfc_error ("Integer value too large in expression at %C");
733 else if (report_error
< 0)
734 gfc_error_now ("Integer value too large in expression at %C");
738 *result
= val
.to_shwi ();
744 /* Recursively copy a list of reference structures. */
747 gfc_copy_ref (gfc_ref
*src
)
755 dest
= gfc_get_ref ();
756 dest
->type
= src
->type
;
761 ar
= gfc_copy_array_ref (&src
->u
.ar
);
767 dest
->u
.c
= src
->u
.c
;
771 dest
->u
.i
= src
->u
.i
;
775 dest
->u
.ss
= src
->u
.ss
;
776 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
777 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
781 dest
->next
= gfc_copy_ref (src
->next
);
787 /* Detect whether an expression has any vector index array references. */
790 gfc_has_vector_index (gfc_expr
*e
)
794 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
795 if (ref
->type
== REF_ARRAY
)
796 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
797 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
803 /* Copy a shape array. */
806 gfc_copy_shape (mpz_t
*shape
, int rank
)
814 new_shape
= gfc_get_shape (rank
);
816 for (n
= 0; n
< rank
; n
++)
817 mpz_init_set (new_shape
[n
], shape
[n
]);
823 /* Copy a shape array excluding dimension N, where N is an integer
824 constant expression. Dimensions are numbered in Fortran style --
827 So, if the original shape array contains R elements
828 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
829 the result contains R-1 elements:
830 { s1 ... sN-1 sN+1 ... sR-1}
832 If anything goes wrong -- N is not a constant, its value is out
833 of range -- or anything else, just returns NULL. */
836 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
838 mpz_t
*new_shape
, *s
;
844 || dim
->expr_type
!= EXPR_CONSTANT
845 || dim
->ts
.type
!= BT_INTEGER
)
848 n
= mpz_get_si (dim
->value
.integer
);
849 n
--; /* Convert to zero based index. */
850 if (n
< 0 || n
>= rank
)
853 s
= new_shape
= gfc_get_shape (rank
- 1);
855 for (i
= 0; i
< rank
; i
++)
859 mpz_init_set (*s
, shape
[i
]);
867 /* Return the maximum kind of two expressions. In general, higher
868 kind numbers mean more precision for numeric types. */
871 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
873 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
877 /* Returns nonzero if the type is numeric, zero otherwise. */
880 numeric_type (bt type
)
882 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
886 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
889 gfc_numeric_ts (gfc_typespec
*ts
)
891 return numeric_type (ts
->type
);
895 /* Return an expression node with an optional argument list attached.
896 A variable number of gfc_expr pointers are strung together in an
897 argument list with a NULL pointer terminating the list. */
900 gfc_build_conversion (gfc_expr
*e
)
905 p
->expr_type
= EXPR_FUNCTION
;
907 p
->value
.function
.actual
= gfc_get_actual_arglist ();
908 p
->value
.function
.actual
->expr
= e
;
914 /* Given an expression node with some sort of numeric binary
915 expression, insert type conversions required to make the operands
916 have the same type. Conversion warnings are disabled if wconversion
919 The exception is that the operands of an exponential don't have to
920 have the same type. If possible, the base is promoted to the type
921 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
922 1.0**2 stays as it is. */
925 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
929 op1
= e
->value
.op
.op1
;
930 op2
= e
->value
.op
.op2
;
932 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
934 gfc_clear_ts (&e
->ts
);
938 /* Kind conversions of same type. */
939 if (op1
->ts
.type
== op2
->ts
.type
)
941 if (op1
->ts
.kind
== op2
->ts
.kind
)
943 /* No type conversions. */
948 if (op1
->ts
.kind
> op2
->ts
.kind
)
949 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
951 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
957 /* Integer combined with real or complex. */
958 if (op2
->ts
.type
== BT_INTEGER
)
962 /* Special case for ** operator. */
963 if (e
->value
.op
.op
== INTRINSIC_POWER
)
966 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
970 if (op1
->ts
.type
== BT_INTEGER
)
973 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
977 /* Real combined with complex. */
978 e
->ts
.type
= BT_COMPLEX
;
979 if (op1
->ts
.kind
> op2
->ts
.kind
)
980 e
->ts
.kind
= op1
->ts
.kind
;
982 e
->ts
.kind
= op2
->ts
.kind
;
983 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
984 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
985 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
986 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
993 /* Determine if an expression is constant in the sense of F08:7.1.12.
994 * This function expects that the expression has already been simplified. */
997 gfc_is_constant_expr (gfc_expr
*e
)
1000 gfc_actual_arglist
*arg
;
1005 switch (e
->expr_type
)
1008 return (gfc_is_constant_expr (e
->value
.op
.op1
)
1009 && (e
->value
.op
.op2
== NULL
1010 || gfc_is_constant_expr (e
->value
.op
.op2
)));
1013 /* The only context in which this can occur is in a parameterized
1014 derived type declaration, so returning true is OK. */
1015 if (e
->symtree
->n
.sym
->attr
.pdt_len
1016 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1023 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1024 || e
->value
.function
.isym
);
1026 /* Call to intrinsic with at least one argument. */
1027 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1029 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1030 if (!gfc_is_constant_expr (arg
->expr
))
1034 if (e
->value
.function
.isym
1035 && (e
->value
.function
.isym
->elemental
1036 || e
->value
.function
.isym
->pure
1037 || e
->value
.function
.isym
->inquiry
1038 || e
->value
.function
.isym
->transformational
))
1047 case EXPR_SUBSTRING
:
1048 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1049 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1052 case EXPR_STRUCTURE
:
1053 c
= gfc_constructor_first (e
->value
.constructor
);
1054 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1055 return gfc_constant_ac (e
);
1057 for (; c
; c
= gfc_constructor_next (c
))
1058 if (!gfc_is_constant_expr (c
->expr
))
1065 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1071 /* Is true if the expression or symbol is a passed CFI descriptor. */
1073 is_CFI_desc (gfc_symbol
*sym
, gfc_expr
*e
)
1076 && e
&& e
->expr_type
== EXPR_VARIABLE
)
1077 sym
= e
->symtree
->n
.sym
;
1079 if (sym
&& sym
->attr
.dummy
1080 && sym
->ns
->proc_name
->attr
.is_bind_c
1081 && sym
->attr
.dimension
1082 && (sym
->attr
.pointer
1083 || sym
->attr
.allocatable
1084 || sym
->as
->type
== AS_ASSUMED_SHAPE
1085 || sym
->as
->type
== AS_ASSUMED_RANK
))
1092 /* Is true if an array reference is followed by a component or substring
1095 is_subref_array (gfc_expr
* e
)
1101 if (e
->expr_type
!= EXPR_VARIABLE
)
1104 sym
= e
->symtree
->n
.sym
;
1106 if (sym
->attr
.subref_array_pointer
)
1111 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1113 /* If we haven't seen the array reference and this is an intrinsic,
1114 what follows cannot be a subreference array, unless there is a
1115 substring reference. */
1116 if (!seen_array
&& ref
->type
== REF_COMPONENT
1117 && ref
->u
.c
.component
->ts
.type
!= BT_CHARACTER
1118 && ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1119 && !gfc_bt_struct (ref
->u
.c
.component
->ts
.type
))
1122 if (ref
->type
== REF_ARRAY
1123 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1127 && ref
->type
!= REF_ARRAY
)
1131 if (sym
->ts
.type
== BT_CLASS
1133 && CLASS_DATA (sym
)->attr
.dimension
1134 && CLASS_DATA (sym
)->attr
.class_pointer
)
1141 /* Try to collapse intrinsic expressions. */
1144 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1146 gfc_intrinsic_op op
;
1147 gfc_expr
*op1
, *op2
, *result
;
1149 if (p
->value
.op
.op
== INTRINSIC_USER
)
1152 op1
= p
->value
.op
.op1
;
1153 op2
= p
->value
.op
.op2
;
1154 op
= p
->value
.op
.op
;
1156 if (!gfc_simplify_expr (op1
, type
))
1158 if (!gfc_simplify_expr (op2
, type
))
1161 if (!gfc_is_constant_expr (op1
)
1162 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1166 p
->value
.op
.op1
= NULL
;
1167 p
->value
.op
.op2
= NULL
;
1171 case INTRINSIC_PARENTHESES
:
1172 result
= gfc_parentheses (op1
);
1175 case INTRINSIC_UPLUS
:
1176 result
= gfc_uplus (op1
);
1179 case INTRINSIC_UMINUS
:
1180 result
= gfc_uminus (op1
);
1183 case INTRINSIC_PLUS
:
1184 result
= gfc_add (op1
, op2
);
1187 case INTRINSIC_MINUS
:
1188 result
= gfc_subtract (op1
, op2
);
1191 case INTRINSIC_TIMES
:
1192 result
= gfc_multiply (op1
, op2
);
1195 case INTRINSIC_DIVIDE
:
1196 result
= gfc_divide (op1
, op2
);
1199 case INTRINSIC_POWER
:
1200 result
= gfc_power (op1
, op2
);
1203 case INTRINSIC_CONCAT
:
1204 result
= gfc_concat (op1
, op2
);
1208 case INTRINSIC_EQ_OS
:
1209 result
= gfc_eq (op1
, op2
, op
);
1213 case INTRINSIC_NE_OS
:
1214 result
= gfc_ne (op1
, op2
, op
);
1218 case INTRINSIC_GT_OS
:
1219 result
= gfc_gt (op1
, op2
, op
);
1223 case INTRINSIC_GE_OS
:
1224 result
= gfc_ge (op1
, op2
, op
);
1228 case INTRINSIC_LT_OS
:
1229 result
= gfc_lt (op1
, op2
, op
);
1233 case INTRINSIC_LE_OS
:
1234 result
= gfc_le (op1
, op2
, op
);
1238 result
= gfc_not (op1
);
1242 result
= gfc_and (op1
, op2
);
1246 result
= gfc_or (op1
, op2
);
1250 result
= gfc_eqv (op1
, op2
);
1253 case INTRINSIC_NEQV
:
1254 result
= gfc_neqv (op1
, op2
);
1258 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1263 gfc_free_expr (op1
);
1264 gfc_free_expr (op2
);
1268 result
->rank
= p
->rank
;
1269 result
->where
= p
->where
;
1270 gfc_replace_expr (p
, result
);
1276 /* Subroutine to simplify constructor expressions. Mutually recursive
1277 with gfc_simplify_expr(). */
1280 simplify_constructor (gfc_constructor_base base
, int type
)
1285 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1288 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1289 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1290 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1295 /* Try and simplify a copy. Replace the original if successful
1296 but keep going through the constructor at all costs. Not
1297 doing so can make a dog's dinner of complicated things. */
1298 p
= gfc_copy_expr (c
->expr
);
1300 if (!gfc_simplify_expr (p
, type
))
1306 gfc_replace_expr (c
->expr
, p
);
1314 /* Pull a single array element out of an array constructor. */
1317 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1318 gfc_constructor
**rval
)
1320 unsigned long nelemen
;
1326 gfc_constructor
*cons
;
1333 mpz_init_set_ui (offset
, 0);
1336 mpz_init_set_ui (span
, 1);
1337 for (i
= 0; i
< ar
->dimen
; i
++)
1339 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1340 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1348 if (e
->expr_type
!= EXPR_CONSTANT
)
1354 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1355 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1357 /* Check the bounds. */
1358 if ((ar
->as
->upper
[i
]
1359 && mpz_cmp (e
->value
.integer
,
1360 ar
->as
->upper
[i
]->value
.integer
) > 0)
1361 || (mpz_cmp (e
->value
.integer
,
1362 ar
->as
->lower
[i
]->value
.integer
) < 0))
1364 gfc_error ("Index in dimension %d is out of bounds "
1365 "at %L", i
+ 1, &ar
->c_where
[i
]);
1371 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1372 mpz_mul (delta
, delta
, span
);
1373 mpz_add (offset
, offset
, delta
);
1375 mpz_set_ui (tmp
, 1);
1376 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1377 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1378 mpz_mul (span
, span
, tmp
);
1381 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1382 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1401 /* Find a component of a structure constructor. */
1403 static gfc_constructor
*
1404 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1406 gfc_component
*pick
= ref
->u
.c
.component
;
1407 gfc_constructor
*c
= gfc_constructor_first (base
);
1409 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1410 int ext
= dt
->attr
.extension
;
1412 /* For extended types, check if the desired component is in one of the
1414 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1415 pick
->name
, true, true, NULL
))
1417 dt
= dt
->components
->ts
.u
.derived
;
1418 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1422 gfc_component
*comp
= dt
->components
;
1423 while (comp
!= pick
)
1426 c
= gfc_constructor_next (c
);
1433 /* Replace an expression with the contents of a constructor, removing
1434 the subobject reference in the process. */
1437 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1447 e
= gfc_copy_expr (p
);
1448 e
->ref
= p
->ref
->next
;
1449 p
->ref
->next
= NULL
;
1450 gfc_replace_expr (p
, e
);
1454 /* Pull an array section out of an array constructor. */
1457 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1464 long unsigned one
= 1;
1466 mpz_t start
[GFC_MAX_DIMENSIONS
];
1467 mpz_t end
[GFC_MAX_DIMENSIONS
];
1468 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1469 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1470 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1475 gfc_constructor_base base
;
1476 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1486 base
= expr
->value
.constructor
;
1487 expr
->value
.constructor
= NULL
;
1489 rank
= ref
->u
.ar
.as
->rank
;
1491 if (expr
->shape
== NULL
)
1492 expr
->shape
= gfc_get_shape (rank
);
1494 mpz_init_set_ui (delta_mpz
, one
);
1495 mpz_init_set_ui (nelts
, one
);
1498 /* Do the initialization now, so that we can cleanup without
1499 keeping track of where we were. */
1500 for (d
= 0; d
< rank
; d
++)
1502 mpz_init (delta
[d
]);
1503 mpz_init (start
[d
]);
1506 mpz_init (stride
[d
]);
1510 /* Build the counters to clock through the array reference. */
1512 for (d
= 0; d
< rank
; d
++)
1514 /* Make this stretch of code easier on the eye! */
1515 begin
= ref
->u
.ar
.start
[d
];
1516 finish
= ref
->u
.ar
.end
[d
];
1517 step
= ref
->u
.ar
.stride
[d
];
1518 lower
= ref
->u
.ar
.as
->lower
[d
];
1519 upper
= ref
->u
.ar
.as
->upper
[d
];
1521 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1523 gfc_constructor
*ci
;
1526 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1532 gcc_assert (begin
->rank
== 1);
1533 /* Zero-sized arrays have no shape and no elements, stop early. */
1536 mpz_init_set_ui (nelts
, 0);
1540 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1541 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1542 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1543 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1546 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1548 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1549 || mpz_cmp (ci
->expr
->value
.integer
,
1550 lower
->value
.integer
) < 0)
1552 gfc_error ("index in dimension %d is out of bounds "
1553 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1561 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1562 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1563 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1569 /* Obtain the stride. */
1571 mpz_set (stride
[d
], step
->value
.integer
);
1573 mpz_set_ui (stride
[d
], one
);
1575 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1576 mpz_set_ui (stride
[d
], one
);
1578 /* Obtain the start value for the index. */
1580 mpz_set (start
[d
], begin
->value
.integer
);
1582 mpz_set (start
[d
], lower
->value
.integer
);
1584 mpz_set (ctr
[d
], start
[d
]);
1586 /* Obtain the end value for the index. */
1588 mpz_set (end
[d
], finish
->value
.integer
);
1590 mpz_set (end
[d
], upper
->value
.integer
);
1592 /* Separate 'if' because elements sometimes arrive with
1594 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1595 mpz_set (end
[d
], begin
->value
.integer
);
1597 /* Check the bounds. */
1598 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1599 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1600 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1601 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1603 gfc_error ("index in dimension %d is out of bounds "
1604 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1609 /* Calculate the number of elements and the shape. */
1610 mpz_set (tmp_mpz
, stride
[d
]);
1611 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1612 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1613 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1614 mpz_mul (nelts
, nelts
, tmp_mpz
);
1616 /* An element reference reduces the rank of the expression; don't
1617 add anything to the shape array. */
1618 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1619 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1622 /* Calculate the 'stride' (=delta) for conversion of the
1623 counter values into the index along the constructor. */
1624 mpz_set (delta
[d
], delta_mpz
);
1625 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1626 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1627 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1631 cons
= gfc_constructor_first (base
);
1633 /* Now clock through the array reference, calculating the index in
1634 the source constructor and transferring the elements to the new
1636 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1638 mpz_init_set_ui (ptr
, 0);
1641 for (d
= 0; d
< rank
; d
++)
1643 mpz_set (tmp_mpz
, ctr
[d
]);
1644 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1645 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1646 mpz_add (ptr
, ptr
, tmp_mpz
);
1648 if (!incr_ctr
) continue;
1650 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1652 gcc_assert(vecsub
[d
]);
1654 if (!gfc_constructor_next (vecsub
[d
]))
1655 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1658 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1661 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1665 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1667 if (mpz_cmp_ui (stride
[d
], 0) > 0
1668 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1669 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1670 mpz_set (ctr
[d
], start
[d
]);
1676 limit
= mpz_get_ui (ptr
);
1677 if (limit
>= flag_max_array_constructor
)
1679 gfc_error ("The number of elements in the array constructor "
1680 "at %L requires an increase of the allowed %d "
1681 "upper limit. See %<-fmax-array-constructor%> "
1682 "option", &expr
->where
, flag_max_array_constructor
);
1686 cons
= gfc_constructor_lookup (base
, limit
);
1688 gfc_constructor_append_expr (&expr
->value
.constructor
,
1689 gfc_copy_expr (cons
->expr
), NULL
);
1696 mpz_clear (delta_mpz
);
1697 mpz_clear (tmp_mpz
);
1699 for (d
= 0; d
< rank
; d
++)
1701 mpz_clear (delta
[d
]);
1702 mpz_clear (start
[d
]);
1705 mpz_clear (stride
[d
]);
1707 gfc_constructor_free (base
);
1711 /* Pull a substring out of an expression. */
1714 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1717 gfc_charlen_t start
;
1718 gfc_charlen_t length
;
1721 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1722 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1725 *newp
= gfc_copy_expr (p
);
1726 free ((*newp
)->value
.character
.string
);
1728 end
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1729 start
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1731 length
= end
- start
+ 1;
1735 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1736 (*newp
)->value
.character
.length
= length
;
1737 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1738 length
* sizeof (gfc_char_t
));
1744 /* Pull an inquiry result out of an expression. */
1747 find_inquiry_ref (gfc_expr
*p
, gfc_expr
**newp
)
1750 gfc_ref
*inquiry
= NULL
;
1753 tmp
= gfc_copy_expr (p
);
1755 if (tmp
->ref
&& tmp
->ref
->type
== REF_INQUIRY
)
1762 for (ref
= tmp
->ref
; ref
; ref
= ref
->next
)
1763 if (ref
->next
&& ref
->next
->type
== REF_INQUIRY
)
1765 inquiry
= ref
->next
;
1772 gfc_free_expr (tmp
);
1776 gfc_resolve_expr (tmp
);
1778 /* In principle there can be more than one inquiry reference. */
1779 for (; inquiry
; inquiry
= inquiry
->next
)
1781 switch (inquiry
->u
.i
)
1784 if (tmp
->ts
.type
!= BT_CHARACTER
)
1787 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1790 if (!tmp
->ts
.u
.cl
->length
1791 || tmp
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1794 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1798 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1801 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1804 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1805 NULL
, tmp
->ts
.kind
);
1809 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1812 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1815 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1816 mpfr_set ((*newp
)->value
.real
,
1817 mpc_realref (p
->value
.complex), GFC_RND_MODE
);
1821 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1824 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1827 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1828 mpfr_set ((*newp
)->value
.real
,
1829 mpc_imagref (p
->value
.complex), GFC_RND_MODE
);
1832 tmp
= gfc_copy_expr (*newp
);
1837 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1839 gfc_free_expr (*newp
);
1843 gfc_free_expr (tmp
);
1847 gfc_free_expr (tmp
);
1853 /* Simplify a subobject reference of a constructor. This occurs when
1854 parameter variable values are substituted. */
1857 simplify_const_ref (gfc_expr
*p
)
1859 gfc_constructor
*cons
, *c
;
1860 gfc_expr
*newp
= NULL
;
1865 switch (p
->ref
->type
)
1868 switch (p
->ref
->u
.ar
.type
)
1871 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1872 will generate this. */
1873 if (p
->expr_type
!= EXPR_ARRAY
)
1875 remove_subobject_ref (p
, NULL
);
1878 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1884 remove_subobject_ref (p
, cons
);
1888 if (!find_array_section (p
, p
->ref
))
1890 p
->ref
->u
.ar
.type
= AR_FULL
;
1895 if (p
->ref
->next
!= NULL
1896 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1898 for (c
= gfc_constructor_first (p
->value
.constructor
);
1899 c
; c
= gfc_constructor_next (c
))
1901 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1902 if (!simplify_const_ref (c
->expr
))
1906 if (gfc_bt_struct (p
->ts
.type
)
1908 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1910 /* There may have been component references. */
1911 p
->ts
= c
->expr
->ts
;
1915 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1917 if (p
->ts
.type
== BT_CHARACTER
1918 && last_ref
->type
== REF_SUBSTRING
)
1920 /* If this is a CHARACTER array and we possibly took
1921 a substring out of it, update the type-spec's
1922 character length according to the first element
1923 (as all should have the same length). */
1924 gfc_charlen_t string_len
;
1925 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1927 const gfc_expr
* first
= c
->expr
;
1928 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1929 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1930 string_len
= first
->value
.character
.length
;
1938 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1941 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
,
1945 gfc_free_expr (p
->ts
.u
.cl
->length
);
1948 = gfc_get_int_expr (gfc_charlen_int_kind
,
1952 gfc_free_ref_list (p
->ref
);
1963 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1964 remove_subobject_ref (p
, cons
);
1968 if (!find_inquiry_ref (p
, &newp
))
1971 gfc_replace_expr (p
, newp
);
1972 gfc_free_ref_list (p
->ref
);
1977 if (!find_substring_ref (p
, &newp
))
1980 gfc_replace_expr (p
, newp
);
1981 gfc_free_ref_list (p
->ref
);
1991 /* Simplify a chain of references. */
1994 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
1999 for (; ref
; ref
= ref
->next
)
2004 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
2006 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
2008 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
2010 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
2016 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
2018 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
2023 if (!find_inquiry_ref (*p
, &newp
))
2026 gfc_replace_expr (*p
, newp
);
2027 gfc_free_ref_list ((*p
)->ref
);
2039 /* Try to substitute the value of a parameter variable. */
2042 simplify_parameter_variable (gfc_expr
*p
, int type
)
2047 if (gfc_is_size_zero_array (p
))
2049 if (p
->expr_type
== EXPR_ARRAY
)
2052 e
= gfc_get_expr ();
2053 e
->expr_type
= EXPR_ARRAY
;
2056 e
->value
.constructor
= NULL
;
2057 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2058 e
->where
= p
->where
;
2059 gfc_replace_expr (p
, e
);
2063 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2069 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
)
2070 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, p
->ts
.u
.cl
);
2072 /* Do not copy subobject refs for constant. */
2073 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2074 e
->ref
= gfc_copy_ref (p
->ref
);
2075 t
= gfc_simplify_expr (e
, type
);
2077 /* Only use the simplification if it eliminated all subobject references. */
2079 gfc_replace_expr (p
, e
);
2088 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2090 /* Given an expression, simplify it by collapsing constant
2091 expressions. Most simplification takes place when the expression
2092 tree is being constructed. If an intrinsic function is simplified
2093 at some point, we get called again to collapse the result against
2096 We work by recursively simplifying expression nodes, simplifying
2097 intrinsic functions where possible, which can lead to further
2098 constant collapsing. If an operator has constant operand(s), we
2099 rip the expression apart, and rebuild it, hoping that it becomes
2102 The expression type is defined for:
2103 0 Basic expression parsing
2104 1 Simplifying array constructors -- will substitute
2106 Returns false on error, true otherwise.
2107 NOTE: Will return true even if the expression cannot be simplified. */
2110 gfc_simplify_expr (gfc_expr
*p
, int type
)
2112 gfc_actual_arglist
*ap
;
2113 gfc_intrinsic_sym
* isym
= NULL
;
2119 switch (p
->expr_type
)
2122 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2123 simplify_ref_chain (p
->ref
, type
, &p
);
2129 // For array-bound functions, we don't need to optimize
2130 // the 'array' argument. In particular, if the argument
2131 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2132 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2133 // can have any lbound.
2134 ap
= p
->value
.function
.actual
;
2135 if (p
->value
.function
.isym
&&
2136 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2137 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2138 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2139 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
))
2142 for ( ; ap
; ap
= ap
->next
)
2143 if (!gfc_simplify_expr (ap
->expr
, type
))
2146 if (p
->value
.function
.isym
!= NULL
2147 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2150 if (p
->expr_type
== EXPR_FUNCTION
)
2153 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2154 if (isym
&& isym
->elemental
)
2155 scalarize_intrinsic_call (p
, false);
2160 case EXPR_SUBSTRING
:
2161 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2164 if (gfc_is_constant_expr (p
))
2167 HOST_WIDE_INT start
, end
;
2170 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2172 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2173 start
--; /* Convert from one-based to zero-based. */
2176 end
= p
->value
.character
.length
;
2177 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2178 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2183 s
= gfc_get_wide_string (end
- start
+ 2);
2184 memcpy (s
, p
->value
.character
.string
+ start
,
2185 (end
- start
) * sizeof (gfc_char_t
));
2186 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2187 free (p
->value
.character
.string
);
2188 p
->value
.character
.string
= s
;
2189 p
->value
.character
.length
= end
- start
;
2190 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2191 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2193 p
->value
.character
.length
);
2194 gfc_free_ref_list (p
->ref
);
2196 p
->expr_type
= EXPR_CONSTANT
;
2201 if (!simplify_intrinsic_op (p
, type
))
2206 /* Only substitute array parameter variables if we are in an
2207 initialization expression, or we want a subsection. */
2208 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2209 && (gfc_init_expr_flag
|| p
->ref
2210 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2212 if (!simplify_parameter_variable (p
, type
))
2219 gfc_simplify_iterator_var (p
);
2222 /* Simplify subcomponent references. */
2223 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2228 case EXPR_STRUCTURE
:
2230 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2233 /* If the following conditions hold, we found something like kind type
2234 inquiry of the form a(2)%kind while simplify the ref chain. */
2235 if (p
->expr_type
== EXPR_CONSTANT
&& !p
->ref
&& !p
->rank
&& !p
->shape
)
2238 if (!simplify_constructor (p
->value
.constructor
, type
))
2241 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2242 && p
->ref
->u
.ar
.type
== AR_FULL
)
2243 gfc_expand_constructor (p
, false);
2245 if (!simplify_const_ref (p
))
2262 /* Returns the type of an expression with the exception that iterator
2263 variables are automatically integers no matter what else they may
2269 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2276 /* Scalarize an expression for an elemental intrinsic call. */
2279 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2281 gfc_actual_arglist
*a
, *b
;
2282 gfc_constructor_base ctor
;
2283 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2284 gfc_constructor
*ci
, *new_ctor
;
2285 gfc_expr
*expr
, *old
;
2286 int n
, i
, rank
[5], array_arg
;
2292 a
= e
->value
.function
.actual
;
2293 for (; a
; a
= a
->next
)
2294 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2297 /* Find which, if any, arguments are arrays. Assume that the old
2298 expression carries the type information and that the first arg
2299 that is an array expression carries all the shape information.*/
2301 a
= e
->value
.function
.actual
;
2302 for (; a
; a
= a
->next
)
2305 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2308 expr
= gfc_copy_expr (a
->expr
);
2315 old
= gfc_copy_expr (e
);
2317 gfc_constructor_free (expr
->value
.constructor
);
2318 expr
->value
.constructor
= NULL
;
2320 expr
->where
= old
->where
;
2321 expr
->expr_type
= EXPR_ARRAY
;
2323 /* Copy the array argument constructors into an array, with nulls
2326 a
= old
->value
.function
.actual
;
2327 for (; a
; a
= a
->next
)
2329 /* Check that this is OK for an initialization expression. */
2330 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2334 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2336 rank
[n
] = a
->expr
->rank
;
2337 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2338 args
[n
] = gfc_constructor_first (ctor
);
2340 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2343 rank
[n
] = a
->expr
->rank
;
2346 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2347 args
[n
] = gfc_constructor_first (ctor
);
2355 gfc_get_errors (NULL
, &errors
);
2357 /* Using the array argument as the master, step through the array
2358 calling the function for each element and advancing the array
2359 constructors together. */
2360 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2362 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2363 gfc_copy_expr (old
), NULL
);
2365 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2367 b
= old
->value
.function
.actual
;
2368 for (i
= 0; i
< n
; i
++)
2371 new_ctor
->expr
->value
.function
.actual
2372 = a
= gfc_get_actual_arglist ();
2375 a
->next
= gfc_get_actual_arglist ();
2380 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2382 a
->expr
= gfc_copy_expr (b
->expr
);
2387 /* Simplify the function calls. If the simplification fails, the
2388 error will be flagged up down-stream or the library will deal
2391 gfc_simplify_expr (new_ctor
->expr
, 0);
2393 for (i
= 0; i
< n
; i
++)
2395 args
[i
] = gfc_constructor_next (args
[i
]);
2397 for (i
= 1; i
< n
; i
++)
2398 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2399 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2405 /* Free "expr" but not the pointers it contains. */
2407 gfc_free_expr (old
);
2411 gfc_error_now ("elemental function arguments at %C are not compliant");
2414 gfc_free_expr (expr
);
2415 gfc_free_expr (old
);
2421 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2423 gfc_expr
*op1
= e
->value
.op
.op1
;
2424 gfc_expr
*op2
= e
->value
.op
.op2
;
2426 if (!(*check_function
)(op1
))
2429 switch (e
->value
.op
.op
)
2431 case INTRINSIC_UPLUS
:
2432 case INTRINSIC_UMINUS
:
2433 if (!numeric_type (et0 (op1
)))
2438 case INTRINSIC_EQ_OS
:
2440 case INTRINSIC_NE_OS
:
2442 case INTRINSIC_GT_OS
:
2444 case INTRINSIC_GE_OS
:
2446 case INTRINSIC_LT_OS
:
2448 case INTRINSIC_LE_OS
:
2449 if (!(*check_function
)(op2
))
2452 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2453 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2455 gfc_error ("Numeric or CHARACTER operands are required in "
2456 "expression at %L", &e
->where
);
2461 case INTRINSIC_PLUS
:
2462 case INTRINSIC_MINUS
:
2463 case INTRINSIC_TIMES
:
2464 case INTRINSIC_DIVIDE
:
2465 case INTRINSIC_POWER
:
2466 if (!(*check_function
)(op2
))
2469 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2474 case INTRINSIC_CONCAT
:
2475 if (!(*check_function
)(op2
))
2478 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2480 gfc_error ("Concatenation operator in expression at %L "
2481 "must have two CHARACTER operands", &op1
->where
);
2485 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2487 gfc_error ("Concat operator at %L must concatenate strings of the "
2488 "same kind", &e
->where
);
2495 if (et0 (op1
) != BT_LOGICAL
)
2497 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2498 "operand", &op1
->where
);
2507 case INTRINSIC_NEQV
:
2508 if (!(*check_function
)(op2
))
2511 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2513 gfc_error ("LOGICAL operands are required in expression at %L",
2520 case INTRINSIC_PARENTHESES
:
2524 gfc_error ("Only intrinsic operators can be used in expression at %L",
2532 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2537 /* F2003, 7.1.7 (3): In init expression, allocatable components
2538 must not be data-initialized. */
2540 check_alloc_comp_init (gfc_expr
*e
)
2542 gfc_component
*comp
;
2543 gfc_constructor
*ctor
;
2545 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2546 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2548 for (comp
= e
->ts
.u
.derived
->components
,
2549 ctor
= gfc_constructor_first (e
->value
.constructor
);
2550 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2552 if (comp
->attr
.allocatable
&& ctor
->expr
2553 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2555 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2556 "component %qs in structure constructor at %L",
2557 comp
->name
, &ctor
->expr
->where
);
2566 check_init_expr_arguments (gfc_expr
*e
)
2568 gfc_actual_arglist
*ap
;
2570 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2571 if (!gfc_check_init_expr (ap
->expr
))
2577 static bool check_restricted (gfc_expr
*);
2579 /* F95, 7.1.6.1, Initialization expressions, (7)
2580 F2003, 7.1.7 Initialization expression, (8)
2581 F2008, 7.1.12 Constant expression, (4) */
2584 check_inquiry (gfc_expr
*e
, int not_restricted
)
2587 const char *const *functions
;
2589 static const char *const inquiry_func_f95
[] = {
2590 "lbound", "shape", "size", "ubound",
2591 "bit_size", "len", "kind",
2592 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2593 "precision", "radix", "range", "tiny",
2597 static const char *const inquiry_func_f2003
[] = {
2598 "lbound", "shape", "size", "ubound",
2599 "bit_size", "len", "kind",
2600 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2601 "precision", "radix", "range", "tiny",
2605 /* std=f2008+ or -std=gnu */
2606 static const char *const inquiry_func_gnu
[] = {
2607 "lbound", "shape", "size", "ubound",
2608 "bit_size", "len", "kind",
2609 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2610 "precision", "radix", "range", "tiny",
2611 "new_line", "storage_size", NULL
2615 gfc_actual_arglist
*ap
;
2619 if (!e
->value
.function
.isym
2620 || !e
->value
.function
.isym
->inquiry
)
2623 /* An undeclared parameter will get us here (PR25018). */
2624 if (e
->symtree
== NULL
)
2627 sym
= e
->symtree
->n
.sym
;
2629 if (sym
->from_intmod
)
2631 if (sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2632 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2633 && sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2636 if (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2637 && sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2644 functions
= inquiry_func_gnu
;
2645 if (gfc_option
.warn_std
& GFC_STD_F2003
)
2646 functions
= inquiry_func_f2003
;
2647 if (gfc_option
.warn_std
& GFC_STD_F95
)
2648 functions
= inquiry_func_f95
;
2650 for (i
= 0; functions
[i
]; i
++)
2651 if (strcmp (functions
[i
], name
) == 0)
2654 if (functions
[i
] == NULL
)
2658 /* At this point we have an inquiry function with a variable argument. The
2659 type of the variable might be undefined, but we need it now, because the
2660 arguments of these functions are not allowed to be undefined. */
2662 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2667 asym
= ap
->expr
->symtree
? ap
->expr
->symtree
->n
.sym
: NULL
;
2669 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2671 if (asym
&& asym
->ts
.type
== BT_UNKNOWN
2672 && !gfc_set_default_type (asym
, 0, gfc_current_ns
))
2675 ap
->expr
->ts
= asym
->ts
;
2678 if (asym
&& asym
->assoc
&& asym
->assoc
->target
2679 && asym
->assoc
->target
->expr_type
== EXPR_CONSTANT
)
2681 gfc_free_expr (ap
->expr
);
2682 ap
->expr
= gfc_copy_expr (asym
->assoc
->target
);
2685 /* Assumed character length will not reduce to a constant expression
2686 with LEN, as required by the standard. */
2687 if (i
== 5 && not_restricted
&& asym
2688 && asym
->ts
.type
== BT_CHARACTER
2689 && ((asym
->ts
.u
.cl
&& asym
->ts
.u
.cl
->length
== NULL
)
2690 || asym
->ts
.deferred
))
2692 gfc_error ("Assumed or deferred character length variable %qs "
2693 "in constant expression at %L",
2694 asym
->name
, &ap
->expr
->where
);
2697 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2700 if (not_restricted
== 0
2701 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2702 && !check_restricted (ap
->expr
))
2705 if (not_restricted
== 0
2706 && ap
->expr
->expr_type
== EXPR_VARIABLE
2707 && asym
->attr
.dummy
&& asym
->attr
.optional
)
2715 /* F95, 7.1.6.1, Initialization expressions, (5)
2716 F2003, 7.1.7 Initialization expression, (5) */
2719 check_transformational (gfc_expr
*e
)
2721 static const char * const trans_func_f95
[] = {
2722 "repeat", "reshape", "selected_int_kind",
2723 "selected_real_kind", "transfer", "trim", NULL
2726 static const char * const trans_func_f2003
[] = {
2727 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2728 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2729 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2730 "trim", "unpack", NULL
2733 static const char * const trans_func_f2008
[] = {
2734 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2735 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2736 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2737 "trim", "unpack", "findloc", NULL
2742 const char *const *functions
;
2744 if (!e
->value
.function
.isym
2745 || !e
->value
.function
.isym
->transformational
)
2748 name
= e
->symtree
->n
.sym
->name
;
2750 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2751 functions
= trans_func_f2008
;
2752 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2753 functions
= trans_func_f2003
;
2755 functions
= trans_func_f95
;
2757 /* NULL() is dealt with below. */
2758 if (strcmp ("null", name
) == 0)
2761 for (i
= 0; functions
[i
]; i
++)
2762 if (strcmp (functions
[i
], name
) == 0)
2765 if (functions
[i
] == NULL
)
2767 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2768 "in an initialization expression", name
, &e
->where
);
2772 return check_init_expr_arguments (e
);
2776 /* F95, 7.1.6.1, Initialization expressions, (6)
2777 F2003, 7.1.7 Initialization expression, (6) */
2780 check_null (gfc_expr
*e
)
2782 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2785 return check_init_expr_arguments (e
);
2790 check_elemental (gfc_expr
*e
)
2792 if (!e
->value
.function
.isym
2793 || !e
->value
.function
.isym
->elemental
)
2796 if (e
->ts
.type
!= BT_INTEGER
2797 && e
->ts
.type
!= BT_CHARACTER
2798 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2799 "initialization expression at %L", &e
->where
))
2802 return check_init_expr_arguments (e
);
2807 check_conversion (gfc_expr
*e
)
2809 if (!e
->value
.function
.isym
2810 || !e
->value
.function
.isym
->conversion
)
2813 return check_init_expr_arguments (e
);
2817 /* Verify that an expression is an initialization expression. A side
2818 effect is that the expression tree is reduced to a single constant
2819 node if all goes well. This would normally happen when the
2820 expression is constructed but function references are assumed to be
2821 intrinsics in the context of initialization expressions. If
2822 false is returned an error message has been generated. */
2825 gfc_check_init_expr (gfc_expr
*e
)
2833 switch (e
->expr_type
)
2836 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2838 t
= gfc_simplify_expr (e
, 0);
2847 gfc_intrinsic_sym
* isym
= NULL
;
2848 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2850 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2851 IEEE_EXCEPTIONS modules. */
2852 int mod
= sym
->from_intmod
;
2853 if (mod
== INTMOD_NONE
&& sym
->generic
)
2854 mod
= sym
->generic
->sym
->from_intmod
;
2855 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2857 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2860 gfc_replace_expr (e
, new_expr
);
2866 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2867 into an array constructor, we need to skip the error check here.
2868 Conversion errors are caught below in scalarize_intrinsic_call. */
2869 conversion
= e
->value
.function
.isym
2870 && (e
->value
.function
.isym
->conversion
== 1);
2872 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2873 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2875 gfc_error ("Function %qs in initialization expression at %L "
2876 "must be an intrinsic function",
2877 e
->symtree
->n
.sym
->name
, &e
->where
);
2881 if ((m
= check_conversion (e
)) == MATCH_NO
2882 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2883 && (m
= check_null (e
)) == MATCH_NO
2884 && (m
= check_transformational (e
)) == MATCH_NO
2885 && (m
= check_elemental (e
)) == MATCH_NO
)
2887 gfc_error ("Intrinsic function %qs at %L is not permitted "
2888 "in an initialization expression",
2889 e
->symtree
->n
.sym
->name
, &e
->where
);
2893 if (m
== MATCH_ERROR
)
2896 /* Try to scalarize an elemental intrinsic function that has an
2898 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2899 if (isym
&& isym
->elemental
2900 && (t
= scalarize_intrinsic_call (e
, true)))
2905 t
= gfc_simplify_expr (e
, 0);
2912 /* This occurs when parsing pdt templates. */
2913 if (gfc_expr_attr (e
).pdt_kind
)
2916 if (gfc_check_iter_variable (e
))
2919 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2921 /* A PARAMETER shall not be used to define itself, i.e.
2922 REAL, PARAMETER :: x = transfer(0, x)
2924 if (!e
->symtree
->n
.sym
->value
)
2926 gfc_error ("PARAMETER %qs is used at %L before its definition "
2927 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2931 t
= simplify_parameter_variable (e
, 0);
2936 if (gfc_in_match_data ())
2941 if (e
->symtree
->n
.sym
->as
)
2943 switch (e
->symtree
->n
.sym
->as
->type
)
2945 case AS_ASSUMED_SIZE
:
2946 gfc_error ("Assumed size array %qs at %L is not permitted "
2947 "in an initialization expression",
2948 e
->symtree
->n
.sym
->name
, &e
->where
);
2951 case AS_ASSUMED_SHAPE
:
2952 gfc_error ("Assumed shape array %qs at %L is not permitted "
2953 "in an initialization expression",
2954 e
->symtree
->n
.sym
->name
, &e
->where
);
2958 if (!e
->symtree
->n
.sym
->attr
.allocatable
2959 && !e
->symtree
->n
.sym
->attr
.pointer
2960 && e
->symtree
->n
.sym
->attr
.dummy
)
2961 gfc_error ("Assumed-shape array %qs at %L is not permitted "
2962 "in an initialization expression",
2963 e
->symtree
->n
.sym
->name
, &e
->where
);
2965 gfc_error ("Deferred array %qs at %L is not permitted "
2966 "in an initialization expression",
2967 e
->symtree
->n
.sym
->name
, &e
->where
);
2971 gfc_error ("Array %qs at %L is a variable, which does "
2972 "not reduce to a constant expression",
2973 e
->symtree
->n
.sym
->name
, &e
->where
);
2981 gfc_error ("Parameter %qs at %L has not been declared or is "
2982 "a variable, which does not reduce to a constant "
2983 "expression", e
->symtree
->name
, &e
->where
);
2992 case EXPR_SUBSTRING
:
2995 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2999 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
3001 t
= gfc_simplify_expr (e
, 0);
3007 case EXPR_STRUCTURE
:
3008 t
= e
->ts
.is_iso_c
? true : false;
3012 t
= check_alloc_comp_init (e
);
3016 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3023 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3027 t
= gfc_expand_constructor (e
, true);
3031 t
= gfc_check_constructor_type (e
);
3035 gfc_internal_error ("check_init_expr(): Unknown expression type");
3041 /* Reduces a general expression to an initialization expression (a constant).
3042 This used to be part of gfc_match_init_expr.
3043 Note that this function doesn't free the given expression on false. */
3046 gfc_reduce_init_expr (gfc_expr
*expr
)
3050 gfc_init_expr_flag
= true;
3051 t
= gfc_resolve_expr (expr
);
3053 t
= gfc_check_init_expr (expr
);
3054 gfc_init_expr_flag
= false;
3059 if (expr
->expr_type
== EXPR_ARRAY
)
3061 if (!gfc_check_constructor_type (expr
))
3063 if (!gfc_expand_constructor (expr
, true))
3071 /* Match an initialization expression. We work by first matching an
3072 expression, then reducing it to a constant. */
3075 gfc_match_init_expr (gfc_expr
**result
)
3083 gfc_init_expr_flag
= true;
3085 m
= gfc_match_expr (&expr
);
3088 gfc_init_expr_flag
= false;
3092 if (gfc_derived_parameter_expr (expr
))
3095 gfc_init_expr_flag
= false;
3099 t
= gfc_reduce_init_expr (expr
);
3102 gfc_free_expr (expr
);
3103 gfc_init_expr_flag
= false;
3108 gfc_init_expr_flag
= false;
3114 /* Given an actual argument list, test to see that each argument is a
3115 restricted expression and optionally if the expression type is
3116 integer or character. */
3119 restricted_args (gfc_actual_arglist
*a
)
3121 for (; a
; a
= a
->next
)
3123 if (!check_restricted (a
->expr
))
3131 /************* Restricted/specification expressions *************/
3134 /* Make sure a non-intrinsic function is a specification function,
3135 * see F08:7.1.11.5. */
3138 external_spec_function (gfc_expr
*e
)
3142 f
= e
->value
.function
.esym
;
3144 /* IEEE functions allowed are "a reference to a transformational function
3145 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3146 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3147 IEEE_EXCEPTIONS". */
3148 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3149 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3151 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3152 || !strcmp (f
->name
, "ieee_support_rounding")
3153 || !strcmp (f
->name
, "ieee_support_flag")
3154 || !strcmp (f
->name
, "ieee_support_halting")
3155 || !strcmp (f
->name
, "ieee_support_datatype")
3156 || !strcmp (f
->name
, "ieee_support_denormal")
3157 || !strcmp (f
->name
, "ieee_support_subnormal")
3158 || !strcmp (f
->name
, "ieee_support_divide")
3159 || !strcmp (f
->name
, "ieee_support_inf")
3160 || !strcmp (f
->name
, "ieee_support_io")
3161 || !strcmp (f
->name
, "ieee_support_nan")
3162 || !strcmp (f
->name
, "ieee_support_sqrt")
3163 || !strcmp (f
->name
, "ieee_support_standard")
3164 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3165 goto function_allowed
;
3168 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3170 gfc_error ("Specification function %qs at %L cannot be a statement "
3171 "function", f
->name
, &e
->where
);
3175 if (f
->attr
.proc
== PROC_INTERNAL
)
3177 gfc_error ("Specification function %qs at %L cannot be an internal "
3178 "function", f
->name
, &e
->where
);
3182 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3184 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3190 if (f
->attr
.recursive
3191 && !gfc_notify_std (GFC_STD_F2003
,
3192 "Specification function %qs "
3193 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3197 return restricted_args (e
->value
.function
.actual
);
3201 /* Check to see that a function reference to an intrinsic is a
3202 restricted expression. */
3205 restricted_intrinsic (gfc_expr
*e
)
3207 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3208 if (check_inquiry (e
, 0) == MATCH_YES
)
3211 return restricted_args (e
->value
.function
.actual
);
3215 /* Check the expressions of an actual arglist. Used by check_restricted. */
3218 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3220 for (; arg
; arg
= arg
->next
)
3221 if (!checker (arg
->expr
))
3228 /* Check the subscription expressions of a reference chain with a checking
3229 function; used by check_restricted. */
3232 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3242 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
3244 if (!checker (ref
->u
.ar
.start
[dim
]))
3246 if (!checker (ref
->u
.ar
.end
[dim
]))
3248 if (!checker (ref
->u
.ar
.stride
[dim
]))
3254 /* Nothing needed, just proceed to next reference. */
3258 if (!checker (ref
->u
.ss
.start
))
3260 if (!checker (ref
->u
.ss
.end
))
3269 return check_references (ref
->next
, checker
);
3272 /* Return true if ns is a parent of the current ns. */
3275 is_parent_of_current_ns (gfc_namespace
*ns
)
3278 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3285 /* Verify that an expression is a restricted expression. Like its
3286 cousin check_init_expr(), an error message is generated if we
3290 check_restricted (gfc_expr
*e
)
3298 switch (e
->expr_type
)
3301 t
= check_intrinsic_op (e
, check_restricted
);
3303 t
= gfc_simplify_expr (e
, 0);
3308 if (e
->value
.function
.esym
)
3310 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3312 t
= external_spec_function (e
);
3316 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3319 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3322 t
= restricted_intrinsic (e
);
3327 sym
= e
->symtree
->n
.sym
;
3330 /* If a dummy argument appears in a context that is valid for a
3331 restricted expression in an elemental procedure, it will have
3332 already been simplified away once we get here. Therefore we
3333 don't need to jump through hoops to distinguish valid from
3334 invalid cases. Allowed in F2008 and F2018. */
3335 if (gfc_notification_std (GFC_STD_F2008
)
3336 && sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3337 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3339 gfc_error_now ("Dummy argument %qs not "
3340 "allowed in expression at %L",
3341 sym
->name
, &e
->where
);
3345 if (sym
->attr
.optional
)
3347 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3348 sym
->name
, &e
->where
);
3352 if (sym
->attr
.intent
== INTENT_OUT
)
3354 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3355 sym
->name
, &e
->where
);
3359 /* Check reference chain if any. */
3360 if (!check_references (e
->ref
, &check_restricted
))
3363 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3364 processed in resolve.c(resolve_formal_arglist). This is done so
3365 that host associated dummy array indices are accepted (PR23446).
3366 This mechanism also does the same for the specification expressions
3367 of array-valued functions. */
3369 || sym
->attr
.in_common
3370 || sym
->attr
.use_assoc
3372 || sym
->attr
.implied_index
3373 || sym
->attr
.flavor
== FL_PARAMETER
3374 || is_parent_of_current_ns (sym
->ns
)
3375 || (sym
->ns
->proc_name
!= NULL
3376 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3377 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3383 gfc_error ("Variable %qs cannot appear in the expression at %L",
3384 sym
->name
, &e
->where
);
3385 /* Prevent a repetition of the error. */
3394 case EXPR_SUBSTRING
:
3395 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3399 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3401 t
= gfc_simplify_expr (e
, 0);
3405 case EXPR_STRUCTURE
:
3406 t
= gfc_check_constructor (e
, check_restricted
);
3410 t
= gfc_check_constructor (e
, check_restricted
);
3414 gfc_internal_error ("check_restricted(): Unknown expression type");
3421 /* Check to see that an expression is a specification expression. If
3422 we return false, an error has been generated. */
3425 gfc_specification_expr (gfc_expr
*e
)
3427 gfc_component
*comp
;
3432 if (e
->ts
.type
!= BT_INTEGER
)
3434 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3435 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3439 comp
= gfc_get_proc_ptr_comp (e
);
3440 if (e
->expr_type
== EXPR_FUNCTION
3441 && !e
->value
.function
.isym
3442 && !e
->value
.function
.esym
3443 && !gfc_pure (e
->symtree
->n
.sym
)
3444 && (!comp
|| !comp
->attr
.pure
))
3446 gfc_error ("Function %qs at %L must be PURE",
3447 e
->symtree
->n
.sym
->name
, &e
->where
);
3448 /* Prevent repeat error messages. */
3449 e
->symtree
->n
.sym
->attr
.pure
= 1;
3455 gfc_error ("Expression at %L must be scalar", &e
->where
);
3459 if (!gfc_simplify_expr (e
, 0))
3462 return check_restricted (e
);
3466 /************** Expression conformance checks. *************/
3468 /* Given two expressions, make sure that the arrays are conformable. */
3471 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3473 int op1_flag
, op2_flag
, d
;
3474 mpz_t op1_size
, op2_size
;
3480 if (op1
->rank
== 0 || op2
->rank
== 0)
3483 va_start (argp
, optype_msgid
);
3484 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3487 if (op1
->rank
!= op2
->rank
)
3489 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3490 op1
->rank
, op2
->rank
, &op1
->where
);
3496 for (d
= 0; d
< op1
->rank
; d
++)
3498 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3499 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3501 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3503 gfc_error ("Different shape for %s at %L on dimension %d "
3504 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3505 (int) mpz_get_si (op1_size
),
3506 (int) mpz_get_si (op2_size
));
3512 mpz_clear (op1_size
);
3514 mpz_clear (op2_size
);
3524 /* Given an assignable expression and an arbitrary expression, make
3525 sure that the assignment can take place. Only add a call to the intrinsic
3526 conversion routines, when allow_convert is set. When this assign is a
3527 coarray call, then the convert is done by the coarray routine implictly and
3528 adding the intrinsic conversion would do harm in most cases. */
3531 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3538 sym
= lvalue
->symtree
->n
.sym
;
3540 /* See if this is the component or subcomponent of a pointer and guard
3541 against assignment to LEN or KIND part-refs. */
3542 has_pointer
= sym
->attr
.pointer
;
3543 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3545 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3546 && ref
->u
.c
.component
->attr
.pointer
)
3548 else if (ref
->type
== REF_INQUIRY
3549 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3551 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3552 "allowed", &lvalue
->where
);
3557 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3558 variable local to a function subprogram. Its existence begins when
3559 execution of the function is initiated and ends when execution of the
3560 function is terminated...
3561 Therefore, the left hand side is no longer a variable, when it is: */
3562 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3563 && !sym
->attr
.external
)
3568 /* (i) Use associated; */
3569 if (sym
->attr
.use_assoc
)
3572 /* (ii) The assignment is in the main program; or */
3573 if (gfc_current_ns
->proc_name
3574 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3577 /* (iii) A module or internal procedure... */
3578 if (gfc_current_ns
->proc_name
3579 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3580 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3581 && gfc_current_ns
->parent
3582 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3583 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3584 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3586 /* ... that is not a function... */
3587 if (gfc_current_ns
->proc_name
3588 && !gfc_current_ns
->proc_name
->attr
.function
)
3591 /* ... or is not an entry and has a different name. */
3592 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3596 /* (iv) Host associated and not the function symbol or the
3597 parent result. This picks up sibling references, which
3598 cannot be entries. */
3599 if (!sym
->attr
.entry
3600 && sym
->ns
== gfc_current_ns
->parent
3601 && sym
!= gfc_current_ns
->proc_name
3602 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3607 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3613 /* Reject assigning to an external symbol. For initializers, this
3614 was already done before, in resolve_fl_procedure. */
3615 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
3616 && sym
->attr
.proc
!= PROC_MODULE
&& !rvalue
->error
)
3618 gfc_error ("Illegal assignment to external procedure at %L",
3624 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3626 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3627 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3631 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3633 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3638 if (rvalue
->expr_type
== EXPR_NULL
)
3640 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3641 && lvalue
->symtree
->n
.sym
->attr
.data
)
3645 gfc_error ("NULL appears on right-hand side in assignment at %L",
3651 /* This is possibly a typo: x = f() instead of x => f(). */
3653 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3654 gfc_warning (OPT_Wsurprising
,
3655 "POINTER-valued function appears on right-hand side of "
3656 "assignment at %L", &rvalue
->where
);
3658 /* Check size of array assignments. */
3659 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3660 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3663 /* Handle the case of a BOZ literal on the RHS. */
3664 if (rvalue
->ts
.type
== BT_BOZ
)
3666 if (lvalue
->symtree
->n
.sym
->attr
.data
)
3668 if (lvalue
->ts
.type
== BT_INTEGER
3669 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3672 if (lvalue
->ts
.type
== BT_REAL
3673 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3675 if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
3676 "be assigned to a REAL variable",
3683 if (!lvalue
->symtree
->n
.sym
->attr
.data
3684 && gfc_invalid_boz ("BOZ literal constant at %L is neither a "
3685 "data-stmt-constant nor an actual argument to "
3686 "INT, REAL, DBLE, or CMPLX intrinsic function",
3690 if (lvalue
->ts
.type
== BT_INTEGER
3691 && gfc_boz2int (rvalue
, lvalue
->ts
.kind
))
3694 if (lvalue
->ts
.type
== BT_REAL
3695 && gfc_boz2real (rvalue
, lvalue
->ts
.kind
))
3698 gfc_error ("BOZ literal constant near %L cannot be assigned to a "
3699 "%qs variable", &rvalue
->where
, gfc_typename (lvalue
));
3703 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3705 gfc_error ("The assignment to a KIND or LEN component of a "
3706 "parameterized type at %L is not allowed",
3711 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3714 /* Only DATA Statements come here. */
3719 /* Numeric can be converted to any other numeric. And Hollerith can be
3720 converted to any other type. */
3721 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3722 || rvalue
->ts
.type
== BT_HOLLERITH
)
3725 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3728 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3729 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3730 "conversion of %s to %s", where
,
3731 gfc_typename (rvalue
), gfc_typename (lvalue
));
3736 /* Assignment is the only case where character variables of different
3737 kind values can be converted into one another. */
3738 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3740 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3741 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3749 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3753 /* Check that a pointer assignment is OK. We first check lvalue, and
3754 we only check rvalue if it's not an assignment to NULL() or a
3755 NULLIFY statement. */
3758 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
3759 bool suppress_type_test
, bool is_init_expr
)
3761 symbol_attribute attr
, lhs_attr
;
3763 bool is_pure
, is_implicit_pure
, rank_remap
;
3767 lhs_attr
= gfc_expr_attr (lvalue
);
3768 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3770 gfc_error ("Pointer assignment target is not a POINTER at %L",
3775 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3776 && !lhs_attr
.proc_pointer
)
3778 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3779 "l-value since it is a procedure",
3780 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3784 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3787 same_rank
= lvalue
->rank
== rvalue
->rank
;
3788 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3790 if (ref
->type
== REF_COMPONENT
)
3791 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3793 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3797 if (ref
->u
.ar
.type
== AR_FULL
)
3800 if (ref
->u
.ar
.type
!= AR_SECTION
)
3802 gfc_error ("Expected bounds specification for %qs at %L",
3803 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3807 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3808 "for %qs in pointer assignment at %L",
3809 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3812 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3814 * (C1017) If bounds-spec-list is specified, the number of
3815 * bounds-specs shall equal the rank of data-pointer-object.
3817 * If bounds-spec-list appears, it specifies the lower bounds.
3819 * (C1018) If bounds-remapping-list is specified, the number of
3820 * bounds-remappings shall equal the rank of data-pointer-object.
3822 * If bounds-remapping-list appears, it specifies the upper and
3823 * lower bounds of each dimension of the pointer; the pointer target
3824 * shall be simply contiguous or of rank one.
3826 * (C1019) If bounds-remapping-list is not specified, the ranks of
3827 * data-pointer-object and data-target shall be the same.
3829 * Thus when bounds are given, all lbounds are necessary and either
3830 * all or none of the upper bounds; no strides are allowed. If the
3831 * upper bounds are present, we may do rank remapping. */
3832 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3834 if (ref
->u
.ar
.stride
[dim
])
3836 gfc_error ("Stride must not be present at %L",
3840 if (!same_rank
&& (!ref
->u
.ar
.start
[dim
] ||!ref
->u
.ar
.end
[dim
]))
3842 gfc_error ("Rank remapping requires a "
3843 "list of %<lower-bound : upper-bound%> "
3844 "specifications at %L", &lvalue
->where
);
3847 if (!ref
->u
.ar
.start
[dim
]
3848 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3850 gfc_error ("Expected list of %<lower-bound :%> or "
3851 "list of %<lower-bound : upper-bound%> "
3852 "specifications at %L", &lvalue
->where
);
3857 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3860 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
]))
3862 gfc_error ("Rank remapping requires a "
3863 "list of %<lower-bound : upper-bound%> "
3864 "specifications at %L", &lvalue
->where
);
3867 if (!rank_remap
&& ref
->u
.ar
.end
[dim
])
3869 gfc_error ("Expected list of %<lower-bound :%> or "
3870 "list of %<lower-bound : upper-bound%> "
3871 "specifications at %L", &lvalue
->where
);
3879 is_pure
= gfc_pure (NULL
);
3880 is_implicit_pure
= gfc_implicit_pure (NULL
);
3882 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3883 kind, etc for lvalue and rvalue must match, and rvalue must be a
3884 pure variable if we're in a pure function. */
3885 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3888 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3889 if (lvalue
->expr_type
== EXPR_VARIABLE
3890 && gfc_is_coindexed (lvalue
))
3893 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3894 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3896 gfc_error ("Pointer object at %L shall not have a coindex",
3902 /* Checks on rvalue for procedure pointer assignments. */
3907 gfc_component
*comp1
, *comp2
;
3910 attr
= gfc_expr_attr (rvalue
);
3911 if (!((rvalue
->expr_type
== EXPR_NULL
)
3912 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3913 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3914 || (rvalue
->expr_type
== EXPR_VARIABLE
3915 && attr
.flavor
== FL_PROCEDURE
)))
3917 gfc_error ("Invalid procedure pointer assignment at %L",
3922 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3924 /* Check for intrinsics. */
3925 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3926 if (!sym
->attr
.intrinsic
3927 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3928 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3930 sym
->attr
.intrinsic
= 1;
3931 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3932 attr
= gfc_expr_attr (rvalue
);
3934 /* Check for result of embracing function. */
3935 if (sym
->attr
.function
&& sym
->result
== sym
)
3939 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3940 if (sym
== ns
->proc_name
)
3942 gfc_error ("Function result %qs is invalid as proc-target "
3943 "in procedure pointer assignment at %L",
3944 sym
->name
, &rvalue
->where
);
3951 gfc_error ("Abstract interface %qs is invalid "
3952 "in procedure pointer assignment at %L",
3953 rvalue
->symtree
->name
, &rvalue
->where
);
3956 /* Check for F08:C729. */
3957 if (attr
.flavor
== FL_PROCEDURE
)
3959 if (attr
.proc
== PROC_ST_FUNCTION
)
3961 gfc_error ("Statement function %qs is invalid "
3962 "in procedure pointer assignment at %L",
3963 rvalue
->symtree
->name
, &rvalue
->where
);
3966 if (attr
.proc
== PROC_INTERNAL
&&
3967 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3968 "is invalid in procedure pointer assignment "
3969 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3971 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3972 attr
.subroutine
) == 0)
3974 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3975 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3979 /* Check for F08:C730. */
3980 if (attr
.elemental
&& !attr
.intrinsic
)
3982 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3983 "in procedure pointer assignment at %L",
3984 rvalue
->symtree
->name
, &rvalue
->where
);
3988 /* Ensure that the calling convention is the same. As other attributes
3989 such as DLLEXPORT may differ, one explicitly only tests for the
3990 calling conventions. */
3991 if (rvalue
->expr_type
== EXPR_VARIABLE
3992 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3993 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3995 symbol_attribute calls
;
3998 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3999 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
4000 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
4002 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
4003 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
4005 gfc_error ("Mismatch in the procedure pointer assignment "
4006 "at %L: mismatch in the calling convention",
4012 comp1
= gfc_get_proc_ptr_comp (lvalue
);
4014 s1
= comp1
->ts
.interface
;
4017 s1
= lvalue
->symtree
->n
.sym
;
4018 if (s1
->ts
.interface
)
4019 s1
= s1
->ts
.interface
;
4022 comp2
= gfc_get_proc_ptr_comp (rvalue
);
4025 if (rvalue
->expr_type
== EXPR_FUNCTION
)
4027 s2
= comp2
->ts
.interface
->result
;
4032 s2
= comp2
->ts
.interface
;
4036 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
4038 if (rvalue
->value
.function
.esym
)
4039 s2
= rvalue
->value
.function
.esym
->result
;
4041 s2
= rvalue
->symtree
->n
.sym
->result
;
4047 s2
= rvalue
->symtree
->n
.sym
;
4051 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
4052 s2
= s2
->ts
.interface
;
4054 /* Special check for the case of absent interface on the lvalue.
4055 * All other interface checks are done below. */
4056 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
4058 gfc_error ("Interface mismatch in procedure pointer assignment "
4059 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
4063 /* F08:7.2.2.4 (4) */
4064 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
4068 gfc_error ("Explicit interface required for component %qs at %L: %s",
4069 comp1
->name
, &lvalue
->where
, err
);
4072 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
4074 gfc_error ("Explicit interface required for %qs at %L: %s",
4075 s1
->name
, &lvalue
->where
, err
);
4079 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
4083 gfc_error ("Explicit interface required for component %qs at %L: %s",
4084 comp2
->name
, &rvalue
->where
, err
);
4087 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
4089 gfc_error ("Explicit interface required for %qs at %L: %s",
4090 s2
->name
, &rvalue
->where
, err
);
4095 if (s1
== s2
|| !s1
|| !s2
)
4098 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
4099 err
, sizeof(err
), NULL
, NULL
))
4101 gfc_error ("Interface mismatch in procedure pointer assignment "
4102 "at %L: %s", &rvalue
->where
, err
);
4106 /* Check F2008Cor2, C729. */
4107 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4108 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4110 gfc_error ("Procedure pointer target %qs at %L must be either an "
4111 "intrinsic, host or use associated, referenced or have "
4112 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4120 /* A non-proc pointer cannot point to a constant. */
4121 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4123 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4129 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4131 /* Check for F03:C717. */
4132 if (UNLIMITED_POLY (rvalue
)
4133 && !(UNLIMITED_POLY (lvalue
)
4134 || (lvalue
->ts
.type
== BT_DERIVED
4135 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4136 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4137 gfc_error ("Data-pointer-object at %L must be unlimited "
4138 "polymorphic, or of a type with the BIND or SEQUENCE "
4139 "attribute, to be compatible with an unlimited "
4140 "polymorphic target", &lvalue
->where
);
4141 else if (!suppress_type_test
)
4142 gfc_error ("Different types in pointer assignment at %L; "
4143 "attempted assignment of %s to %s", &lvalue
->where
,
4144 gfc_typename (rvalue
), gfc_typename (lvalue
));
4148 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4150 gfc_error ("Different kind type parameters in pointer "
4151 "assignment at %L", &lvalue
->where
);
4155 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4157 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4161 /* Make sure the vtab is present. */
4162 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4163 gfc_find_vtab (&rvalue
->ts
);
4165 /* Check rank remapping. */
4170 /* If this can be determined, check that the target must be at least as
4171 large as the pointer assigned to it is. */
4172 if (gfc_array_size (lvalue
, &lsize
)
4173 && gfc_array_size (rvalue
, &rsize
)
4174 && mpz_cmp (rsize
, lsize
) < 0)
4176 gfc_error ("Rank remapping target is smaller than size of the"
4177 " pointer (%ld < %ld) at %L",
4178 mpz_get_si (rsize
), mpz_get_si (lsize
),
4183 /* The target must be either rank one or it must be simply contiguous
4184 and F2008 must be allowed. */
4185 if (rvalue
->rank
!= 1)
4187 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4189 gfc_error ("Rank remapping target must be rank 1 or"
4190 " simply contiguous at %L", &rvalue
->where
);
4193 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4194 "rank 1 at %L", &rvalue
->where
))
4199 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4200 if (rvalue
->expr_type
== EXPR_NULL
)
4203 if (lvalue
->ts
.type
== BT_CHARACTER
)
4205 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4210 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4211 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4213 attr
= gfc_expr_attr (rvalue
);
4215 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4217 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4218 to caf_get. Map this to the same error message as below when it is
4219 still a variable expression. */
4220 if (rvalue
->value
.function
.isym
4221 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4222 /* The test above might need to be extend when F08, Note 5.4 has to be
4223 interpreted in the way that target and pointer with the same coindex
4225 gfc_error ("Data target at %L shall not have a coindex",
4228 gfc_error ("Target expression in pointer assignment "
4229 "at %L must deliver a pointer result",
4239 gcc_assert (rvalue
->symtree
);
4240 sym
= rvalue
->symtree
->n
.sym
;
4242 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4243 target
= CLASS_DATA (sym
)->attr
.target
;
4245 target
= sym
->attr
.target
;
4247 if (!target
&& !proc_pointer
)
4249 gfc_error ("Pointer assignment target in initialization expression "
4250 "does not have the TARGET attribute at %L",
4257 if (!attr
.target
&& !attr
.pointer
)
4259 gfc_error ("Pointer assignment target is neither TARGET "
4260 "nor POINTER at %L", &rvalue
->where
);
4265 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4267 gfc_error ("Bad target in pointer assignment in PURE "
4268 "procedure at %L", &rvalue
->where
);
4271 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4272 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4274 if (gfc_has_vector_index (rvalue
))
4276 gfc_error ("Pointer assignment with vector subscript "
4277 "on rhs at %L", &rvalue
->where
);
4281 if (attr
.is_protected
&& attr
.use_assoc
4282 && !(attr
.pointer
|| attr
.proc_pointer
))
4284 gfc_error ("Pointer assignment target has PROTECTED "
4285 "attribute at %L", &rvalue
->where
);
4289 /* F2008, C725. For PURE also C1283. */
4290 if (rvalue
->expr_type
== EXPR_VARIABLE
4291 && gfc_is_coindexed (rvalue
))
4294 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4295 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4297 gfc_error ("Data target at %L shall not have a coindex",
4303 /* Warn for assignments of contiguous pointers to targets which is not
4304 contiguous. Be lenient in the definition of what counts as
4307 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
4308 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4309 "non-contiguous target at %L", &rvalue
->where
);
4311 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4312 if (warn_target_lifetime
4313 && rvalue
->expr_type
== EXPR_VARIABLE
4314 && !rvalue
->symtree
->n
.sym
->attr
.save
4315 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4316 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4317 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4318 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4319 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4324 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4325 || lvalue
->symtree
->n
.sym
->attr
.result
4326 || lvalue
->symtree
->n
.sym
->attr
.function
4327 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4328 && lvalue
->symtree
->n
.sym
->ns
4329 != rvalue
->symtree
->n
.sym
->ns
)
4330 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4331 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4333 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4334 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4335 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4336 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4337 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4339 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4346 gfc_warning (OPT_Wtarget_lifetime
,
4347 "Pointer at %L in pointer assignment might outlive the "
4348 "pointer target", &lvalue
->where
);
4355 /* Relative of gfc_check_assign() except that the lvalue is a single
4356 symbol. Used for initialization assignments. */
4359 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4363 bool pointer
, proc_pointer
;
4365 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4367 lvalue
.expr_type
= EXPR_VARIABLE
;
4368 lvalue
.ts
= sym
->ts
;
4370 lvalue
.rank
= sym
->as
->rank
;
4371 lvalue
.symtree
= XCNEW (gfc_symtree
);
4372 lvalue
.symtree
->n
.sym
= sym
;
4373 lvalue
.where
= sym
->declared_at
;
4377 lvalue
.ref
= gfc_get_ref ();
4378 lvalue
.ref
->type
= REF_COMPONENT
;
4379 lvalue
.ref
->u
.c
.component
= comp
;
4380 lvalue
.ref
->u
.c
.sym
= sym
;
4381 lvalue
.ts
= comp
->ts
;
4382 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4383 lvalue
.where
= comp
->loc
;
4384 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4385 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4386 proc_pointer
= comp
->attr
.proc_pointer
;
4390 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4391 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4392 proc_pointer
= sym
->attr
.proc_pointer
;
4395 if (pointer
|| proc_pointer
)
4396 r
= gfc_check_pointer_assign (&lvalue
, rvalue
, false, true);
4399 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4400 into an array constructor, we should check if it can be reduced
4401 as an initialization expression. */
4402 if (rvalue
->expr_type
== EXPR_FUNCTION
4403 && rvalue
->value
.function
.isym
4404 && (rvalue
->value
.function
.isym
->conversion
== 1))
4405 gfc_check_init_expr (rvalue
);
4407 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4410 free (lvalue
.symtree
);
4416 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
&& !proc_pointer
)
4418 /* F08:C461. Additional checks for pointer initialization. */
4419 symbol_attribute attr
;
4420 attr
= gfc_expr_attr (rvalue
);
4421 if (attr
.allocatable
)
4423 gfc_error ("Pointer initialization target at %L "
4424 "must not be ALLOCATABLE", &rvalue
->where
);
4427 if (!attr
.target
|| attr
.pointer
)
4429 gfc_error ("Pointer initialization target at %L "
4430 "must have the TARGET attribute", &rvalue
->where
);
4434 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4435 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4436 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4438 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4439 attr
.save
= SAVE_IMPLICIT
;
4444 gfc_error ("Pointer initialization target at %L "
4445 "must have the SAVE attribute", &rvalue
->where
);
4450 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4452 /* F08:C1220. Additional checks for procedure pointer initialization. */
4453 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4454 if (attr
.proc_pointer
)
4456 gfc_error ("Procedure pointer initialization target at %L "
4457 "may not be a procedure pointer", &rvalue
->where
);
4460 if (attr
.proc
== PROC_INTERNAL
)
4462 gfc_error ("Internal procedure %qs is invalid in "
4463 "procedure pointer initialization at %L",
4464 rvalue
->symtree
->name
, &rvalue
->where
);
4469 gfc_error ("Dummy procedure %qs is invalid in "
4470 "procedure pointer initialization at %L",
4471 rvalue
->symtree
->name
, &rvalue
->where
);
4479 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4480 * require that an expression be built. */
4483 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4485 return gfc_build_init_expr (ts
, where
, false);
4488 /* Build an initializer for a local integer, real, complex, logical, or
4489 character variable, based on the command line flags finit-local-zero,
4490 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4491 With force, an initializer is ALWAYS generated. */
4494 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4496 gfc_expr
*init_expr
;
4498 /* Try to build an initializer expression. */
4499 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4501 /* If we want to force generation, make sure we default to zero. */
4502 gfc_init_local_real init_real
= flag_init_real
;
4503 int init_logical
= gfc_option
.flag_init_logical
;
4506 if (init_real
== GFC_INIT_REAL_OFF
)
4507 init_real
= GFC_INIT_REAL_ZERO
;
4508 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4509 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4512 /* We will only initialize integers, reals, complex, logicals, and
4513 characters, and only if the corresponding command-line flags
4514 were set. Otherwise, we free init_expr and return null. */
4518 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4519 mpz_set_si (init_expr
->value
.integer
,
4520 gfc_option
.flag_init_integer_value
);
4523 gfc_free_expr (init_expr
);
4531 case GFC_INIT_REAL_SNAN
:
4532 init_expr
->is_snan
= 1;
4534 case GFC_INIT_REAL_NAN
:
4535 mpfr_set_nan (init_expr
->value
.real
);
4538 case GFC_INIT_REAL_INF
:
4539 mpfr_set_inf (init_expr
->value
.real
, 1);
4542 case GFC_INIT_REAL_NEG_INF
:
4543 mpfr_set_inf (init_expr
->value
.real
, -1);
4546 case GFC_INIT_REAL_ZERO
:
4547 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4551 gfc_free_expr (init_expr
);
4560 case GFC_INIT_REAL_SNAN
:
4561 init_expr
->is_snan
= 1;
4563 case GFC_INIT_REAL_NAN
:
4564 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4565 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4568 case GFC_INIT_REAL_INF
:
4569 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4570 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4573 case GFC_INIT_REAL_NEG_INF
:
4574 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4575 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4578 case GFC_INIT_REAL_ZERO
:
4579 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4583 gfc_free_expr (init_expr
);
4590 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4591 init_expr
->value
.logical
= 0;
4592 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4593 init_expr
->value
.logical
= 1;
4596 gfc_free_expr (init_expr
);
4602 /* For characters, the length must be constant in order to
4603 create a default initializer. */
4604 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4606 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4608 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4609 init_expr
->value
.character
.length
= char_len
;
4610 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4611 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4612 init_expr
->value
.character
.string
[i
]
4613 = (unsigned char) gfc_option
.flag_init_character_value
;
4617 gfc_free_expr (init_expr
);
4621 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4622 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4624 gfc_actual_arglist
*arg
;
4625 init_expr
= gfc_get_expr ();
4626 init_expr
->where
= *where
;
4627 init_expr
->ts
= *ts
;
4628 init_expr
->expr_type
= EXPR_FUNCTION
;
4629 init_expr
->value
.function
.isym
=
4630 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4631 init_expr
->value
.function
.name
= "repeat";
4632 arg
= gfc_get_actual_arglist ();
4633 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4634 arg
->expr
->value
.character
.string
[0] =
4635 gfc_option
.flag_init_character_value
;
4636 arg
->next
= gfc_get_actual_arglist ();
4637 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4638 init_expr
->value
.function
.actual
= arg
;
4643 gfc_free_expr (init_expr
);
4650 /* Apply an initialization expression to a typespec. Can be used for symbols or
4651 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4652 combined with some effort. */
4655 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4657 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4660 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4661 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4663 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4665 if (init
->expr_type
== EXPR_CONSTANT
)
4666 gfc_set_constant_character_len (len
, init
, -1);
4668 && init
->ts
.type
== BT_CHARACTER
4669 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4670 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4671 init
->ts
.u
.cl
->length
->value
.integer
))
4673 gfc_constructor
*ctor
;
4674 ctor
= gfc_constructor_first (init
->value
.constructor
);
4678 bool has_ts
= (init
->ts
.u
.cl
4679 && init
->ts
.u
.cl
->length_from_typespec
);
4681 /* Remember the length of the first element for checking
4682 that all elements *in the constructor* have the same
4683 length. This need not be the length of the LHS! */
4684 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4685 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4686 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4688 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4689 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4691 gfc_set_constant_character_len (len
, ctor
->expr
,
4692 has_ts
? -1 : first_len
);
4693 if (!ctor
->expr
->ts
.u
.cl
)
4695 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4697 ctor
->expr
->ts
.u
.cl
->length
4698 = gfc_copy_expr (ts
->u
.cl
->length
);
4706 /* Check whether an expression is a structure constructor and whether it has
4707 other values than NULL. */
4710 is_non_empty_structure_constructor (gfc_expr
* e
)
4712 if (e
->expr_type
!= EXPR_STRUCTURE
)
4715 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4718 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4720 cons
= gfc_constructor_next (cons
);
4726 /* Check for default initializer; sym->value is not enough
4727 as it is also set for EXPR_NULL of allocatables. */
4730 gfc_has_default_initializer (gfc_symbol
*der
)
4734 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4735 for (c
= der
->components
; c
; c
= c
->next
)
4736 if (gfc_bt_struct (c
->ts
.type
))
4738 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4739 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4741 && is_non_empty_structure_constructor (c
->initializer
))
4742 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4744 if (c
->attr
.pointer
&& c
->initializer
)
4758 Generate an initializer expression which initializes the entirety of a union.
4759 A normal structure constructor is insufficient without undue effort, because
4760 components of maps may be oddly aligned/overlapped. (For example if a
4761 character is initialized from one map overtop a real from the other, only one
4762 byte of the real is actually initialized.) Unfortunately we don't know the
4763 size of the union right now, so we can't generate a proper initializer, but
4764 we use a NULL expr as a placeholder and do the right thing later in
4765 gfc_trans_subcomponent_assign.
4768 generate_union_initializer (gfc_component
*un
)
4770 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4773 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4774 placeholder
->ts
= un
->ts
;
4779 /* Get the user-specified initializer for a union, if any. This means the user
4780 has said to initialize component(s) of a map. For simplicity's sake we
4781 only allow the user to initialize the first map. We don't have to worry
4782 about overlapping initializers as they are released early in resolution (see
4783 resolve_fl_struct). */
4786 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4789 gfc_expr
*init
=NULL
;
4791 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4794 for (map
= union_type
->components
; map
; map
= map
->next
)
4796 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4798 init
= gfc_default_initializer (&map
->ts
);
4812 class_allocatable (gfc_component
*comp
)
4814 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4815 && CLASS_DATA (comp
)->attr
.allocatable
;
4819 class_pointer (gfc_component
*comp
)
4821 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4822 && CLASS_DATA (comp
)->attr
.pointer
;
4826 comp_allocatable (gfc_component
*comp
)
4828 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4832 comp_pointer (gfc_component
*comp
)
4834 return comp
->attr
.pointer
4835 || comp
->attr
.proc_pointer
4836 || comp
->attr
.class_pointer
4837 || class_pointer (comp
);
4840 /* Fetch or generate an initializer for the given component.
4841 Only generate an initializer if generate is true. */
4844 component_initializer (gfc_component
*c
, bool generate
)
4846 gfc_expr
*init
= NULL
;
4848 /* Allocatable components always get EXPR_NULL.
4849 Pointer components are only initialized when generating, and only if they
4850 do not already have an initializer. */
4851 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4853 init
= gfc_get_null_expr (&c
->loc
);
4858 /* See if we can find the initializer immediately. */
4859 if (c
->initializer
|| !generate
)
4860 return c
->initializer
;
4862 /* Recursively handle derived type components. */
4863 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4864 init
= gfc_generate_initializer (&c
->ts
, true);
4866 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4868 gfc_component
*map
= NULL
;
4869 gfc_constructor
*ctor
;
4870 gfc_expr
*user_init
;
4872 /* If we don't have a user initializer and we aren't generating one, this
4873 union has no initializer. */
4874 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4875 if (!user_init
&& !generate
)
4878 /* Otherwise use a structure constructor. */
4879 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4883 /* If we are to generate an initializer for the union, add a constructor
4884 which initializes the whole union first. */
4887 ctor
= gfc_constructor_get ();
4888 ctor
->expr
= generate_union_initializer (c
);
4889 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4892 /* If we found an initializer in one of our maps, apply it. Note this
4893 is applied _after_ the entire-union initializer above if any. */
4896 ctor
= gfc_constructor_get ();
4897 ctor
->expr
= user_init
;
4898 ctor
->n
.component
= map
;
4899 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4903 /* Treat simple components like locals. */
4906 /* We MUST give an initializer, so force generation. */
4907 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4908 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4915 /* Get an expression for a default initializer of a derived type. */
4918 gfc_default_initializer (gfc_typespec
*ts
)
4920 return gfc_generate_initializer (ts
, false);
4923 /* Generate an initializer expression for an iso_c_binding type
4924 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
4927 generate_isocbinding_initializer (gfc_symbol
*derived
)
4929 /* The initializers have already been built into the c_null_[fun]ptr symbols
4930 from gen_special_c_interop_ptr. */
4931 gfc_symtree
*npsym
= NULL
;
4932 if (0 == strcmp (derived
->name
, "c_ptr"))
4933 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
4934 else if (0 == strcmp (derived
->name
, "c_funptr"))
4935 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
4937 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
4938 " type, expected %<c_ptr%> or %<c_funptr%>");
4941 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
4942 init
->symtree
= npsym
;
4943 init
->ts
.is_iso_c
= true;
4950 /* Get or generate an expression for a default initializer of a derived type.
4951 If -finit-derived is specified, generate default initialization expressions
4952 for components that lack them when generate is set. */
4955 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4957 gfc_expr
*init
, *tmp
;
4958 gfc_component
*comp
;
4960 generate
= flag_init_derived
&& generate
;
4962 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
4963 return generate_isocbinding_initializer (ts
->u
.derived
);
4965 /* See if we have a default initializer in this, but not in nested
4966 types (otherwise we could use gfc_has_default_initializer()).
4967 We don't need to check if we are going to generate them. */
4968 comp
= ts
->u
.derived
->components
;
4971 for (; comp
; comp
= comp
->next
)
4972 if (comp
->initializer
|| comp_allocatable (comp
))
4979 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4980 &ts
->u
.derived
->declared_at
);
4983 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4985 gfc_constructor
*ctor
= gfc_constructor_get();
4987 /* Fetch or generate an initializer for the component. */
4988 tmp
= component_initializer (comp
, generate
);
4991 /* Save the component ref for STRUCTUREs and UNIONs. */
4992 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4993 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4994 ctor
->n
.component
= comp
;
4996 /* If the initializer was not generated, we need a copy. */
4997 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4998 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
4999 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
5002 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
5008 gfc_constructor_append (&init
->value
.constructor
, ctor
);
5015 /* Given a symbol, create an expression node with that symbol as a
5016 variable. If the symbol is array valued, setup a reference of the
5020 gfc_get_variable_expr (gfc_symtree
*var
)
5024 e
= gfc_get_expr ();
5025 e
->expr_type
= EXPR_VARIABLE
;
5027 e
->ts
= var
->n
.sym
->ts
;
5029 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
5030 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
5031 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
5032 && CLASS_DATA (var
->n
.sym
)->as
)))
5034 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
5035 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
5036 e
->ref
= gfc_get_ref ();
5037 e
->ref
->type
= REF_ARRAY
;
5038 e
->ref
->u
.ar
.type
= AR_FULL
;
5039 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
5040 ? CLASS_DATA (var
->n
.sym
)->as
5048 /* Adds a full array reference to an expression, as needed. */
5051 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
5054 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5059 ref
->next
= gfc_get_ref ();
5064 e
->ref
= gfc_get_ref ();
5067 ref
->type
= REF_ARRAY
;
5068 ref
->u
.ar
.type
= AR_FULL
;
5069 ref
->u
.ar
.dimen
= e
->rank
;
5070 ref
->u
.ar
.where
= e
->where
;
5076 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
5080 lval
= gfc_get_expr ();
5081 lval
->expr_type
= EXPR_VARIABLE
;
5082 lval
->where
= sym
->declared_at
;
5084 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5086 /* It will always be a full array. */
5087 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5088 lval
->rank
= as
? as
->rank
: 0;
5090 gfc_add_full_array_ref (lval
, as
);
5095 /* Returns the array_spec of a full array expression. A NULL is
5096 returned otherwise. */
5098 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
5103 if (expr
->rank
== 0)
5106 /* Follow any component references. */
5107 if (expr
->expr_type
== EXPR_VARIABLE
5108 || expr
->expr_type
== EXPR_CONSTANT
)
5111 as
= expr
->symtree
->n
.sym
->as
;
5115 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5120 as
= ref
->u
.c
.component
->as
;
5129 switch (ref
->u
.ar
.type
)
5152 /* General expression traversal function. */
5155 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5156 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5161 gfc_actual_arglist
*args
;
5168 if ((*func
) (expr
, sym
, &f
))
5171 if (expr
->ts
.type
== BT_CHARACTER
5173 && expr
->ts
.u
.cl
->length
5174 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5175 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5178 switch (expr
->expr_type
)
5183 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5185 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5193 case EXPR_SUBSTRING
:
5196 case EXPR_STRUCTURE
:
5198 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5199 c
; c
= gfc_constructor_next (c
))
5201 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5205 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5207 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5209 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5211 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5218 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5220 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5236 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5238 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5240 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5242 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5248 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5250 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5255 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5256 && ref
->u
.c
.component
->ts
.u
.cl
5257 && ref
->u
.c
.component
->ts
.u
.cl
->length
5258 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5260 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5264 if (ref
->u
.c
.component
->as
)
5265 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5266 + ref
->u
.c
.component
->as
->corank
; i
++)
5268 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5271 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5288 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5291 expr_set_symbols_referenced (gfc_expr
*expr
,
5292 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5293 int *f ATTRIBUTE_UNUSED
)
5295 if (expr
->expr_type
!= EXPR_VARIABLE
)
5297 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5302 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5304 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5308 /* Determine if an expression is a procedure pointer component and return
5309 the component in that case. Otherwise return NULL. */
5312 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5316 if (!expr
|| !expr
->ref
)
5323 if (ref
->type
== REF_COMPONENT
5324 && ref
->u
.c
.component
->attr
.proc_pointer
)
5325 return ref
->u
.c
.component
;
5331 /* Determine if an expression is a procedure pointer component. */
5334 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5336 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5340 /* Determine if an expression is a function with an allocatable class scalar
5343 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5345 if (expr
->expr_type
== EXPR_FUNCTION
5346 && expr
->value
.function
.esym
5347 && expr
->value
.function
.esym
->result
5348 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5349 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5350 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5357 /* Determine if an expression is a function with an allocatable class array
5360 gfc_is_class_array_function (gfc_expr
*expr
)
5362 if (expr
->expr_type
== EXPR_FUNCTION
5363 && expr
->value
.function
.esym
5364 && expr
->value
.function
.esym
->result
5365 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5366 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5367 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5368 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5375 /* Walk an expression tree and check each variable encountered for being typed.
5376 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5377 mode as is a basic arithmetic expression using those; this is for things in
5380 INTEGER :: arr(n), n
5381 INTEGER :: arr(n + 1), n
5383 The namespace is needed for IMPLICIT typing. */
5385 static gfc_namespace
* check_typed_ns
;
5388 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5389 int* f ATTRIBUTE_UNUSED
)
5393 if (e
->expr_type
!= EXPR_VARIABLE
)
5396 gcc_assert (e
->symtree
);
5397 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5404 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5408 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5412 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5413 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5415 if (e
->expr_type
== EXPR_OP
)
5419 gcc_assert (e
->value
.op
.op1
);
5420 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5422 if (t
&& e
->value
.op
.op2
)
5423 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5429 /* Otherwise, walk the expression and do it strictly. */
5430 check_typed_ns
= ns
;
5431 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5433 return error_found
? false : true;
5437 /* This function returns true if it contains any references to PDT KIND
5438 or LEN parameters. */
5441 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5442 int* f ATTRIBUTE_UNUSED
)
5444 if (e
->expr_type
!= EXPR_VARIABLE
)
5447 gcc_assert (e
->symtree
);
5448 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5449 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5457 gfc_derived_parameter_expr (gfc_expr
*e
)
5459 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5463 /* This function returns the overall type of a type parameter spec list.
5464 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5465 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5466 unless derived is not NULL. In this latter case, all the LEN parameters
5467 must be either assumed or deferred for the return argument to be set to
5468 anything other than SPEC_EXPLICIT. */
5471 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5473 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5475 bool seen_assumed
= false;
5476 bool seen_deferred
= false;
5478 if (derived
== NULL
)
5480 for (; param_list
; param_list
= param_list
->next
)
5481 if (param_list
->spec_type
== SPEC_ASSUMED
5482 || param_list
->spec_type
== SPEC_DEFERRED
)
5483 return param_list
->spec_type
;
5487 for (; param_list
; param_list
= param_list
->next
)
5489 c
= gfc_find_component (derived
, param_list
->name
,
5491 gcc_assert (c
!= NULL
);
5492 if (c
->attr
.pdt_kind
)
5494 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5495 return SPEC_EXPLICIT
;
5496 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5497 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5498 if (seen_assumed
&& seen_deferred
)
5499 return SPEC_EXPLICIT
;
5501 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5508 gfc_ref_this_image (gfc_ref
*ref
)
5512 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5514 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5515 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5522 gfc_find_team_co (gfc_expr
*e
)
5526 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5527 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5528 return ref
->u
.ar
.team
;
5530 if (e
->value
.function
.actual
->expr
)
5531 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5533 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5534 return ref
->u
.ar
.team
;
5540 gfc_find_stat_co (gfc_expr
*e
)
5544 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5545 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5546 return ref
->u
.ar
.stat
;
5548 if (e
->value
.function
.actual
->expr
)
5549 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5551 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5552 return ref
->u
.ar
.stat
;
5558 gfc_is_coindexed (gfc_expr
*e
)
5562 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5563 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5564 return !gfc_ref_this_image (ref
);
5570 /* Coarrays are variables with a corank but not being coindexed. However, also
5571 the following is a coarray: A subobject of a coarray is a coarray if it does
5572 not have any cosubscripts, vector subscripts, allocatable component
5573 selection, or pointer component selection. (F2008, 2.4.7) */
5576 gfc_is_coarray (gfc_expr
*e
)
5580 gfc_component
*comp
;
5585 if (e
->expr_type
!= EXPR_VARIABLE
)
5589 sym
= e
->symtree
->n
.sym
;
5591 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5592 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5594 coarray
= sym
->attr
.codimension
;
5596 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5600 comp
= ref
->u
.c
.component
;
5601 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5602 && (CLASS_DATA (comp
)->attr
.class_pointer
5603 || CLASS_DATA (comp
)->attr
.allocatable
))
5606 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5608 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5611 coarray
= comp
->attr
.codimension
;
5619 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5625 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5626 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5638 return coarray
&& !coindexed
;
5643 gfc_get_corank (gfc_expr
*e
)
5648 if (!gfc_is_coarray (e
))
5651 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5652 corank
= e
->ts
.u
.derived
->components
->as
5653 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5655 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5657 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5659 if (ref
->type
== REF_ARRAY
)
5660 corank
= ref
->u
.ar
.as
->corank
;
5661 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5668 /* Check whether the expression has an ultimate allocatable component.
5669 Being itself allocatable does not count. */
5671 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5673 gfc_ref
*ref
, *last
= NULL
;
5675 if (e
->expr_type
!= EXPR_VARIABLE
)
5678 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5679 if (ref
->type
== REF_COMPONENT
)
5682 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5683 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5684 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5685 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5689 if (e
->ts
.type
== BT_CLASS
)
5690 return CLASS_DATA (e
)->attr
.alloc_comp
;
5691 else if (e
->ts
.type
== BT_DERIVED
)
5692 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5698 /* Check whether the expression has an pointer component.
5699 Being itself a pointer does not count. */
5701 gfc_has_ultimate_pointer (gfc_expr
*e
)
5703 gfc_ref
*ref
, *last
= NULL
;
5705 if (e
->expr_type
!= EXPR_VARIABLE
)
5708 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5709 if (ref
->type
== REF_COMPONENT
)
5712 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5713 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5714 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5715 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5719 if (e
->ts
.type
== BT_CLASS
)
5720 return CLASS_DATA (e
)->attr
.pointer_comp
;
5721 else if (e
->ts
.type
== BT_DERIVED
)
5722 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5728 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5729 Note: A scalar is not regarded as "simply contiguous" by the standard.
5730 if bool is not strict, some further checks are done - for instance,
5731 a "(::1)" is accepted. */
5734 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5738 gfc_array_ref
*ar
= NULL
;
5739 gfc_ref
*ref
, *part_ref
= NULL
;
5742 if (expr
->expr_type
== EXPR_ARRAY
)
5745 if (expr
->expr_type
== EXPR_FUNCTION
)
5747 if (expr
->value
.function
.esym
)
5748 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5751 /* Type-bound procedures. */
5752 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5753 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5757 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5758 if (r
->type
== REF_COMPONENT
)
5761 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5762 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5765 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5768 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5771 if (!permit_element
&& expr
->rank
== 0)
5774 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5777 return false; /* Array shall be last part-ref. */
5779 if (ref
->type
== REF_COMPONENT
)
5781 else if (ref
->type
== REF_SUBSTRING
)
5783 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5787 sym
= expr
->symtree
->n
.sym
;
5788 if (expr
->ts
.type
!= BT_CLASS
5790 && !part_ref
->u
.c
.component
->attr
.contiguous
5791 && part_ref
->u
.c
.component
->attr
.pointer
)
5793 && !sym
->attr
.contiguous
5794 && (sym
->attr
.pointer
5795 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5796 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5799 if (!ar
|| ar
->type
== AR_FULL
)
5802 gcc_assert (ar
->type
== AR_SECTION
);
5804 /* Check for simply contiguous array */
5806 for (i
= 0; i
< ar
->dimen
; i
++)
5808 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5811 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5817 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5820 /* If the previous section was not contiguous, that's an error,
5821 unless we have effective only one element and checking is not
5823 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5824 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5825 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5826 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5827 ar
->end
[i
]->value
.integer
) != 0))
5830 /* Following the standard, "(::1)" or - if known at compile time -
5831 "(lbound:ubound)" are not simply contiguous; if strict
5832 is false, they are regarded as simply contiguous. */
5833 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5834 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5835 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5839 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5840 || !ar
->as
->lower
[i
]
5841 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5842 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5843 ar
->as
->lower
[i
]->value
.integer
) != 0))
5847 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5848 || !ar
->as
->upper
[i
]
5849 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5850 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5851 ar
->as
->upper
[i
]->value
.integer
) != 0))
5858 /* Return true if the expression is guaranteed to be non-contiguous,
5859 false if we cannot prove anything. It is probably best to call
5860 this after gfc_is_simply_contiguous. If neither of them returns
5861 true, we cannot say (at compile-time). */
5864 gfc_is_not_contiguous (gfc_expr
*array
)
5867 gfc_array_ref
*ar
= NULL
;
5869 bool previous_incomplete
;
5871 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
5873 /* Array-ref shall be last ref. */
5878 if (ref
->type
== REF_ARRAY
)
5882 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
5885 previous_incomplete
= false;
5887 /* Check if we can prove that the array is not contiguous. */
5889 for (i
= 0; i
< ar
->dimen
; i
++)
5891 mpz_t arr_size
, ref_size
;
5893 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
5895 if (gfc_dep_difference (ar
->as
->lower
[i
], ar
->as
->upper
[i
], &arr_size
))
5897 /* a(2:4,2:) is known to be non-contiguous, but
5898 a(2:4,i:i) can be contiguous. */
5899 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
5901 mpz_clear (arr_size
);
5902 mpz_clear (ref_size
);
5905 else if (mpz_cmp (arr_size
, ref_size
) != 0)
5906 previous_incomplete
= true;
5908 mpz_clear (arr_size
);
5911 /* Check for a(::2), i.e. where the stride is not unity.
5912 This is only done if there is more than one element in
5913 the reference along this dimension. */
5915 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
5916 && ar
->dimen_type
[i
] == DIMEN_RANGE
5917 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5918 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
5921 mpz_clear (ref_size
);
5924 /* We didn't find anything definitive. */
5928 /* Build call to an intrinsic procedure. The number of arguments has to be
5929 passed (rather than ending the list with a NULL value) because we may
5930 want to add arguments but with a NULL-expression. */
5933 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5934 locus where
, unsigned numarg
, ...)
5937 gfc_actual_arglist
* atail
;
5938 gfc_intrinsic_sym
* isym
;
5941 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5943 isym
= gfc_intrinsic_function_by_id (id
);
5946 result
= gfc_get_expr ();
5947 result
->expr_type
= EXPR_FUNCTION
;
5948 result
->ts
= isym
->ts
;
5949 result
->where
= where
;
5950 result
->value
.function
.name
= mangled_name
;
5951 result
->value
.function
.isym
= isym
;
5953 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5954 gfc_commit_symbol (result
->symtree
->n
.sym
);
5955 gcc_assert (result
->symtree
5956 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5957 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5958 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5959 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5960 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5961 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5963 va_start (ap
, numarg
);
5965 for (i
= 0; i
< numarg
; ++i
)
5969 atail
->next
= gfc_get_actual_arglist ();
5970 atail
= atail
->next
;
5973 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5975 atail
->expr
= va_arg (ap
, gfc_expr
*);
5983 /* Check if an expression may appear in a variable definition context
5984 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5985 This is called from the various places when resolving
5986 the pieces that make up such a context.
5987 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5988 variables), some checks are not performed.
5990 Optionally, a possible error message can be suppressed if context is NULL
5991 and just the return status (true / false) be requested. */
5994 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5995 bool own_scope
, const char* context
)
5997 gfc_symbol
* sym
= NULL
;
5999 bool check_intentin
;
6001 symbol_attribute attr
;
6005 if (e
->expr_type
== EXPR_VARIABLE
)
6007 gcc_assert (e
->symtree
);
6008 sym
= e
->symtree
->n
.sym
;
6010 else if (e
->expr_type
== EXPR_FUNCTION
)
6012 gcc_assert (e
->symtree
);
6013 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
6016 attr
= gfc_expr_attr (e
);
6017 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
6019 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
6022 gfc_error ("Fortran 2008: Pointer functions in variable definition"
6023 " context (%s) at %L", context
, &e
->where
);
6027 else if (e
->expr_type
!= EXPR_VARIABLE
)
6030 gfc_error ("Non-variable expression in variable definition context (%s)"
6031 " at %L", context
, &e
->where
);
6035 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
6038 gfc_error ("Named constant %qs in variable definition context (%s)"
6039 " at %L", sym
->name
, context
, &e
->where
);
6042 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
6043 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
6044 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
6047 gfc_error ("%qs in variable definition context (%s) at %L is not"
6048 " a variable", sym
->name
, context
, &e
->where
);
6052 /* Find out whether the expr is a pointer; this also means following
6053 component references to the last one. */
6054 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
6055 if (pointer
&& !is_pointer
)
6058 gfc_error ("Non-POINTER in pointer association context (%s)"
6059 " at %L", context
, &e
->where
);
6063 if (e
->ts
.type
== BT_DERIVED
6064 && e
->ts
.u
.derived
== NULL
)
6067 gfc_error ("Type inaccessible in variable definition context (%s) "
6068 "at %L", context
, &e
->where
);
6075 || (e
->ts
.type
== BT_DERIVED
6076 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6077 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
6080 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6081 context
, &e
->where
);
6085 /* TS18508, C702/C203. */
6088 || (e
->ts
.type
== BT_DERIVED
6089 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6090 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
6093 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6094 context
, &e
->where
);
6098 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6099 component of sub-component of a pointer; we need to distinguish
6100 assignment to a pointer component from pointer-assignment to a pointer
6101 component. Note that (normal) assignment to procedure pointers is not
6103 check_intentin
= !own_scope
;
6104 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
6105 && CLASS_DATA (sym
))
6106 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
6107 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
6109 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
6110 check_intentin
= false;
6111 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
6113 ptr_component
= true;
6115 check_intentin
= false;
6120 && (sym
->attr
.intent
== INTENT_IN
6121 || (sym
->attr
.select_type_temporary
&& sym
->assoc
6122 && sym
->assoc
->target
&& sym
->assoc
->target
->symtree
6123 && sym
->assoc
->target
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)))
6125 if (pointer
&& is_pointer
)
6128 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6129 " association context (%s) at %L",
6130 sym
->name
, context
, &e
->where
);
6133 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
6135 const char *name
= sym
->attr
.select_type_temporary
6136 ? sym
->assoc
->target
->symtree
->name
: sym
->name
;
6138 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6139 " definition context (%s) at %L",
6140 name
, context
, &e
->where
);
6145 /* PROTECTED and use-associated. */
6146 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
6148 if (pointer
&& is_pointer
)
6151 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6152 " pointer association context (%s) at %L",
6153 sym
->name
, context
, &e
->where
);
6156 if (!pointer
&& !is_pointer
)
6159 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6160 " variable definition context (%s) at %L",
6161 sym
->name
, context
, &e
->where
);
6166 /* Variable not assignable from a PURE procedure but appears in
6167 variable definition context. */
6168 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6171 gfc_error ("Variable %qs cannot appear in a variable definition"
6172 " context (%s) at %L in PURE procedure",
6173 sym
->name
, context
, &e
->where
);
6177 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6178 && gfc_impure_variable (sym
))
6183 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6185 sym
= ns
->proc_name
;
6188 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6190 sym
->attr
.implicit_pure
= 0;
6195 /* Check variable definition context for associate-names. */
6196 if (!pointer
&& sym
->assoc
&& !sym
->attr
.select_rank_temporary
)
6199 gfc_association_list
* assoc
;
6201 gcc_assert (sym
->assoc
->target
);
6203 /* If this is a SELECT TYPE temporary (the association is used internally
6204 for SELECT TYPE), silently go over to the target. */
6205 if (sym
->attr
.select_type_temporary
)
6207 gfc_expr
* t
= sym
->assoc
->target
;
6209 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6210 name
= t
->symtree
->name
;
6212 if (t
->symtree
->n
.sym
->assoc
)
6213 assoc
= t
->symtree
->n
.sym
->assoc
;
6222 gcc_assert (name
&& assoc
);
6224 /* Is association to a valid variable? */
6225 if (!assoc
->variable
)
6229 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6230 gfc_error ("%qs at %L associated to vector-indexed target"
6231 " cannot be used in a variable definition"
6233 name
, &e
->where
, context
);
6235 gfc_error ("%qs at %L associated to expression"
6236 " cannot be used in a variable definition"
6238 name
, &e
->where
, context
);
6243 /* Target must be allowed to appear in a variable definition context. */
6244 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6247 gfc_error ("Associate-name %qs cannot appear in a variable"
6248 " definition context (%s) at %L because its target"
6249 " at %L cannot, either",
6250 name
, context
, &e
->where
,
6251 &assoc
->target
->where
);
6256 /* Check for same value in vector expression subscript. */
6259 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6260 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6261 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6262 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6263 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6265 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6266 if (arr
->expr_type
== EXPR_ARRAY
)
6268 gfc_constructor
*c
, *n
;
6271 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6272 c
!= NULL
; c
= gfc_constructor_next (c
))
6274 if (c
== NULL
|| c
->iterator
!= NULL
)
6279 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6280 n
= gfc_constructor_next (n
))
6282 if (n
->iterator
!= NULL
)
6286 if (gfc_dep_compare_expr (ec
, en
) == 0)
6289 gfc_error_now ("Elements with the same value "
6290 "at %L and %L in vector "
6291 "subscript in a variable "
6292 "definition context (%s)",
6293 &(ec
->where
), &(en
->where
),