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. */
347 /* Should never be reached. */
349 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
356 switch (q
->value
.op
.op
)
359 case INTRINSIC_PARENTHESES
:
360 case INTRINSIC_UPLUS
:
361 case INTRINSIC_UMINUS
:
362 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
365 default: /* Binary operators. */
366 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
367 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
374 q
->value
.function
.actual
=
375 gfc_copy_actual_arglist (p
->value
.function
.actual
);
380 q
->value
.compcall
.actual
=
381 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
382 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
387 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
398 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
400 q
->ref
= gfc_copy_ref (p
->ref
);
403 q
->param_list
= gfc_copy_actual_arglist (p
->param_list
);
410 gfc_clear_shape (mpz_t
*shape
, int rank
)
414 for (i
= 0; i
< rank
; i
++)
415 mpz_clear (shape
[i
]);
420 gfc_free_shape (mpz_t
**shape
, int rank
)
425 gfc_clear_shape (*shape
, rank
);
431 /* Workhorse function for gfc_free_expr() that frees everything
432 beneath an expression node, but not the node itself. This is
433 useful when we want to simplify a node and replace it with
434 something else or the expression node belongs to another structure. */
437 free_expr0 (gfc_expr
*e
)
439 switch (e
->expr_type
)
442 /* Free any parts of the value that need freeing. */
446 mpz_clear (e
->value
.integer
);
450 mpfr_clear (e
->value
.real
);
454 free (e
->value
.character
.string
);
458 mpc_clear (e
->value
.complex);
465 /* Free the representation. */
466 free (e
->representation
.string
);
471 if (e
->value
.op
.op1
!= NULL
)
472 gfc_free_expr (e
->value
.op
.op1
);
473 if (e
->value
.op
.op2
!= NULL
)
474 gfc_free_expr (e
->value
.op
.op2
);
478 gfc_free_actual_arglist (e
->value
.function
.actual
);
483 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
491 gfc_constructor_free (e
->value
.constructor
);
495 free (e
->value
.character
.string
);
502 gfc_internal_error ("free_expr0(): Bad expr type");
505 /* Free a shape array. */
506 gfc_free_shape (&e
->shape
, e
->rank
);
508 gfc_free_ref_list (e
->ref
);
510 gfc_free_actual_arglist (e
->param_list
);
512 memset (e
, '\0', sizeof (gfc_expr
));
516 /* Free an expression node and everything beneath it. */
519 gfc_free_expr (gfc_expr
*e
)
528 /* Free an argument list and everything below it. */
531 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
533 gfc_actual_arglist
*a2
;
539 gfc_free_expr (a1
->expr
);
546 /* Copy an arglist structure and all of the arguments. */
549 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
551 gfc_actual_arglist
*head
, *tail
, *new_arg
;
555 for (; p
; p
= p
->next
)
557 new_arg
= gfc_get_actual_arglist ();
560 new_arg
->expr
= gfc_copy_expr (p
->expr
);
561 new_arg
->next
= NULL
;
566 tail
->next
= new_arg
;
575 /* Free a list of reference structures. */
578 gfc_free_ref_list (gfc_ref
*p
)
590 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
592 gfc_free_expr (p
->u
.ar
.start
[i
]);
593 gfc_free_expr (p
->u
.ar
.end
[i
]);
594 gfc_free_expr (p
->u
.ar
.stride
[i
]);
600 gfc_free_expr (p
->u
.ss
.start
);
601 gfc_free_expr (p
->u
.ss
.end
);
614 /* Graft the *src expression onto the *dest subexpression. */
617 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
625 /* Try to extract an integer constant from the passed expression node.
626 Return true if some error occurred, false on success. If REPORT_ERROR
627 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
628 for negative using gfc_error_now. */
631 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
635 /* A KIND component is a parameter too. The expression for it
636 is stored in the initializer and should be consistent with
638 if (gfc_expr_attr(expr
).pdt_kind
)
640 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
642 if (ref
->u
.c
.component
->attr
.pdt_kind
)
643 expr
= ref
->u
.c
.component
->initializer
;
647 if (expr
->expr_type
!= EXPR_CONSTANT
)
649 if (report_error
> 0)
650 gfc_error ("Constant expression required at %C");
651 else if (report_error
< 0)
652 gfc_error_now ("Constant expression required at %C");
656 if (expr
->ts
.type
!= BT_INTEGER
)
658 if (report_error
> 0)
659 gfc_error ("Integer expression required at %C");
660 else if (report_error
< 0)
661 gfc_error_now ("Integer expression required at %C");
665 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
666 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
668 if (report_error
> 0)
669 gfc_error ("Integer value too large in expression at %C");
670 else if (report_error
< 0)
671 gfc_error_now ("Integer value too large in expression at %C");
675 *result
= (int) mpz_get_si (expr
->value
.integer
);
681 /* Same as gfc_extract_int, but use a HWI. */
684 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
, int report_error
)
688 /* A KIND component is a parameter too. The expression for it is
689 stored in the initializer and should be consistent with the tests
691 if (gfc_expr_attr(expr
).pdt_kind
)
693 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
695 if (ref
->u
.c
.component
->attr
.pdt_kind
)
696 expr
= ref
->u
.c
.component
->initializer
;
700 if (expr
->expr_type
!= EXPR_CONSTANT
)
702 if (report_error
> 0)
703 gfc_error ("Constant expression required at %C");
704 else if (report_error
< 0)
705 gfc_error_now ("Constant expression required at %C");
709 if (expr
->ts
.type
!= BT_INTEGER
)
711 if (report_error
> 0)
712 gfc_error ("Integer expression required at %C");
713 else if (report_error
< 0)
714 gfc_error_now ("Integer expression required at %C");
718 /* Use long_long_integer_type_node to determine when to saturate. */
719 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
720 expr
->value
.integer
, false);
722 if (!wi::fits_shwi_p (val
))
724 if (report_error
> 0)
725 gfc_error ("Integer value too large in expression at %C");
726 else if (report_error
< 0)
727 gfc_error_now ("Integer value too large in expression at %C");
731 *result
= val
.to_shwi ();
737 /* Recursively copy a list of reference structures. */
740 gfc_copy_ref (gfc_ref
*src
)
748 dest
= gfc_get_ref ();
749 dest
->type
= src
->type
;
754 ar
= gfc_copy_array_ref (&src
->u
.ar
);
760 dest
->u
.c
= src
->u
.c
;
764 dest
->u
.i
= src
->u
.i
;
768 dest
->u
.ss
= src
->u
.ss
;
769 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
770 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
774 dest
->next
= gfc_copy_ref (src
->next
);
780 /* Detect whether an expression has any vector index array references. */
783 gfc_has_vector_index (gfc_expr
*e
)
787 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
788 if (ref
->type
== REF_ARRAY
)
789 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
790 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
796 /* Copy a shape array. */
799 gfc_copy_shape (mpz_t
*shape
, int rank
)
807 new_shape
= gfc_get_shape (rank
);
809 for (n
= 0; n
< rank
; n
++)
810 mpz_init_set (new_shape
[n
], shape
[n
]);
816 /* Copy a shape array excluding dimension N, where N is an integer
817 constant expression. Dimensions are numbered in Fortran style --
820 So, if the original shape array contains R elements
821 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
822 the result contains R-1 elements:
823 { s1 ... sN-1 sN+1 ... sR-1}
825 If anything goes wrong -- N is not a constant, its value is out
826 of range -- or anything else, just returns NULL. */
829 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
831 mpz_t
*new_shape
, *s
;
837 || dim
->expr_type
!= EXPR_CONSTANT
838 || dim
->ts
.type
!= BT_INTEGER
)
841 n
= mpz_get_si (dim
->value
.integer
);
842 n
--; /* Convert to zero based index. */
843 if (n
< 0 || n
>= rank
)
846 s
= new_shape
= gfc_get_shape (rank
- 1);
848 for (i
= 0; i
< rank
; i
++)
852 mpz_init_set (*s
, shape
[i
]);
860 /* Return the maximum kind of two expressions. In general, higher
861 kind numbers mean more precision for numeric types. */
864 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
866 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
870 /* Returns nonzero if the type is numeric, zero otherwise. */
873 numeric_type (bt type
)
875 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
879 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
882 gfc_numeric_ts (gfc_typespec
*ts
)
884 return numeric_type (ts
->type
);
888 /* Return an expression node with an optional argument list attached.
889 A variable number of gfc_expr pointers are strung together in an
890 argument list with a NULL pointer terminating the list. */
893 gfc_build_conversion (gfc_expr
*e
)
898 p
->expr_type
= EXPR_FUNCTION
;
900 p
->value
.function
.actual
= gfc_get_actual_arglist ();
901 p
->value
.function
.actual
->expr
= e
;
907 /* Given an expression node with some sort of numeric binary
908 expression, insert type conversions required to make the operands
909 have the same type. Conversion warnings are disabled if wconversion
912 The exception is that the operands of an exponential don't have to
913 have the same type. If possible, the base is promoted to the type
914 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
915 1.0**2 stays as it is. */
918 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
922 op1
= e
->value
.op
.op1
;
923 op2
= e
->value
.op
.op2
;
925 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
927 gfc_clear_ts (&e
->ts
);
931 /* Kind conversions of same type. */
932 if (op1
->ts
.type
== op2
->ts
.type
)
934 if (op1
->ts
.kind
== op2
->ts
.kind
)
936 /* No type conversions. */
941 if (op1
->ts
.kind
> op2
->ts
.kind
)
942 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
944 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
950 /* Integer combined with real or complex. */
951 if (op2
->ts
.type
== BT_INTEGER
)
955 /* Special case for ** operator. */
956 if (e
->value
.op
.op
== INTRINSIC_POWER
)
959 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
963 if (op1
->ts
.type
== BT_INTEGER
)
966 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
970 /* Real combined with complex. */
971 e
->ts
.type
= BT_COMPLEX
;
972 if (op1
->ts
.kind
> op2
->ts
.kind
)
973 e
->ts
.kind
= op1
->ts
.kind
;
975 e
->ts
.kind
= op2
->ts
.kind
;
976 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
977 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
978 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
979 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
986 /* Determine if an expression is constant in the sense of F08:7.1.12.
987 * This function expects that the expression has already been simplified. */
990 gfc_is_constant_expr (gfc_expr
*e
)
993 gfc_actual_arglist
*arg
;
998 switch (e
->expr_type
)
1001 return (gfc_is_constant_expr (e
->value
.op
.op1
)
1002 && (e
->value
.op
.op2
== NULL
1003 || gfc_is_constant_expr (e
->value
.op
.op2
)));
1006 /* The only context in which this can occur is in a parameterized
1007 derived type declaration, so returning true is OK. */
1008 if (e
->symtree
->n
.sym
->attr
.pdt_len
1009 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1016 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1017 || e
->value
.function
.isym
);
1019 /* Call to intrinsic with at least one argument. */
1020 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1022 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1023 if (!gfc_is_constant_expr (arg
->expr
))
1027 if (e
->value
.function
.isym
1028 && (e
->value
.function
.isym
->elemental
1029 || e
->value
.function
.isym
->pure
1030 || e
->value
.function
.isym
->inquiry
1031 || e
->value
.function
.isym
->transformational
))
1040 case EXPR_SUBSTRING
:
1041 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1042 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1045 case EXPR_STRUCTURE
:
1046 c
= gfc_constructor_first (e
->value
.constructor
);
1047 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1048 return gfc_constant_ac (e
);
1050 for (; c
; c
= gfc_constructor_next (c
))
1051 if (!gfc_is_constant_expr (c
->expr
))
1058 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1064 /* Is true if the expression or symbol is a passed CFI descriptor. */
1066 is_CFI_desc (gfc_symbol
*sym
, gfc_expr
*e
)
1069 && e
&& e
->expr_type
== EXPR_VARIABLE
)
1070 sym
= e
->symtree
->n
.sym
;
1072 if (sym
&& sym
->attr
.dummy
1073 && sym
->ns
->proc_name
->attr
.is_bind_c
1074 && sym
->attr
.dimension
1075 && (sym
->attr
.pointer
1076 || sym
->attr
.allocatable
1077 || sym
->as
->type
== AS_ASSUMED_SHAPE
1078 || sym
->as
->type
== AS_ASSUMED_RANK
))
1085 /* Is true if an array reference is followed by a component or substring
1088 is_subref_array (gfc_expr
* e
)
1094 if (e
->expr_type
!= EXPR_VARIABLE
)
1097 sym
= e
->symtree
->n
.sym
;
1099 if (sym
->attr
.subref_array_pointer
)
1104 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1106 /* If we haven't seen the array reference and this is an intrinsic,
1107 what follows cannot be a subreference array, unless there is a
1108 substring reference. */
1109 if (!seen_array
&& ref
->type
== REF_COMPONENT
1110 && ref
->u
.c
.component
->ts
.type
!= BT_CHARACTER
1111 && ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1112 && !gfc_bt_struct (ref
->u
.c
.component
->ts
.type
))
1115 if (ref
->type
== REF_ARRAY
1116 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1120 && ref
->type
!= REF_ARRAY
)
1124 if (sym
->ts
.type
== BT_CLASS
1126 && CLASS_DATA (sym
)->attr
.dimension
1127 && CLASS_DATA (sym
)->attr
.class_pointer
)
1134 /* Try to collapse intrinsic expressions. */
1137 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1139 gfc_intrinsic_op op
;
1140 gfc_expr
*op1
, *op2
, *result
;
1142 if (p
->value
.op
.op
== INTRINSIC_USER
)
1145 op1
= p
->value
.op
.op1
;
1146 op2
= p
->value
.op
.op2
;
1147 op
= p
->value
.op
.op
;
1149 if (!gfc_simplify_expr (op1
, type
))
1151 if (!gfc_simplify_expr (op2
, type
))
1154 if (!gfc_is_constant_expr (op1
)
1155 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1159 p
->value
.op
.op1
= NULL
;
1160 p
->value
.op
.op2
= NULL
;
1164 case INTRINSIC_PARENTHESES
:
1165 result
= gfc_parentheses (op1
);
1168 case INTRINSIC_UPLUS
:
1169 result
= gfc_uplus (op1
);
1172 case INTRINSIC_UMINUS
:
1173 result
= gfc_uminus (op1
);
1176 case INTRINSIC_PLUS
:
1177 result
= gfc_add (op1
, op2
);
1180 case INTRINSIC_MINUS
:
1181 result
= gfc_subtract (op1
, op2
);
1184 case INTRINSIC_TIMES
:
1185 result
= gfc_multiply (op1
, op2
);
1188 case INTRINSIC_DIVIDE
:
1189 result
= gfc_divide (op1
, op2
);
1192 case INTRINSIC_POWER
:
1193 result
= gfc_power (op1
, op2
);
1196 case INTRINSIC_CONCAT
:
1197 result
= gfc_concat (op1
, op2
);
1201 case INTRINSIC_EQ_OS
:
1202 result
= gfc_eq (op1
, op2
, op
);
1206 case INTRINSIC_NE_OS
:
1207 result
= gfc_ne (op1
, op2
, op
);
1211 case INTRINSIC_GT_OS
:
1212 result
= gfc_gt (op1
, op2
, op
);
1216 case INTRINSIC_GE_OS
:
1217 result
= gfc_ge (op1
, op2
, op
);
1221 case INTRINSIC_LT_OS
:
1222 result
= gfc_lt (op1
, op2
, op
);
1226 case INTRINSIC_LE_OS
:
1227 result
= gfc_le (op1
, op2
, op
);
1231 result
= gfc_not (op1
);
1235 result
= gfc_and (op1
, op2
);
1239 result
= gfc_or (op1
, op2
);
1243 result
= gfc_eqv (op1
, op2
);
1246 case INTRINSIC_NEQV
:
1247 result
= gfc_neqv (op1
, op2
);
1251 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1256 gfc_free_expr (op1
);
1257 gfc_free_expr (op2
);
1261 result
->rank
= p
->rank
;
1262 result
->where
= p
->where
;
1263 gfc_replace_expr (p
, result
);
1269 /* Subroutine to simplify constructor expressions. Mutually recursive
1270 with gfc_simplify_expr(). */
1273 simplify_constructor (gfc_constructor_base base
, int type
)
1278 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1281 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1282 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1283 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1288 /* Try and simplify a copy. Replace the original if successful
1289 but keep going through the constructor at all costs. Not
1290 doing so can make a dog's dinner of complicated things. */
1291 p
= gfc_copy_expr (c
->expr
);
1293 if (!gfc_simplify_expr (p
, type
))
1299 gfc_replace_expr (c
->expr
, p
);
1307 /* Pull a single array element out of an array constructor. */
1310 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1311 gfc_constructor
**rval
)
1313 unsigned long nelemen
;
1319 gfc_constructor
*cons
;
1326 mpz_init_set_ui (offset
, 0);
1329 mpz_init_set_ui (span
, 1);
1330 for (i
= 0; i
< ar
->dimen
; i
++)
1332 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1333 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1341 if (e
->expr_type
!= EXPR_CONSTANT
)
1347 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1348 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1350 /* Check the bounds. */
1351 if ((ar
->as
->upper
[i
]
1352 && mpz_cmp (e
->value
.integer
,
1353 ar
->as
->upper
[i
]->value
.integer
) > 0)
1354 || (mpz_cmp (e
->value
.integer
,
1355 ar
->as
->lower
[i
]->value
.integer
) < 0))
1357 gfc_error ("Index in dimension %d is out of bounds "
1358 "at %L", i
+ 1, &ar
->c_where
[i
]);
1364 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1365 mpz_mul (delta
, delta
, span
);
1366 mpz_add (offset
, offset
, delta
);
1368 mpz_set_ui (tmp
, 1);
1369 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1370 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1371 mpz_mul (span
, span
, tmp
);
1374 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1375 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1394 /* Find a component of a structure constructor. */
1396 static gfc_constructor
*
1397 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1399 gfc_component
*pick
= ref
->u
.c
.component
;
1400 gfc_constructor
*c
= gfc_constructor_first (base
);
1402 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1403 int ext
= dt
->attr
.extension
;
1405 /* For extended types, check if the desired component is in one of the
1407 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1408 pick
->name
, true, true, NULL
))
1410 dt
= dt
->components
->ts
.u
.derived
;
1411 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1415 gfc_component
*comp
= dt
->components
;
1416 while (comp
!= pick
)
1419 c
= gfc_constructor_next (c
);
1426 /* Replace an expression with the contents of a constructor, removing
1427 the subobject reference in the process. */
1430 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1440 e
= gfc_copy_expr (p
);
1441 e
->ref
= p
->ref
->next
;
1442 p
->ref
->next
= NULL
;
1443 gfc_replace_expr (p
, e
);
1447 /* Pull an array section out of an array constructor. */
1450 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1457 long unsigned one
= 1;
1459 mpz_t start
[GFC_MAX_DIMENSIONS
];
1460 mpz_t end
[GFC_MAX_DIMENSIONS
];
1461 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1462 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1463 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1468 gfc_constructor_base base
;
1469 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1479 base
= expr
->value
.constructor
;
1480 expr
->value
.constructor
= NULL
;
1482 rank
= ref
->u
.ar
.as
->rank
;
1484 if (expr
->shape
== NULL
)
1485 expr
->shape
= gfc_get_shape (rank
);
1487 mpz_init_set_ui (delta_mpz
, one
);
1488 mpz_init_set_ui (nelts
, one
);
1491 /* Do the initialization now, so that we can cleanup without
1492 keeping track of where we were. */
1493 for (d
= 0; d
< rank
; d
++)
1495 mpz_init (delta
[d
]);
1496 mpz_init (start
[d
]);
1499 mpz_init (stride
[d
]);
1503 /* Build the counters to clock through the array reference. */
1505 for (d
= 0; d
< rank
; d
++)
1507 /* Make this stretch of code easier on the eye! */
1508 begin
= ref
->u
.ar
.start
[d
];
1509 finish
= ref
->u
.ar
.end
[d
];
1510 step
= ref
->u
.ar
.stride
[d
];
1511 lower
= ref
->u
.ar
.as
->lower
[d
];
1512 upper
= ref
->u
.ar
.as
->upper
[d
];
1514 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1516 gfc_constructor
*ci
;
1519 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1525 gcc_assert (begin
->rank
== 1);
1526 /* Zero-sized arrays have no shape and no elements, stop early. */
1529 mpz_init_set_ui (nelts
, 0);
1533 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1534 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1535 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1536 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1539 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1541 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1542 || mpz_cmp (ci
->expr
->value
.integer
,
1543 lower
->value
.integer
) < 0)
1545 gfc_error ("index in dimension %d is out of bounds "
1546 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1554 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1555 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1556 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1562 /* Obtain the stride. */
1564 mpz_set (stride
[d
], step
->value
.integer
);
1566 mpz_set_ui (stride
[d
], one
);
1568 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1569 mpz_set_ui (stride
[d
], one
);
1571 /* Obtain the start value for the index. */
1573 mpz_set (start
[d
], begin
->value
.integer
);
1575 mpz_set (start
[d
], lower
->value
.integer
);
1577 mpz_set (ctr
[d
], start
[d
]);
1579 /* Obtain the end value for the index. */
1581 mpz_set (end
[d
], finish
->value
.integer
);
1583 mpz_set (end
[d
], upper
->value
.integer
);
1585 /* Separate 'if' because elements sometimes arrive with
1587 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1588 mpz_set (end
[d
], begin
->value
.integer
);
1590 /* Check the bounds. */
1591 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1592 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1593 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1594 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1596 gfc_error ("index in dimension %d is out of bounds "
1597 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1602 /* Calculate the number of elements and the shape. */
1603 mpz_set (tmp_mpz
, stride
[d
]);
1604 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1605 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1606 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1607 mpz_mul (nelts
, nelts
, tmp_mpz
);
1609 /* An element reference reduces the rank of the expression; don't
1610 add anything to the shape array. */
1611 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1612 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1615 /* Calculate the 'stride' (=delta) for conversion of the
1616 counter values into the index along the constructor. */
1617 mpz_set (delta
[d
], delta_mpz
);
1618 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1619 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1620 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1624 cons
= gfc_constructor_first (base
);
1626 /* Now clock through the array reference, calculating the index in
1627 the source constructor and transferring the elements to the new
1629 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1631 mpz_init_set_ui (ptr
, 0);
1634 for (d
= 0; d
< rank
; d
++)
1636 mpz_set (tmp_mpz
, ctr
[d
]);
1637 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1638 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1639 mpz_add (ptr
, ptr
, tmp_mpz
);
1641 if (!incr_ctr
) continue;
1643 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1645 gcc_assert(vecsub
[d
]);
1647 if (!gfc_constructor_next (vecsub
[d
]))
1648 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1651 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1654 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1658 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1660 if (mpz_cmp_ui (stride
[d
], 0) > 0
1661 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1662 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1663 mpz_set (ctr
[d
], start
[d
]);
1669 limit
= mpz_get_ui (ptr
);
1670 if (limit
>= flag_max_array_constructor
)
1672 gfc_error ("The number of elements in the array constructor "
1673 "at %L requires an increase of the allowed %d "
1674 "upper limit. See %<-fmax-array-constructor%> "
1675 "option", &expr
->where
, flag_max_array_constructor
);
1679 cons
= gfc_constructor_lookup (base
, limit
);
1681 gfc_constructor_append_expr (&expr
->value
.constructor
,
1682 gfc_copy_expr (cons
->expr
), NULL
);
1689 mpz_clear (delta_mpz
);
1690 mpz_clear (tmp_mpz
);
1692 for (d
= 0; d
< rank
; d
++)
1694 mpz_clear (delta
[d
]);
1695 mpz_clear (start
[d
]);
1698 mpz_clear (stride
[d
]);
1700 gfc_constructor_free (base
);
1704 /* Pull a substring out of an expression. */
1707 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1710 gfc_charlen_t start
;
1711 gfc_charlen_t length
;
1714 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1715 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1718 *newp
= gfc_copy_expr (p
);
1719 free ((*newp
)->value
.character
.string
);
1721 end
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1722 start
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1724 length
= end
- start
+ 1;
1728 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1729 (*newp
)->value
.character
.length
= length
;
1730 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1731 length
* sizeof (gfc_char_t
));
1737 /* Pull an inquiry result out of an expression. */
1740 find_inquiry_ref (gfc_expr
*p
, gfc_expr
**newp
)
1743 gfc_ref
*inquiry
= NULL
;
1746 tmp
= gfc_copy_expr (p
);
1748 if (tmp
->ref
&& tmp
->ref
->type
== REF_INQUIRY
)
1755 for (ref
= tmp
->ref
; ref
; ref
= ref
->next
)
1756 if (ref
->next
&& ref
->next
->type
== REF_INQUIRY
)
1758 inquiry
= ref
->next
;
1765 gfc_free_expr (tmp
);
1769 gfc_resolve_expr (tmp
);
1771 /* In principle there can be more than one inquiry reference. */
1772 for (; inquiry
; inquiry
= inquiry
->next
)
1774 switch (inquiry
->u
.i
)
1777 if (tmp
->ts
.type
!= BT_CHARACTER
)
1780 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1783 if (!tmp
->ts
.u
.cl
->length
1784 || tmp
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1787 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1791 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1794 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1797 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1798 NULL
, tmp
->ts
.kind
);
1802 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1805 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1808 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1809 mpfr_set ((*newp
)->value
.real
,
1810 mpc_realref (p
->value
.complex), GFC_RND_MODE
);
1814 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1817 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1820 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1821 mpfr_set ((*newp
)->value
.real
,
1822 mpc_imagref (p
->value
.complex), GFC_RND_MODE
);
1825 tmp
= gfc_copy_expr (*newp
);
1830 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1832 gfc_free_expr (*newp
);
1836 gfc_free_expr (tmp
);
1840 gfc_free_expr (tmp
);
1846 /* Simplify a subobject reference of a constructor. This occurs when
1847 parameter variable values are substituted. */
1850 simplify_const_ref (gfc_expr
*p
)
1852 gfc_constructor
*cons
, *c
;
1853 gfc_expr
*newp
= NULL
;
1858 switch (p
->ref
->type
)
1861 switch (p
->ref
->u
.ar
.type
)
1864 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1865 will generate this. */
1866 if (p
->expr_type
!= EXPR_ARRAY
)
1868 remove_subobject_ref (p
, NULL
);
1871 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1877 remove_subobject_ref (p
, cons
);
1881 if (!find_array_section (p
, p
->ref
))
1883 p
->ref
->u
.ar
.type
= AR_FULL
;
1888 if (p
->ref
->next
!= NULL
1889 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1891 for (c
= gfc_constructor_first (p
->value
.constructor
);
1892 c
; c
= gfc_constructor_next (c
))
1894 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1895 if (!simplify_const_ref (c
->expr
))
1899 if (gfc_bt_struct (p
->ts
.type
)
1901 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1903 /* There may have been component references. */
1904 p
->ts
= c
->expr
->ts
;
1908 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1910 if (p
->ts
.type
== BT_CHARACTER
1911 && last_ref
->type
== REF_SUBSTRING
)
1913 /* If this is a CHARACTER array and we possibly took
1914 a substring out of it, update the type-spec's
1915 character length according to the first element
1916 (as all should have the same length). */
1917 gfc_charlen_t string_len
;
1918 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1920 const gfc_expr
* first
= c
->expr
;
1921 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1922 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1923 string_len
= first
->value
.character
.length
;
1931 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1934 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
,
1938 gfc_free_expr (p
->ts
.u
.cl
->length
);
1941 = gfc_get_int_expr (gfc_charlen_int_kind
,
1945 gfc_free_ref_list (p
->ref
);
1956 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1957 remove_subobject_ref (p
, cons
);
1961 if (!find_inquiry_ref (p
, &newp
))
1964 gfc_replace_expr (p
, newp
);
1965 gfc_free_ref_list (p
->ref
);
1970 if (!find_substring_ref (p
, &newp
))
1973 gfc_replace_expr (p
, newp
);
1974 gfc_free_ref_list (p
->ref
);
1984 /* Simplify a chain of references. */
1987 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
1992 for (; ref
; ref
= ref
->next
)
1997 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1999 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
2001 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
2003 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
2009 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
2011 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
2016 if (!find_inquiry_ref (*p
, &newp
))
2019 gfc_replace_expr (*p
, newp
);
2020 gfc_free_ref_list ((*p
)->ref
);
2032 /* Try to substitute the value of a parameter variable. */
2035 simplify_parameter_variable (gfc_expr
*p
, int type
)
2040 if (gfc_is_size_zero_array (p
))
2042 if (p
->expr_type
== EXPR_ARRAY
)
2045 e
= gfc_get_expr ();
2046 e
->expr_type
= EXPR_ARRAY
;
2049 e
->value
.constructor
= NULL
;
2050 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2051 e
->where
= p
->where
;
2052 gfc_replace_expr (p
, e
);
2056 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2062 /* Do not copy subobject refs for constant. */
2063 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2064 e
->ref
= gfc_copy_ref (p
->ref
);
2065 t
= gfc_simplify_expr (e
, type
);
2067 /* Only use the simplification if it eliminated all subobject references. */
2069 gfc_replace_expr (p
, e
);
2078 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2080 /* Given an expression, simplify it by collapsing constant
2081 expressions. Most simplification takes place when the expression
2082 tree is being constructed. If an intrinsic function is simplified
2083 at some point, we get called again to collapse the result against
2086 We work by recursively simplifying expression nodes, simplifying
2087 intrinsic functions where possible, which can lead to further
2088 constant collapsing. If an operator has constant operand(s), we
2089 rip the expression apart, and rebuild it, hoping that it becomes
2092 The expression type is defined for:
2093 0 Basic expression parsing
2094 1 Simplifying array constructors -- will substitute
2096 Returns false on error, true otherwise.
2097 NOTE: Will return true even if the expression cannot be simplified. */
2100 gfc_simplify_expr (gfc_expr
*p
, int type
)
2102 gfc_actual_arglist
*ap
;
2103 gfc_intrinsic_sym
* isym
= NULL
;
2109 switch (p
->expr_type
)
2112 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2113 simplify_ref_chain (p
->ref
, type
, &p
);
2119 // For array-bound functions, we don't need to optimize
2120 // the 'array' argument. In particular, if the argument
2121 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2122 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2123 // can have any lbound.
2124 ap
= p
->value
.function
.actual
;
2125 if (p
->value
.function
.isym
&&
2126 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2127 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2128 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2129 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
))
2132 for ( ; ap
; ap
= ap
->next
)
2133 if (!gfc_simplify_expr (ap
->expr
, type
))
2136 if (p
->value
.function
.isym
!= NULL
2137 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2140 if (p
->expr_type
== EXPR_FUNCTION
)
2143 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2144 if (isym
&& isym
->elemental
)
2145 scalarize_intrinsic_call (p
, false);
2150 case EXPR_SUBSTRING
:
2151 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2154 if (gfc_is_constant_expr (p
))
2157 HOST_WIDE_INT start
, end
;
2160 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2162 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2163 start
--; /* Convert from one-based to zero-based. */
2166 end
= p
->value
.character
.length
;
2167 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2168 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2173 s
= gfc_get_wide_string (end
- start
+ 2);
2174 memcpy (s
, p
->value
.character
.string
+ start
,
2175 (end
- start
) * sizeof (gfc_char_t
));
2176 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2177 free (p
->value
.character
.string
);
2178 p
->value
.character
.string
= s
;
2179 p
->value
.character
.length
= end
- start
;
2180 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2181 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2183 p
->value
.character
.length
);
2184 gfc_free_ref_list (p
->ref
);
2186 p
->expr_type
= EXPR_CONSTANT
;
2191 if (!simplify_intrinsic_op (p
, type
))
2196 /* Only substitute array parameter variables if we are in an
2197 initialization expression, or we want a subsection. */
2198 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2199 && (gfc_init_expr_flag
|| p
->ref
2200 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2202 if (!simplify_parameter_variable (p
, type
))
2209 gfc_simplify_iterator_var (p
);
2212 /* Simplify subcomponent references. */
2213 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2218 case EXPR_STRUCTURE
:
2220 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2223 if (!simplify_constructor (p
->value
.constructor
, type
))
2226 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2227 && p
->ref
->u
.ar
.type
== AR_FULL
)
2228 gfc_expand_constructor (p
, false);
2230 if (!simplify_const_ref (p
))
2247 /* Returns the type of an expression with the exception that iterator
2248 variables are automatically integers no matter what else they may
2254 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2261 /* Scalarize an expression for an elemental intrinsic call. */
2264 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2266 gfc_actual_arglist
*a
, *b
;
2267 gfc_constructor_base ctor
;
2268 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2269 gfc_constructor
*ci
, *new_ctor
;
2270 gfc_expr
*expr
, *old
;
2271 int n
, i
, rank
[5], array_arg
;
2277 a
= e
->value
.function
.actual
;
2278 for (; a
; a
= a
->next
)
2279 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2282 /* Find which, if any, arguments are arrays. Assume that the old
2283 expression carries the type information and that the first arg
2284 that is an array expression carries all the shape information.*/
2286 a
= e
->value
.function
.actual
;
2287 for (; a
; a
= a
->next
)
2290 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2293 expr
= gfc_copy_expr (a
->expr
);
2300 old
= gfc_copy_expr (e
);
2302 gfc_constructor_free (expr
->value
.constructor
);
2303 expr
->value
.constructor
= NULL
;
2305 expr
->where
= old
->where
;
2306 expr
->expr_type
= EXPR_ARRAY
;
2308 /* Copy the array argument constructors into an array, with nulls
2311 a
= old
->value
.function
.actual
;
2312 for (; a
; a
= a
->next
)
2314 /* Check that this is OK for an initialization expression. */
2315 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2319 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2321 rank
[n
] = a
->expr
->rank
;
2322 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2323 args
[n
] = gfc_constructor_first (ctor
);
2325 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2328 rank
[n
] = a
->expr
->rank
;
2331 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2332 args
[n
] = gfc_constructor_first (ctor
);
2340 gfc_get_errors (NULL
, &errors
);
2342 /* Using the array argument as the master, step through the array
2343 calling the function for each element and advancing the array
2344 constructors together. */
2345 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2347 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2348 gfc_copy_expr (old
), NULL
);
2350 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2352 b
= old
->value
.function
.actual
;
2353 for (i
= 0; i
< n
; i
++)
2356 new_ctor
->expr
->value
.function
.actual
2357 = a
= gfc_get_actual_arglist ();
2360 a
->next
= gfc_get_actual_arglist ();
2365 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2367 a
->expr
= gfc_copy_expr (b
->expr
);
2372 /* Simplify the function calls. If the simplification fails, the
2373 error will be flagged up down-stream or the library will deal
2376 gfc_simplify_expr (new_ctor
->expr
, 0);
2378 for (i
= 0; i
< n
; i
++)
2380 args
[i
] = gfc_constructor_next (args
[i
]);
2382 for (i
= 1; i
< n
; i
++)
2383 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2384 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2390 /* Free "expr" but not the pointers it contains. */
2392 gfc_free_expr (old
);
2396 gfc_error_now ("elemental function arguments at %C are not compliant");
2399 gfc_free_expr (expr
);
2400 gfc_free_expr (old
);
2406 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2408 gfc_expr
*op1
= e
->value
.op
.op1
;
2409 gfc_expr
*op2
= e
->value
.op
.op2
;
2411 if (!(*check_function
)(op1
))
2414 switch (e
->value
.op
.op
)
2416 case INTRINSIC_UPLUS
:
2417 case INTRINSIC_UMINUS
:
2418 if (!numeric_type (et0 (op1
)))
2423 case INTRINSIC_EQ_OS
:
2425 case INTRINSIC_NE_OS
:
2427 case INTRINSIC_GT_OS
:
2429 case INTRINSIC_GE_OS
:
2431 case INTRINSIC_LT_OS
:
2433 case INTRINSIC_LE_OS
:
2434 if (!(*check_function
)(op2
))
2437 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2438 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2440 gfc_error ("Numeric or CHARACTER operands are required in "
2441 "expression at %L", &e
->where
);
2446 case INTRINSIC_PLUS
:
2447 case INTRINSIC_MINUS
:
2448 case INTRINSIC_TIMES
:
2449 case INTRINSIC_DIVIDE
:
2450 case INTRINSIC_POWER
:
2451 if (!(*check_function
)(op2
))
2454 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2459 case INTRINSIC_CONCAT
:
2460 if (!(*check_function
)(op2
))
2463 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2465 gfc_error ("Concatenation operator in expression at %L "
2466 "must have two CHARACTER operands", &op1
->where
);
2470 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2472 gfc_error ("Concat operator at %L must concatenate strings of the "
2473 "same kind", &e
->where
);
2480 if (et0 (op1
) != BT_LOGICAL
)
2482 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2483 "operand", &op1
->where
);
2492 case INTRINSIC_NEQV
:
2493 if (!(*check_function
)(op2
))
2496 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2498 gfc_error ("LOGICAL operands are required in expression at %L",
2505 case INTRINSIC_PARENTHESES
:
2509 gfc_error ("Only intrinsic operators can be used in expression at %L",
2517 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2522 /* F2003, 7.1.7 (3): In init expression, allocatable components
2523 must not be data-initialized. */
2525 check_alloc_comp_init (gfc_expr
*e
)
2527 gfc_component
*comp
;
2528 gfc_constructor
*ctor
;
2530 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2531 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2533 for (comp
= e
->ts
.u
.derived
->components
,
2534 ctor
= gfc_constructor_first (e
->value
.constructor
);
2535 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2537 if (comp
->attr
.allocatable
&& ctor
->expr
2538 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2540 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2541 "component %qs in structure constructor at %L",
2542 comp
->name
, &ctor
->expr
->where
);
2551 check_init_expr_arguments (gfc_expr
*e
)
2553 gfc_actual_arglist
*ap
;
2555 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2556 if (!gfc_check_init_expr (ap
->expr
))
2562 static bool check_restricted (gfc_expr
*);
2564 /* F95, 7.1.6.1, Initialization expressions, (7)
2565 F2003, 7.1.7 Initialization expression, (8)
2566 F2008, 7.1.12 Constant expression, (4) */
2569 check_inquiry (gfc_expr
*e
, int not_restricted
)
2572 const char *const *functions
;
2574 static const char *const inquiry_func_f95
[] = {
2575 "lbound", "shape", "size", "ubound",
2576 "bit_size", "len", "kind",
2577 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2578 "precision", "radix", "range", "tiny",
2582 static const char *const inquiry_func_f2003
[] = {
2583 "lbound", "shape", "size", "ubound",
2584 "bit_size", "len", "kind",
2585 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2586 "precision", "radix", "range", "tiny",
2590 /* std=f2008+ or -std=gnu */
2591 static const char *const inquiry_func_gnu
[] = {
2592 "lbound", "shape", "size", "ubound",
2593 "bit_size", "len", "kind",
2594 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2595 "precision", "radix", "range", "tiny",
2596 "new_line", "storage_size", NULL
2600 gfc_actual_arglist
*ap
;
2602 if (!e
->value
.function
.isym
2603 || !e
->value
.function
.isym
->inquiry
)
2606 /* An undeclared parameter will get us here (PR25018). */
2607 if (e
->symtree
== NULL
)
2610 if (e
->symtree
->n
.sym
->from_intmod
)
2612 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2613 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2614 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2617 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2618 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2623 name
= e
->symtree
->n
.sym
->name
;
2625 functions
= inquiry_func_gnu
;
2626 if (gfc_option
.warn_std
& GFC_STD_F2003
)
2627 functions
= inquiry_func_f2003
;
2628 if (gfc_option
.warn_std
& GFC_STD_F95
)
2629 functions
= inquiry_func_f95
;
2631 for (i
= 0; functions
[i
]; i
++)
2632 if (strcmp (functions
[i
], name
) == 0)
2635 if (functions
[i
] == NULL
)
2639 /* At this point we have an inquiry function with a variable argument. The
2640 type of the variable might be undefined, but we need it now, because the
2641 arguments of these functions are not allowed to be undefined. */
2643 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2648 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2650 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2651 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2654 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2657 /* Assumed character length will not reduce to a constant expression
2658 with LEN, as required by the standard. */
2659 if (i
== 5 && not_restricted
&& ap
->expr
->symtree
2660 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2661 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2662 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2664 gfc_error ("Assumed or deferred character length variable %qs "
2665 "in constant expression at %L",
2666 ap
->expr
->symtree
->n
.sym
->name
,
2670 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2673 if (not_restricted
== 0
2674 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2675 && !check_restricted (ap
->expr
))
2678 if (not_restricted
== 0
2679 && ap
->expr
->expr_type
== EXPR_VARIABLE
2680 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2681 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2689 /* F95, 7.1.6.1, Initialization expressions, (5)
2690 F2003, 7.1.7 Initialization expression, (5) */
2693 check_transformational (gfc_expr
*e
)
2695 static const char * const trans_func_f95
[] = {
2696 "repeat", "reshape", "selected_int_kind",
2697 "selected_real_kind", "transfer", "trim", NULL
2700 static const char * const trans_func_f2003
[] = {
2701 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2702 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2703 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2704 "trim", "unpack", NULL
2707 static const char * const trans_func_f2008
[] = {
2708 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2709 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2710 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2711 "trim", "unpack", "findloc", NULL
2716 const char *const *functions
;
2718 if (!e
->value
.function
.isym
2719 || !e
->value
.function
.isym
->transformational
)
2722 name
= e
->symtree
->n
.sym
->name
;
2724 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2725 functions
= trans_func_f2008
;
2726 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2727 functions
= trans_func_f2003
;
2729 functions
= trans_func_f95
;
2731 /* NULL() is dealt with below. */
2732 if (strcmp ("null", name
) == 0)
2735 for (i
= 0; functions
[i
]; i
++)
2736 if (strcmp (functions
[i
], name
) == 0)
2739 if (functions
[i
] == NULL
)
2741 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2742 "in an initialization expression", name
, &e
->where
);
2746 return check_init_expr_arguments (e
);
2750 /* F95, 7.1.6.1, Initialization expressions, (6)
2751 F2003, 7.1.7 Initialization expression, (6) */
2754 check_null (gfc_expr
*e
)
2756 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2759 return check_init_expr_arguments (e
);
2764 check_elemental (gfc_expr
*e
)
2766 if (!e
->value
.function
.isym
2767 || !e
->value
.function
.isym
->elemental
)
2770 if (e
->ts
.type
!= BT_INTEGER
2771 && e
->ts
.type
!= BT_CHARACTER
2772 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2773 "initialization expression at %L", &e
->where
))
2776 return check_init_expr_arguments (e
);
2781 check_conversion (gfc_expr
*e
)
2783 if (!e
->value
.function
.isym
2784 || !e
->value
.function
.isym
->conversion
)
2787 return check_init_expr_arguments (e
);
2791 /* Verify that an expression is an initialization expression. A side
2792 effect is that the expression tree is reduced to a single constant
2793 node if all goes well. This would normally happen when the
2794 expression is constructed but function references are assumed to be
2795 intrinsics in the context of initialization expressions. If
2796 false is returned an error message has been generated. */
2799 gfc_check_init_expr (gfc_expr
*e
)
2807 switch (e
->expr_type
)
2810 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2812 t
= gfc_simplify_expr (e
, 0);
2821 gfc_intrinsic_sym
* isym
= NULL
;
2822 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2824 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2825 IEEE_EXCEPTIONS modules. */
2826 int mod
= sym
->from_intmod
;
2827 if (mod
== INTMOD_NONE
&& sym
->generic
)
2828 mod
= sym
->generic
->sym
->from_intmod
;
2829 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2831 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2834 gfc_replace_expr (e
, new_expr
);
2840 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2841 into an array constructor, we need to skip the error check here.
2842 Conversion errors are caught below in scalarize_intrinsic_call. */
2843 conversion
= e
->value
.function
.isym
2844 && (e
->value
.function
.isym
->conversion
== 1);
2846 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2847 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2849 gfc_error ("Function %qs in initialization expression at %L "
2850 "must be an intrinsic function",
2851 e
->symtree
->n
.sym
->name
, &e
->where
);
2855 if ((m
= check_conversion (e
)) == MATCH_NO
2856 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2857 && (m
= check_null (e
)) == MATCH_NO
2858 && (m
= check_transformational (e
)) == MATCH_NO
2859 && (m
= check_elemental (e
)) == MATCH_NO
)
2861 gfc_error ("Intrinsic function %qs at %L is not permitted "
2862 "in an initialization expression",
2863 e
->symtree
->n
.sym
->name
, &e
->where
);
2867 if (m
== MATCH_ERROR
)
2870 /* Try to scalarize an elemental intrinsic function that has an
2872 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2873 if (isym
&& isym
->elemental
2874 && (t
= scalarize_intrinsic_call (e
, true)))
2879 t
= gfc_simplify_expr (e
, 0);
2886 /* This occurs when parsing pdt templates. */
2887 if (gfc_expr_attr (e
).pdt_kind
)
2890 if (gfc_check_iter_variable (e
))
2893 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2895 /* A PARAMETER shall not be used to define itself, i.e.
2896 REAL, PARAMETER :: x = transfer(0, x)
2898 if (!e
->symtree
->n
.sym
->value
)
2900 gfc_error ("PARAMETER %qs is used at %L before its definition "
2901 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2905 t
= simplify_parameter_variable (e
, 0);
2910 if (gfc_in_match_data ())
2915 if (e
->symtree
->n
.sym
->as
)
2917 switch (e
->symtree
->n
.sym
->as
->type
)
2919 case AS_ASSUMED_SIZE
:
2920 gfc_error ("Assumed size array %qs at %L is not permitted "
2921 "in an initialization expression",
2922 e
->symtree
->n
.sym
->name
, &e
->where
);
2925 case AS_ASSUMED_SHAPE
:
2926 gfc_error ("Assumed shape array %qs at %L is not permitted "
2927 "in an initialization expression",
2928 e
->symtree
->n
.sym
->name
, &e
->where
);
2932 if (!e
->symtree
->n
.sym
->attr
.allocatable
2933 && !e
->symtree
->n
.sym
->attr
.pointer
2934 && e
->symtree
->n
.sym
->attr
.dummy
)
2935 gfc_error ("Assumed-shape array %qs at %L is not permitted "
2936 "in an initialization expression",
2937 e
->symtree
->n
.sym
->name
, &e
->where
);
2939 gfc_error ("Deferred array %qs at %L is not permitted "
2940 "in an initialization expression",
2941 e
->symtree
->n
.sym
->name
, &e
->where
);
2945 gfc_error ("Array %qs at %L is a variable, which does "
2946 "not reduce to a constant expression",
2947 e
->symtree
->n
.sym
->name
, &e
->where
);
2955 gfc_error ("Parameter %qs at %L has not been declared or is "
2956 "a variable, which does not reduce to a constant "
2957 "expression", e
->symtree
->name
, &e
->where
);
2966 case EXPR_SUBSTRING
:
2969 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2973 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2975 t
= gfc_simplify_expr (e
, 0);
2981 case EXPR_STRUCTURE
:
2982 t
= e
->ts
.is_iso_c
? true : false;
2986 t
= check_alloc_comp_init (e
);
2990 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2997 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
3001 t
= gfc_expand_constructor (e
, true);
3005 t
= gfc_check_constructor_type (e
);
3009 gfc_internal_error ("check_init_expr(): Unknown expression type");
3015 /* Reduces a general expression to an initialization expression (a constant).
3016 This used to be part of gfc_match_init_expr.
3017 Note that this function doesn't free the given expression on false. */
3020 gfc_reduce_init_expr (gfc_expr
*expr
)
3024 gfc_init_expr_flag
= true;
3025 t
= gfc_resolve_expr (expr
);
3027 t
= gfc_check_init_expr (expr
);
3028 gfc_init_expr_flag
= false;
3033 if (expr
->expr_type
== EXPR_ARRAY
)
3035 if (!gfc_check_constructor_type (expr
))
3037 if (!gfc_expand_constructor (expr
, true))
3045 /* Match an initialization expression. We work by first matching an
3046 expression, then reducing it to a constant. */
3049 gfc_match_init_expr (gfc_expr
**result
)
3057 gfc_init_expr_flag
= true;
3059 m
= gfc_match_expr (&expr
);
3062 gfc_init_expr_flag
= false;
3066 if (gfc_derived_parameter_expr (expr
))
3069 gfc_init_expr_flag
= false;
3073 t
= gfc_reduce_init_expr (expr
);
3076 gfc_free_expr (expr
);
3077 gfc_init_expr_flag
= false;
3082 gfc_init_expr_flag
= false;
3088 /* Given an actual argument list, test to see that each argument is a
3089 restricted expression and optionally if the expression type is
3090 integer or character. */
3093 restricted_args (gfc_actual_arglist
*a
)
3095 for (; a
; a
= a
->next
)
3097 if (!check_restricted (a
->expr
))
3105 /************* Restricted/specification expressions *************/
3108 /* Make sure a non-intrinsic function is a specification function,
3109 * see F08:7.1.11.5. */
3112 external_spec_function (gfc_expr
*e
)
3116 f
= e
->value
.function
.esym
;
3118 /* IEEE functions allowed are "a reference to a transformational function
3119 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3120 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3121 IEEE_EXCEPTIONS". */
3122 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3123 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3125 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3126 || !strcmp (f
->name
, "ieee_support_rounding")
3127 || !strcmp (f
->name
, "ieee_support_flag")
3128 || !strcmp (f
->name
, "ieee_support_halting")
3129 || !strcmp (f
->name
, "ieee_support_datatype")
3130 || !strcmp (f
->name
, "ieee_support_denormal")
3131 || !strcmp (f
->name
, "ieee_support_subnormal")
3132 || !strcmp (f
->name
, "ieee_support_divide")
3133 || !strcmp (f
->name
, "ieee_support_inf")
3134 || !strcmp (f
->name
, "ieee_support_io")
3135 || !strcmp (f
->name
, "ieee_support_nan")
3136 || !strcmp (f
->name
, "ieee_support_sqrt")
3137 || !strcmp (f
->name
, "ieee_support_standard")
3138 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3139 goto function_allowed
;
3142 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3144 gfc_error ("Specification function %qs at %L cannot be a statement "
3145 "function", f
->name
, &e
->where
);
3149 if (f
->attr
.proc
== PROC_INTERNAL
)
3151 gfc_error ("Specification function %qs at %L cannot be an internal "
3152 "function", f
->name
, &e
->where
);
3156 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3158 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3164 if (f
->attr
.recursive
3165 && !gfc_notify_std (GFC_STD_F2003
,
3166 "Specification function %qs "
3167 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3171 return restricted_args (e
->value
.function
.actual
);
3175 /* Check to see that a function reference to an intrinsic is a
3176 restricted expression. */
3179 restricted_intrinsic (gfc_expr
*e
)
3181 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3182 if (check_inquiry (e
, 0) == MATCH_YES
)
3185 return restricted_args (e
->value
.function
.actual
);
3189 /* Check the expressions of an actual arglist. Used by check_restricted. */
3192 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3194 for (; arg
; arg
= arg
->next
)
3195 if (!checker (arg
->expr
))
3202 /* Check the subscription expressions of a reference chain with a checking
3203 function; used by check_restricted. */
3206 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3216 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
3218 if (!checker (ref
->u
.ar
.start
[dim
]))
3220 if (!checker (ref
->u
.ar
.end
[dim
]))
3222 if (!checker (ref
->u
.ar
.stride
[dim
]))
3228 /* Nothing needed, just proceed to next reference. */
3232 if (!checker (ref
->u
.ss
.start
))
3234 if (!checker (ref
->u
.ss
.end
))
3243 return check_references (ref
->next
, checker
);
3246 /* Return true if ns is a parent of the current ns. */
3249 is_parent_of_current_ns (gfc_namespace
*ns
)
3252 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3259 /* Verify that an expression is a restricted expression. Like its
3260 cousin check_init_expr(), an error message is generated if we
3264 check_restricted (gfc_expr
*e
)
3272 switch (e
->expr_type
)
3275 t
= check_intrinsic_op (e
, check_restricted
);
3277 t
= gfc_simplify_expr (e
, 0);
3282 if (e
->value
.function
.esym
)
3284 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3286 t
= external_spec_function (e
);
3290 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3293 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3296 t
= restricted_intrinsic (e
);
3301 sym
= e
->symtree
->n
.sym
;
3304 /* If a dummy argument appears in a context that is valid for a
3305 restricted expression in an elemental procedure, it will have
3306 already been simplified away once we get here. Therefore we
3307 don't need to jump through hoops to distinguish valid from
3309 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3310 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3312 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3313 sym
->name
, &e
->where
);
3317 if (sym
->attr
.optional
)
3319 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3320 sym
->name
, &e
->where
);
3324 if (sym
->attr
.intent
== INTENT_OUT
)
3326 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3327 sym
->name
, &e
->where
);
3331 /* Check reference chain if any. */
3332 if (!check_references (e
->ref
, &check_restricted
))
3335 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3336 processed in resolve.c(resolve_formal_arglist). This is done so
3337 that host associated dummy array indices are accepted (PR23446).
3338 This mechanism also does the same for the specification expressions
3339 of array-valued functions. */
3341 || sym
->attr
.in_common
3342 || sym
->attr
.use_assoc
3344 || sym
->attr
.implied_index
3345 || sym
->attr
.flavor
== FL_PARAMETER
3346 || is_parent_of_current_ns (sym
->ns
)
3347 || (sym
->ns
->proc_name
!= NULL
3348 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3349 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3355 gfc_error ("Variable %qs cannot appear in the expression at %L",
3356 sym
->name
, &e
->where
);
3357 /* Prevent a repetition of the error. */
3366 case EXPR_SUBSTRING
:
3367 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3371 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3373 t
= gfc_simplify_expr (e
, 0);
3377 case EXPR_STRUCTURE
:
3378 t
= gfc_check_constructor (e
, check_restricted
);
3382 t
= gfc_check_constructor (e
, check_restricted
);
3386 gfc_internal_error ("check_restricted(): Unknown expression type");
3393 /* Check to see that an expression is a specification expression. If
3394 we return false, an error has been generated. */
3397 gfc_specification_expr (gfc_expr
*e
)
3399 gfc_component
*comp
;
3404 if (e
->ts
.type
!= BT_INTEGER
)
3406 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3407 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3411 comp
= gfc_get_proc_ptr_comp (e
);
3412 if (e
->expr_type
== EXPR_FUNCTION
3413 && !e
->value
.function
.isym
3414 && !e
->value
.function
.esym
3415 && !gfc_pure (e
->symtree
->n
.sym
)
3416 && (!comp
|| !comp
->attr
.pure
))
3418 gfc_error ("Function %qs at %L must be PURE",
3419 e
->symtree
->n
.sym
->name
, &e
->where
);
3420 /* Prevent repeat error messages. */
3421 e
->symtree
->n
.sym
->attr
.pure
= 1;
3427 gfc_error ("Expression at %L must be scalar", &e
->where
);
3431 if (!gfc_simplify_expr (e
, 0))
3434 return check_restricted (e
);
3438 /************** Expression conformance checks. *************/
3440 /* Given two expressions, make sure that the arrays are conformable. */
3443 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3445 int op1_flag
, op2_flag
, d
;
3446 mpz_t op1_size
, op2_size
;
3452 if (op1
->rank
== 0 || op2
->rank
== 0)
3455 va_start (argp
, optype_msgid
);
3456 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3459 if (op1
->rank
!= op2
->rank
)
3461 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3462 op1
->rank
, op2
->rank
, &op1
->where
);
3468 for (d
= 0; d
< op1
->rank
; d
++)
3470 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3471 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3473 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3475 gfc_error ("Different shape for %s at %L on dimension %d "
3476 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3477 (int) mpz_get_si (op1_size
),
3478 (int) mpz_get_si (op2_size
));
3484 mpz_clear (op1_size
);
3486 mpz_clear (op2_size
);
3496 /* Given an assignable expression and an arbitrary expression, make
3497 sure that the assignment can take place. Only add a call to the intrinsic
3498 conversion routines, when allow_convert is set. When this assign is a
3499 coarray call, then the convert is done by the coarray routine implictly and
3500 adding the intrinsic conversion would do harm in most cases. */
3503 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3510 sym
= lvalue
->symtree
->n
.sym
;
3512 /* See if this is the component or subcomponent of a pointer and guard
3513 against assignment to LEN or KIND part-refs. */
3514 has_pointer
= sym
->attr
.pointer
;
3515 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3517 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3518 && ref
->u
.c
.component
->attr
.pointer
)
3520 else if (ref
->type
== REF_INQUIRY
3521 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3523 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3524 "allowed", &lvalue
->where
);
3529 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3530 variable local to a function subprogram. Its existence begins when
3531 execution of the function is initiated and ends when execution of the
3532 function is terminated...
3533 Therefore, the left hand side is no longer a variable, when it is: */
3534 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3535 && !sym
->attr
.external
)
3540 /* (i) Use associated; */
3541 if (sym
->attr
.use_assoc
)
3544 /* (ii) The assignment is in the main program; or */
3545 if (gfc_current_ns
->proc_name
3546 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3549 /* (iii) A module or internal procedure... */
3550 if (gfc_current_ns
->proc_name
3551 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3552 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3553 && gfc_current_ns
->parent
3554 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3555 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3556 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3558 /* ... that is not a function... */
3559 if (gfc_current_ns
->proc_name
3560 && !gfc_current_ns
->proc_name
->attr
.function
)
3563 /* ... or is not an entry and has a different name. */
3564 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3568 /* (iv) Host associated and not the function symbol or the
3569 parent result. This picks up sibling references, which
3570 cannot be entries. */
3571 if (!sym
->attr
.entry
3572 && sym
->ns
== gfc_current_ns
->parent
3573 && sym
!= gfc_current_ns
->proc_name
3574 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3579 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3585 /* Reject assigning to an external symbol. For initializers, this
3586 was already done before, in resolve_fl_procedure. */
3587 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
3588 && sym
->attr
.proc
!= PROC_MODULE
&& !rvalue
->error
)
3590 gfc_error ("Illegal assignment to external procedure at %L",
3596 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3598 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3599 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3603 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3605 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3610 if (rvalue
->expr_type
== EXPR_NULL
)
3612 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3613 && lvalue
->symtree
->n
.sym
->attr
.data
)
3617 gfc_error ("NULL appears on right-hand side in assignment at %L",
3623 /* This is possibly a typo: x = f() instead of x => f(). */
3625 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3626 gfc_warning (OPT_Wsurprising
,
3627 "POINTER-valued function appears on right-hand side of "
3628 "assignment at %L", &rvalue
->where
);
3630 /* Check size of array assignments. */
3631 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3632 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3635 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3636 && lvalue
->symtree
->n
.sym
->attr
.data
3637 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3638 "initialize non-integer variable %qs",
3639 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3641 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3642 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3643 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3647 /* Handle the case of a BOZ literal on the RHS. */
3648 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3651 if (warn_surprising
)
3652 gfc_warning (OPT_Wsurprising
,
3653 "BOZ literal at %L is bitwise transferred "
3654 "non-integer symbol %qs", &rvalue
->where
,
3655 lvalue
->symtree
->n
.sym
->name
);
3656 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3658 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3660 if (rc
== ARITH_UNDERFLOW
)
3661 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3662 ". This check can be disabled with the option "
3663 "%<-fno-range-check%>", &rvalue
->where
);
3664 else if (rc
== ARITH_OVERFLOW
)
3665 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3666 ". This check can be disabled with the option "
3667 "%<-fno-range-check%>", &rvalue
->where
);
3668 else if (rc
== ARITH_NAN
)
3669 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3670 ". This check can be disabled with the option "
3671 "%<-fno-range-check%>", &rvalue
->where
);
3676 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3678 gfc_error ("The assignment to a KIND or LEN component of a "
3679 "parameterized type at %L is not allowed",
3684 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3687 /* Only DATA Statements come here. */
3692 /* Numeric can be converted to any other numeric. And Hollerith can be
3693 converted to any other type. */
3694 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3695 || rvalue
->ts
.type
== BT_HOLLERITH
)
3698 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3701 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3702 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3703 "conversion of %s to %s", where
,
3704 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3709 /* Assignment is the only case where character variables of different
3710 kind values can be converted into one another. */
3711 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3713 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3714 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3722 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3726 /* Check that a pointer assignment is OK. We first check lvalue, and
3727 we only check rvalue if it's not an assignment to NULL() or a
3728 NULLIFY statement. */
3731 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
3732 bool suppress_type_test
, bool is_init_expr
)
3734 symbol_attribute attr
, lhs_attr
;
3736 bool is_pure
, is_implicit_pure
, rank_remap
;
3740 lhs_attr
= gfc_expr_attr (lvalue
);
3741 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3743 gfc_error ("Pointer assignment target is not a POINTER at %L",
3748 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3749 && !lhs_attr
.proc_pointer
)
3751 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3752 "l-value since it is a procedure",
3753 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3757 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3760 same_rank
= lvalue
->rank
== rvalue
->rank
;
3761 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3763 if (ref
->type
== REF_COMPONENT
)
3764 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3766 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3770 if (ref
->u
.ar
.type
== AR_FULL
)
3773 if (ref
->u
.ar
.type
!= AR_SECTION
)
3775 gfc_error ("Expected bounds specification for %qs at %L",
3776 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3780 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3781 "for %qs in pointer assignment at %L",
3782 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3785 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3787 * (C1017) If bounds-spec-list is specified, the number of
3788 * bounds-specs shall equal the rank of data-pointer-object.
3790 * If bounds-spec-list appears, it specifies the lower bounds.
3792 * (C1018) If bounds-remapping-list is specified, the number of
3793 * bounds-remappings shall equal the rank of data-pointer-object.
3795 * If bounds-remapping-list appears, it specifies the upper and
3796 * lower bounds of each dimension of the pointer; the pointer target
3797 * shall be simply contiguous or of rank one.
3799 * (C1019) If bounds-remapping-list is not specified, the ranks of
3800 * data-pointer-object and data-target shall be the same.
3802 * Thus when bounds are given, all lbounds are necessary and either
3803 * all or none of the upper bounds; no strides are allowed. If the
3804 * upper bounds are present, we may do rank remapping. */
3805 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3807 if (ref
->u
.ar
.stride
[dim
])
3809 gfc_error ("Stride must not be present at %L",
3813 if (!same_rank
&& (!ref
->u
.ar
.start
[dim
] ||!ref
->u
.ar
.end
[dim
]))
3815 gfc_error ("Rank remapping requires a "
3816 "list of %<lower-bound : upper-bound%> "
3817 "specifications at %L", &lvalue
->where
);
3820 if (!ref
->u
.ar
.start
[dim
]
3821 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3823 gfc_error ("Expected list of %<lower-bound :%> or "
3824 "list of %<lower-bound : upper-bound%> "
3825 "specifications at %L", &lvalue
->where
);
3830 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3833 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
]))
3835 gfc_error ("Rank remapping requires a "
3836 "list of %<lower-bound : upper-bound%> "
3837 "specifications at %L", &lvalue
->where
);
3840 if (!rank_remap
&& ref
->u
.ar
.end
[dim
])
3842 gfc_error ("Expected list of %<lower-bound :%> or "
3843 "list of %<lower-bound : upper-bound%> "
3844 "specifications at %L", &lvalue
->where
);
3852 is_pure
= gfc_pure (NULL
);
3853 is_implicit_pure
= gfc_implicit_pure (NULL
);
3855 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3856 kind, etc for lvalue and rvalue must match, and rvalue must be a
3857 pure variable if we're in a pure function. */
3858 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3861 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3862 if (lvalue
->expr_type
== EXPR_VARIABLE
3863 && gfc_is_coindexed (lvalue
))
3866 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3867 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3869 gfc_error ("Pointer object at %L shall not have a coindex",
3875 /* Checks on rvalue for procedure pointer assignments. */
3880 gfc_component
*comp1
, *comp2
;
3883 attr
= gfc_expr_attr (rvalue
);
3884 if (!((rvalue
->expr_type
== EXPR_NULL
)
3885 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3886 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3887 || (rvalue
->expr_type
== EXPR_VARIABLE
3888 && attr
.flavor
== FL_PROCEDURE
)))
3890 gfc_error ("Invalid procedure pointer assignment at %L",
3895 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3897 /* Check for intrinsics. */
3898 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3899 if (!sym
->attr
.intrinsic
3900 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3901 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3903 sym
->attr
.intrinsic
= 1;
3904 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3905 attr
= gfc_expr_attr (rvalue
);
3907 /* Check for result of embracing function. */
3908 if (sym
->attr
.function
&& sym
->result
== sym
)
3912 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3913 if (sym
== ns
->proc_name
)
3915 gfc_error ("Function result %qs is invalid as proc-target "
3916 "in procedure pointer assignment at %L",
3917 sym
->name
, &rvalue
->where
);
3924 gfc_error ("Abstract interface %qs is invalid "
3925 "in procedure pointer assignment at %L",
3926 rvalue
->symtree
->name
, &rvalue
->where
);
3929 /* Check for F08:C729. */
3930 if (attr
.flavor
== FL_PROCEDURE
)
3932 if (attr
.proc
== PROC_ST_FUNCTION
)
3934 gfc_error ("Statement function %qs is invalid "
3935 "in procedure pointer assignment at %L",
3936 rvalue
->symtree
->name
, &rvalue
->where
);
3939 if (attr
.proc
== PROC_INTERNAL
&&
3940 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3941 "is invalid in procedure pointer assignment "
3942 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3944 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3945 attr
.subroutine
) == 0)
3947 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3948 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3952 /* Check for F08:C730. */
3953 if (attr
.elemental
&& !attr
.intrinsic
)
3955 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3956 "in procedure pointer assignment at %L",
3957 rvalue
->symtree
->name
, &rvalue
->where
);
3961 /* Ensure that the calling convention is the same. As other attributes
3962 such as DLLEXPORT may differ, one explicitly only tests for the
3963 calling conventions. */
3964 if (rvalue
->expr_type
== EXPR_VARIABLE
3965 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3966 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3968 symbol_attribute calls
;
3971 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3972 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3973 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3975 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3976 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3978 gfc_error ("Mismatch in the procedure pointer assignment "
3979 "at %L: mismatch in the calling convention",
3985 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3987 s1
= comp1
->ts
.interface
;
3990 s1
= lvalue
->symtree
->n
.sym
;
3991 if (s1
->ts
.interface
)
3992 s1
= s1
->ts
.interface
;
3995 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3998 if (rvalue
->expr_type
== EXPR_FUNCTION
)
4000 s2
= comp2
->ts
.interface
->result
;
4005 s2
= comp2
->ts
.interface
;
4009 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
4011 if (rvalue
->value
.function
.esym
)
4012 s2
= rvalue
->value
.function
.esym
->result
;
4014 s2
= rvalue
->symtree
->n
.sym
->result
;
4020 s2
= rvalue
->symtree
->n
.sym
;
4024 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
4025 s2
= s2
->ts
.interface
;
4027 /* Special check for the case of absent interface on the lvalue.
4028 * All other interface checks are done below. */
4029 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
4031 gfc_error ("Interface mismatch in procedure pointer assignment "
4032 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
4036 /* F08:7.2.2.4 (4) */
4037 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
4041 gfc_error ("Explicit interface required for component %qs at %L: %s",
4042 comp1
->name
, &lvalue
->where
, err
);
4045 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
4047 gfc_error ("Explicit interface required for %qs at %L: %s",
4048 s1
->name
, &lvalue
->where
, err
);
4052 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
4056 gfc_error ("Explicit interface required for component %qs at %L: %s",
4057 comp2
->name
, &rvalue
->where
, err
);
4060 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
4062 gfc_error ("Explicit interface required for %qs at %L: %s",
4063 s2
->name
, &rvalue
->where
, err
);
4068 if (s1
== s2
|| !s1
|| !s2
)
4071 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
4072 err
, sizeof(err
), NULL
, NULL
))
4074 gfc_error ("Interface mismatch in procedure pointer assignment "
4075 "at %L: %s", &rvalue
->where
, err
);
4079 /* Check F2008Cor2, C729. */
4080 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4081 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4083 gfc_error ("Procedure pointer target %qs at %L must be either an "
4084 "intrinsic, host or use associated, referenced or have "
4085 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4093 /* A non-proc pointer cannot point to a constant. */
4094 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4096 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4102 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4104 /* Check for F03:C717. */
4105 if (UNLIMITED_POLY (rvalue
)
4106 && !(UNLIMITED_POLY (lvalue
)
4107 || (lvalue
->ts
.type
== BT_DERIVED
4108 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4109 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4110 gfc_error ("Data-pointer-object at %L must be unlimited "
4111 "polymorphic, or of a type with the BIND or SEQUENCE "
4112 "attribute, to be compatible with an unlimited "
4113 "polymorphic target", &lvalue
->where
);
4114 else if (!suppress_type_test
)
4115 gfc_error ("Different types in pointer assignment at %L; "
4116 "attempted assignment of %s to %s", &lvalue
->where
,
4117 gfc_typename (&rvalue
->ts
),
4118 gfc_typename (&lvalue
->ts
));
4122 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4124 gfc_error ("Different kind type parameters in pointer "
4125 "assignment at %L", &lvalue
->where
);
4129 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4131 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4135 /* Make sure the vtab is present. */
4136 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4137 gfc_find_vtab (&rvalue
->ts
);
4139 /* Check rank remapping. */
4144 /* If this can be determined, check that the target must be at least as
4145 large as the pointer assigned to it is. */
4146 if (gfc_array_size (lvalue
, &lsize
)
4147 && gfc_array_size (rvalue
, &rsize
)
4148 && mpz_cmp (rsize
, lsize
) < 0)
4150 gfc_error ("Rank remapping target is smaller than size of the"
4151 " pointer (%ld < %ld) at %L",
4152 mpz_get_si (rsize
), mpz_get_si (lsize
),
4157 /* The target must be either rank one or it must be simply contiguous
4158 and F2008 must be allowed. */
4159 if (rvalue
->rank
!= 1)
4161 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4163 gfc_error ("Rank remapping target must be rank 1 or"
4164 " simply contiguous at %L", &rvalue
->where
);
4167 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4168 "rank 1 at %L", &rvalue
->where
))
4173 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4174 if (rvalue
->expr_type
== EXPR_NULL
)
4177 if (lvalue
->ts
.type
== BT_CHARACTER
)
4179 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4184 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4185 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4187 attr
= gfc_expr_attr (rvalue
);
4189 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4191 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4192 to caf_get. Map this to the same error message as below when it is
4193 still a variable expression. */
4194 if (rvalue
->value
.function
.isym
4195 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4196 /* The test above might need to be extend when F08, Note 5.4 has to be
4197 interpreted in the way that target and pointer with the same coindex
4199 gfc_error ("Data target at %L shall not have a coindex",
4202 gfc_error ("Target expression in pointer assignment "
4203 "at %L must deliver a pointer result",
4213 gcc_assert (rvalue
->symtree
);
4214 sym
= rvalue
->symtree
->n
.sym
;
4216 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4217 target
= CLASS_DATA (sym
)->attr
.target
;
4219 target
= sym
->attr
.target
;
4221 if (!target
&& !proc_pointer
)
4223 gfc_error ("Pointer assignment target in initialization expression "
4224 "does not have the TARGET attribute at %L",
4231 if (!attr
.target
&& !attr
.pointer
)
4233 gfc_error ("Pointer assignment target is neither TARGET "
4234 "nor POINTER at %L", &rvalue
->where
);
4239 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4241 gfc_error ("Bad target in pointer assignment in PURE "
4242 "procedure at %L", &rvalue
->where
);
4245 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4246 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4248 if (gfc_has_vector_index (rvalue
))
4250 gfc_error ("Pointer assignment with vector subscript "
4251 "on rhs at %L", &rvalue
->where
);
4255 if (attr
.is_protected
&& attr
.use_assoc
4256 && !(attr
.pointer
|| attr
.proc_pointer
))
4258 gfc_error ("Pointer assignment target has PROTECTED "
4259 "attribute at %L", &rvalue
->where
);
4263 /* F2008, C725. For PURE also C1283. */
4264 if (rvalue
->expr_type
== EXPR_VARIABLE
4265 && gfc_is_coindexed (rvalue
))
4268 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4269 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4271 gfc_error ("Data target at %L shall not have a coindex",
4277 /* Warn for assignments of contiguous pointers to targets which is not
4278 contiguous. Be lenient in the definition of what counts as
4281 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
4282 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4283 "non-contiguous target at %L", &rvalue
->where
);
4285 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4286 if (warn_target_lifetime
4287 && rvalue
->expr_type
== EXPR_VARIABLE
4288 && !rvalue
->symtree
->n
.sym
->attr
.save
4289 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4290 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4291 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4292 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4293 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4298 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4299 || lvalue
->symtree
->n
.sym
->attr
.result
4300 || lvalue
->symtree
->n
.sym
->attr
.function
4301 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4302 && lvalue
->symtree
->n
.sym
->ns
4303 != rvalue
->symtree
->n
.sym
->ns
)
4304 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4305 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4307 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4308 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4309 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4310 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4311 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4313 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4320 gfc_warning (OPT_Wtarget_lifetime
,
4321 "Pointer at %L in pointer assignment might outlive the "
4322 "pointer target", &lvalue
->where
);
4329 /* Relative of gfc_check_assign() except that the lvalue is a single
4330 symbol. Used for initialization assignments. */
4333 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4337 bool pointer
, proc_pointer
;
4339 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4341 lvalue
.expr_type
= EXPR_VARIABLE
;
4342 lvalue
.ts
= sym
->ts
;
4344 lvalue
.rank
= sym
->as
->rank
;
4345 lvalue
.symtree
= XCNEW (gfc_symtree
);
4346 lvalue
.symtree
->n
.sym
= sym
;
4347 lvalue
.where
= sym
->declared_at
;
4351 lvalue
.ref
= gfc_get_ref ();
4352 lvalue
.ref
->type
= REF_COMPONENT
;
4353 lvalue
.ref
->u
.c
.component
= comp
;
4354 lvalue
.ref
->u
.c
.sym
= sym
;
4355 lvalue
.ts
= comp
->ts
;
4356 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4357 lvalue
.where
= comp
->loc
;
4358 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4359 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4360 proc_pointer
= comp
->attr
.proc_pointer
;
4364 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4365 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4366 proc_pointer
= sym
->attr
.proc_pointer
;
4369 if (pointer
|| proc_pointer
)
4370 r
= gfc_check_pointer_assign (&lvalue
, rvalue
, false, true);
4373 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4374 into an array constructor, we should check if it can be reduced
4375 as an initialization expression. */
4376 if (rvalue
->expr_type
== EXPR_FUNCTION
4377 && rvalue
->value
.function
.isym
4378 && (rvalue
->value
.function
.isym
->conversion
== 1))
4379 gfc_check_init_expr (rvalue
);
4381 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4384 free (lvalue
.symtree
);
4390 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
&& !proc_pointer
)
4392 /* F08:C461. Additional checks for pointer initialization. */
4393 symbol_attribute attr
;
4394 attr
= gfc_expr_attr (rvalue
);
4395 if (attr
.allocatable
)
4397 gfc_error ("Pointer initialization target at %L "
4398 "must not be ALLOCATABLE", &rvalue
->where
);
4401 if (!attr
.target
|| attr
.pointer
)
4403 gfc_error ("Pointer initialization target at %L "
4404 "must have the TARGET attribute", &rvalue
->where
);
4408 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4409 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4410 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4412 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4413 attr
.save
= SAVE_IMPLICIT
;
4418 gfc_error ("Pointer initialization target at %L "
4419 "must have the SAVE attribute", &rvalue
->where
);
4424 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4426 /* F08:C1220. Additional checks for procedure pointer initialization. */
4427 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4428 if (attr
.proc_pointer
)
4430 gfc_error ("Procedure pointer initialization target at %L "
4431 "may not be a procedure pointer", &rvalue
->where
);
4434 if (attr
.proc
== PROC_INTERNAL
)
4436 gfc_error ("Internal procedure %qs is invalid in "
4437 "procedure pointer initialization at %L",
4438 rvalue
->symtree
->name
, &rvalue
->where
);
4443 gfc_error ("Dummy procedure %qs is invalid in "
4444 "procedure pointer initialization at %L",
4445 rvalue
->symtree
->name
, &rvalue
->where
);
4453 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4454 * require that an expression be built. */
4457 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4459 return gfc_build_init_expr (ts
, where
, false);
4462 /* Build an initializer for a local integer, real, complex, logical, or
4463 character variable, based on the command line flags finit-local-zero,
4464 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4465 With force, an initializer is ALWAYS generated. */
4468 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4470 gfc_expr
*init_expr
;
4472 /* Try to build an initializer expression. */
4473 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4475 /* If we want to force generation, make sure we default to zero. */
4476 gfc_init_local_real init_real
= flag_init_real
;
4477 int init_logical
= gfc_option
.flag_init_logical
;
4480 if (init_real
== GFC_INIT_REAL_OFF
)
4481 init_real
= GFC_INIT_REAL_ZERO
;
4482 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4483 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4486 /* We will only initialize integers, reals, complex, logicals, and
4487 characters, and only if the corresponding command-line flags
4488 were set. Otherwise, we free init_expr and return null. */
4492 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4493 mpz_set_si (init_expr
->value
.integer
,
4494 gfc_option
.flag_init_integer_value
);
4497 gfc_free_expr (init_expr
);
4505 case GFC_INIT_REAL_SNAN
:
4506 init_expr
->is_snan
= 1;
4508 case GFC_INIT_REAL_NAN
:
4509 mpfr_set_nan (init_expr
->value
.real
);
4512 case GFC_INIT_REAL_INF
:
4513 mpfr_set_inf (init_expr
->value
.real
, 1);
4516 case GFC_INIT_REAL_NEG_INF
:
4517 mpfr_set_inf (init_expr
->value
.real
, -1);
4520 case GFC_INIT_REAL_ZERO
:
4521 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4525 gfc_free_expr (init_expr
);
4534 case GFC_INIT_REAL_SNAN
:
4535 init_expr
->is_snan
= 1;
4537 case GFC_INIT_REAL_NAN
:
4538 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4539 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4542 case GFC_INIT_REAL_INF
:
4543 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4544 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4547 case GFC_INIT_REAL_NEG_INF
:
4548 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4549 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4552 case GFC_INIT_REAL_ZERO
:
4553 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4557 gfc_free_expr (init_expr
);
4564 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4565 init_expr
->value
.logical
= 0;
4566 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4567 init_expr
->value
.logical
= 1;
4570 gfc_free_expr (init_expr
);
4576 /* For characters, the length must be constant in order to
4577 create a default initializer. */
4578 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4580 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4582 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4583 init_expr
->value
.character
.length
= char_len
;
4584 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4585 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4586 init_expr
->value
.character
.string
[i
]
4587 = (unsigned char) gfc_option
.flag_init_character_value
;
4591 gfc_free_expr (init_expr
);
4595 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4596 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4598 gfc_actual_arglist
*arg
;
4599 init_expr
= gfc_get_expr ();
4600 init_expr
->where
= *where
;
4601 init_expr
->ts
= *ts
;
4602 init_expr
->expr_type
= EXPR_FUNCTION
;
4603 init_expr
->value
.function
.isym
=
4604 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4605 init_expr
->value
.function
.name
= "repeat";
4606 arg
= gfc_get_actual_arglist ();
4607 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4608 arg
->expr
->value
.character
.string
[0] =
4609 gfc_option
.flag_init_character_value
;
4610 arg
->next
= gfc_get_actual_arglist ();
4611 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4612 init_expr
->value
.function
.actual
= arg
;
4617 gfc_free_expr (init_expr
);
4624 /* Apply an initialization expression to a typespec. Can be used for symbols or
4625 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4626 combined with some effort. */
4629 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4631 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4634 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4635 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4637 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4639 if (init
->expr_type
== EXPR_CONSTANT
)
4640 gfc_set_constant_character_len (len
, init
, -1);
4642 && init
->ts
.type
== BT_CHARACTER
4643 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4644 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4645 init
->ts
.u
.cl
->length
->value
.integer
))
4647 gfc_constructor
*ctor
;
4648 ctor
= gfc_constructor_first (init
->value
.constructor
);
4652 bool has_ts
= (init
->ts
.u
.cl
4653 && init
->ts
.u
.cl
->length_from_typespec
);
4655 /* Remember the length of the first element for checking
4656 that all elements *in the constructor* have the same
4657 length. This need not be the length of the LHS! */
4658 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4659 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4660 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4662 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4663 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4665 gfc_set_constant_character_len (len
, ctor
->expr
,
4666 has_ts
? -1 : first_len
);
4667 if (!ctor
->expr
->ts
.u
.cl
)
4669 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4671 ctor
->expr
->ts
.u
.cl
->length
4672 = gfc_copy_expr (ts
->u
.cl
->length
);
4680 /* Check whether an expression is a structure constructor and whether it has
4681 other values than NULL. */
4684 is_non_empty_structure_constructor (gfc_expr
* e
)
4686 if (e
->expr_type
!= EXPR_STRUCTURE
)
4689 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4692 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4694 cons
= gfc_constructor_next (cons
);
4700 /* Check for default initializer; sym->value is not enough
4701 as it is also set for EXPR_NULL of allocatables. */
4704 gfc_has_default_initializer (gfc_symbol
*der
)
4708 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4709 for (c
= der
->components
; c
; c
= c
->next
)
4710 if (gfc_bt_struct (c
->ts
.type
))
4712 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4713 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4715 && is_non_empty_structure_constructor (c
->initializer
))
4716 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4718 if (c
->attr
.pointer
&& c
->initializer
)
4732 Generate an initializer expression which initializes the entirety of a union.
4733 A normal structure constructor is insufficient without undue effort, because
4734 components of maps may be oddly aligned/overlapped. (For example if a
4735 character is initialized from one map overtop a real from the other, only one
4736 byte of the real is actually initialized.) Unfortunately we don't know the
4737 size of the union right now, so we can't generate a proper initializer, but
4738 we use a NULL expr as a placeholder and do the right thing later in
4739 gfc_trans_subcomponent_assign.
4742 generate_union_initializer (gfc_component
*un
)
4744 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4747 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4748 placeholder
->ts
= un
->ts
;
4753 /* Get the user-specified initializer for a union, if any. This means the user
4754 has said to initialize component(s) of a map. For simplicity's sake we
4755 only allow the user to initialize the first map. We don't have to worry
4756 about overlapping initializers as they are released early in resolution (see
4757 resolve_fl_struct). */
4760 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4763 gfc_expr
*init
=NULL
;
4765 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4768 for (map
= union_type
->components
; map
; map
= map
->next
)
4770 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4772 init
= gfc_default_initializer (&map
->ts
);
4786 class_allocatable (gfc_component
*comp
)
4788 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4789 && CLASS_DATA (comp
)->attr
.allocatable
;
4793 class_pointer (gfc_component
*comp
)
4795 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4796 && CLASS_DATA (comp
)->attr
.pointer
;
4800 comp_allocatable (gfc_component
*comp
)
4802 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4806 comp_pointer (gfc_component
*comp
)
4808 return comp
->attr
.pointer
4809 || comp
->attr
.proc_pointer
4810 || comp
->attr
.class_pointer
4811 || class_pointer (comp
);
4814 /* Fetch or generate an initializer for the given component.
4815 Only generate an initializer if generate is true. */
4818 component_initializer (gfc_component
*c
, bool generate
)
4820 gfc_expr
*init
= NULL
;
4822 /* Allocatable components always get EXPR_NULL.
4823 Pointer components are only initialized when generating, and only if they
4824 do not already have an initializer. */
4825 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4827 init
= gfc_get_null_expr (&c
->loc
);
4832 /* See if we can find the initializer immediately. */
4833 if (c
->initializer
|| !generate
)
4834 return c
->initializer
;
4836 /* Recursively handle derived type components. */
4837 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4838 init
= gfc_generate_initializer (&c
->ts
, true);
4840 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4842 gfc_component
*map
= NULL
;
4843 gfc_constructor
*ctor
;
4844 gfc_expr
*user_init
;
4846 /* If we don't have a user initializer and we aren't generating one, this
4847 union has no initializer. */
4848 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4849 if (!user_init
&& !generate
)
4852 /* Otherwise use a structure constructor. */
4853 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4857 /* If we are to generate an initializer for the union, add a constructor
4858 which initializes the whole union first. */
4861 ctor
= gfc_constructor_get ();
4862 ctor
->expr
= generate_union_initializer (c
);
4863 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4866 /* If we found an initializer in one of our maps, apply it. Note this
4867 is applied _after_ the entire-union initializer above if any. */
4870 ctor
= gfc_constructor_get ();
4871 ctor
->expr
= user_init
;
4872 ctor
->n
.component
= map
;
4873 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4877 /* Treat simple components like locals. */
4880 /* We MUST give an initializer, so force generation. */
4881 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4882 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4889 /* Get an expression for a default initializer of a derived type. */
4892 gfc_default_initializer (gfc_typespec
*ts
)
4894 return gfc_generate_initializer (ts
, false);
4897 /* Generate an initializer expression for an iso_c_binding type
4898 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
4901 generate_isocbinding_initializer (gfc_symbol
*derived
)
4903 /* The initializers have already been built into the c_null_[fun]ptr symbols
4904 from gen_special_c_interop_ptr. */
4905 gfc_symtree
*npsym
= NULL
;
4906 if (0 == strcmp (derived
->name
, "c_ptr"))
4907 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
4908 else if (0 == strcmp (derived
->name
, "c_funptr"))
4909 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
4911 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
4912 " type, expected %<c_ptr%> or %<c_funptr%>");
4915 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
4916 init
->symtree
= npsym
;
4917 init
->ts
.is_iso_c
= true;
4924 /* Get or generate an expression for a default initializer of a derived type.
4925 If -finit-derived is specified, generate default initialization expressions
4926 for components that lack them when generate is set. */
4929 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4931 gfc_expr
*init
, *tmp
;
4932 gfc_component
*comp
;
4934 generate
= flag_init_derived
&& generate
;
4936 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
4937 return generate_isocbinding_initializer (ts
->u
.derived
);
4939 /* See if we have a default initializer in this, but not in nested
4940 types (otherwise we could use gfc_has_default_initializer()).
4941 We don't need to check if we are going to generate them. */
4942 comp
= ts
->u
.derived
->components
;
4945 for (; comp
; comp
= comp
->next
)
4946 if (comp
->initializer
|| comp_allocatable (comp
))
4953 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4954 &ts
->u
.derived
->declared_at
);
4957 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4959 gfc_constructor
*ctor
= gfc_constructor_get();
4961 /* Fetch or generate an initializer for the component. */
4962 tmp
= component_initializer (comp
, generate
);
4965 /* Save the component ref for STRUCTUREs and UNIONs. */
4966 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4967 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4968 ctor
->n
.component
= comp
;
4970 /* If the initializer was not generated, we need a copy. */
4971 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4972 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
4973 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4976 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
4982 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4989 /* Given a symbol, create an expression node with that symbol as a
4990 variable. If the symbol is array valued, setup a reference of the
4994 gfc_get_variable_expr (gfc_symtree
*var
)
4998 e
= gfc_get_expr ();
4999 e
->expr_type
= EXPR_VARIABLE
;
5001 e
->ts
= var
->n
.sym
->ts
;
5003 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
5004 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
5005 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
5006 && CLASS_DATA (var
->n
.sym
)->as
)))
5008 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
5009 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
5010 e
->ref
= gfc_get_ref ();
5011 e
->ref
->type
= REF_ARRAY
;
5012 e
->ref
->u
.ar
.type
= AR_FULL
;
5013 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
5014 ? CLASS_DATA (var
->n
.sym
)->as
5022 /* Adds a full array reference to an expression, as needed. */
5025 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
5028 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5033 ref
->next
= gfc_get_ref ();
5038 e
->ref
= gfc_get_ref ();
5041 ref
->type
= REF_ARRAY
;
5042 ref
->u
.ar
.type
= AR_FULL
;
5043 ref
->u
.ar
.dimen
= e
->rank
;
5044 ref
->u
.ar
.where
= e
->where
;
5050 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
5054 lval
= gfc_get_expr ();
5055 lval
->expr_type
= EXPR_VARIABLE
;
5056 lval
->where
= sym
->declared_at
;
5058 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5060 /* It will always be a full array. */
5061 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5062 lval
->rank
= as
? as
->rank
: 0;
5064 gfc_add_full_array_ref (lval
, as
);
5069 /* Returns the array_spec of a full array expression. A NULL is
5070 returned otherwise. */
5072 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
5077 if (expr
->rank
== 0)
5080 /* Follow any component references. */
5081 if (expr
->expr_type
== EXPR_VARIABLE
5082 || expr
->expr_type
== EXPR_CONSTANT
)
5085 as
= expr
->symtree
->n
.sym
->as
;
5089 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5094 as
= ref
->u
.c
.component
->as
;
5103 switch (ref
->u
.ar
.type
)
5126 /* General expression traversal function. */
5129 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5130 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5135 gfc_actual_arglist
*args
;
5142 if ((*func
) (expr
, sym
, &f
))
5145 if (expr
->ts
.type
== BT_CHARACTER
5147 && expr
->ts
.u
.cl
->length
5148 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5149 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5152 switch (expr
->expr_type
)
5157 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5159 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5167 case EXPR_SUBSTRING
:
5170 case EXPR_STRUCTURE
:
5172 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5173 c
; c
= gfc_constructor_next (c
))
5175 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5179 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5181 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5183 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5185 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5192 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5194 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5210 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5212 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5214 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5216 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5222 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5224 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5229 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5230 && ref
->u
.c
.component
->ts
.u
.cl
5231 && ref
->u
.c
.component
->ts
.u
.cl
->length
5232 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5234 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5238 if (ref
->u
.c
.component
->as
)
5239 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5240 + ref
->u
.c
.component
->as
->corank
; i
++)
5242 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5245 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5262 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5265 expr_set_symbols_referenced (gfc_expr
*expr
,
5266 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5267 int *f ATTRIBUTE_UNUSED
)
5269 if (expr
->expr_type
!= EXPR_VARIABLE
)
5271 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5276 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5278 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5282 /* Determine if an expression is a procedure pointer component and return
5283 the component in that case. Otherwise return NULL. */
5286 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5290 if (!expr
|| !expr
->ref
)
5297 if (ref
->type
== REF_COMPONENT
5298 && ref
->u
.c
.component
->attr
.proc_pointer
)
5299 return ref
->u
.c
.component
;
5305 /* Determine if an expression is a procedure pointer component. */
5308 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5310 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5314 /* Determine if an expression is a function with an allocatable class scalar
5317 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5319 if (expr
->expr_type
== EXPR_FUNCTION
5320 && expr
->value
.function
.esym
5321 && expr
->value
.function
.esym
->result
5322 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5323 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5324 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5331 /* Determine if an expression is a function with an allocatable class array
5334 gfc_is_class_array_function (gfc_expr
*expr
)
5336 if (expr
->expr_type
== EXPR_FUNCTION
5337 && expr
->value
.function
.esym
5338 && expr
->value
.function
.esym
->result
5339 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5340 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5341 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5342 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5349 /* Walk an expression tree and check each variable encountered for being typed.
5350 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5351 mode as is a basic arithmetic expression using those; this is for things in
5354 INTEGER :: arr(n), n
5355 INTEGER :: arr(n + 1), n
5357 The namespace is needed for IMPLICIT typing. */
5359 static gfc_namespace
* check_typed_ns
;
5362 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5363 int* f ATTRIBUTE_UNUSED
)
5367 if (e
->expr_type
!= EXPR_VARIABLE
)
5370 gcc_assert (e
->symtree
);
5371 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5378 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5382 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5386 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5387 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5389 if (e
->expr_type
== EXPR_OP
)
5393 gcc_assert (e
->value
.op
.op1
);
5394 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5396 if (t
&& e
->value
.op
.op2
)
5397 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5403 /* Otherwise, walk the expression and do it strictly. */
5404 check_typed_ns
= ns
;
5405 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5407 return error_found
? false : true;
5411 /* This function returns true if it contains any references to PDT KIND
5412 or LEN parameters. */
5415 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5416 int* f ATTRIBUTE_UNUSED
)
5418 if (e
->expr_type
!= EXPR_VARIABLE
)
5421 gcc_assert (e
->symtree
);
5422 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5423 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5431 gfc_derived_parameter_expr (gfc_expr
*e
)
5433 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5437 /* This function returns the overall type of a type parameter spec list.
5438 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5439 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5440 unless derived is not NULL. In this latter case, all the LEN parameters
5441 must be either assumed or deferred for the return argument to be set to
5442 anything other than SPEC_EXPLICIT. */
5445 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5447 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5449 bool seen_assumed
= false;
5450 bool seen_deferred
= false;
5452 if (derived
== NULL
)
5454 for (; param_list
; param_list
= param_list
->next
)
5455 if (param_list
->spec_type
== SPEC_ASSUMED
5456 || param_list
->spec_type
== SPEC_DEFERRED
)
5457 return param_list
->spec_type
;
5461 for (; param_list
; param_list
= param_list
->next
)
5463 c
= gfc_find_component (derived
, param_list
->name
,
5465 gcc_assert (c
!= NULL
);
5466 if (c
->attr
.pdt_kind
)
5468 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5469 return SPEC_EXPLICIT
;
5470 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5471 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5472 if (seen_assumed
&& seen_deferred
)
5473 return SPEC_EXPLICIT
;
5475 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5482 gfc_ref_this_image (gfc_ref
*ref
)
5486 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5488 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5489 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5496 gfc_find_team_co (gfc_expr
*e
)
5500 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5501 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5502 return ref
->u
.ar
.team
;
5504 if (e
->value
.function
.actual
->expr
)
5505 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5507 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5508 return ref
->u
.ar
.team
;
5514 gfc_find_stat_co (gfc_expr
*e
)
5518 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5519 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5520 return ref
->u
.ar
.stat
;
5522 if (e
->value
.function
.actual
->expr
)
5523 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5525 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5526 return ref
->u
.ar
.stat
;
5532 gfc_is_coindexed (gfc_expr
*e
)
5536 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5537 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5538 return !gfc_ref_this_image (ref
);
5544 /* Coarrays are variables with a corank but not being coindexed. However, also
5545 the following is a coarray: A subobject of a coarray is a coarray if it does
5546 not have any cosubscripts, vector subscripts, allocatable component
5547 selection, or pointer component selection. (F2008, 2.4.7) */
5550 gfc_is_coarray (gfc_expr
*e
)
5554 gfc_component
*comp
;
5559 if (e
->expr_type
!= EXPR_VARIABLE
)
5563 sym
= e
->symtree
->n
.sym
;
5565 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5566 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5568 coarray
= sym
->attr
.codimension
;
5570 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5574 comp
= ref
->u
.c
.component
;
5575 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5576 && (CLASS_DATA (comp
)->attr
.class_pointer
5577 || CLASS_DATA (comp
)->attr
.allocatable
))
5580 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5582 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5585 coarray
= comp
->attr
.codimension
;
5593 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5599 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5600 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5612 return coarray
&& !coindexed
;
5617 gfc_get_corank (gfc_expr
*e
)
5622 if (!gfc_is_coarray (e
))
5625 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5626 corank
= e
->ts
.u
.derived
->components
->as
5627 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5629 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5631 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5633 if (ref
->type
== REF_ARRAY
)
5634 corank
= ref
->u
.ar
.as
->corank
;
5635 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5642 /* Check whether the expression has an ultimate allocatable component.
5643 Being itself allocatable does not count. */
5645 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5647 gfc_ref
*ref
, *last
= NULL
;
5649 if (e
->expr_type
!= EXPR_VARIABLE
)
5652 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5653 if (ref
->type
== REF_COMPONENT
)
5656 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5657 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5658 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5659 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5663 if (e
->ts
.type
== BT_CLASS
)
5664 return CLASS_DATA (e
)->attr
.alloc_comp
;
5665 else if (e
->ts
.type
== BT_DERIVED
)
5666 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5672 /* Check whether the expression has an pointer component.
5673 Being itself a pointer does not count. */
5675 gfc_has_ultimate_pointer (gfc_expr
*e
)
5677 gfc_ref
*ref
, *last
= NULL
;
5679 if (e
->expr_type
!= EXPR_VARIABLE
)
5682 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5683 if (ref
->type
== REF_COMPONENT
)
5686 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5687 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5688 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5689 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5693 if (e
->ts
.type
== BT_CLASS
)
5694 return CLASS_DATA (e
)->attr
.pointer_comp
;
5695 else if (e
->ts
.type
== BT_DERIVED
)
5696 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5702 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5703 Note: A scalar is not regarded as "simply contiguous" by the standard.
5704 if bool is not strict, some further checks are done - for instance,
5705 a "(::1)" is accepted. */
5708 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5712 gfc_array_ref
*ar
= NULL
;
5713 gfc_ref
*ref
, *part_ref
= NULL
;
5716 if (expr
->expr_type
== EXPR_FUNCTION
)
5718 if (expr
->value
.function
.esym
)
5719 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5722 /* Type-bound procedures. */
5723 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5724 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5728 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5729 if (r
->type
== REF_COMPONENT
)
5732 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5733 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5736 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5739 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5742 if (!permit_element
&& expr
->rank
== 0)
5745 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5748 return false; /* Array shall be last part-ref. */
5750 if (ref
->type
== REF_COMPONENT
)
5752 else if (ref
->type
== REF_SUBSTRING
)
5754 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5758 sym
= expr
->symtree
->n
.sym
;
5759 if (expr
->ts
.type
!= BT_CLASS
5761 && !part_ref
->u
.c
.component
->attr
.contiguous
5762 && part_ref
->u
.c
.component
->attr
.pointer
)
5764 && !sym
->attr
.contiguous
5765 && (sym
->attr
.pointer
5766 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5767 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5770 if (!ar
|| ar
->type
== AR_FULL
)
5773 gcc_assert (ar
->type
== AR_SECTION
);
5775 /* Check for simply contiguous array */
5777 for (i
= 0; i
< ar
->dimen
; i
++)
5779 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5782 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5788 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5791 /* If the previous section was not contiguous, that's an error,
5792 unless we have effective only one element and checking is not
5794 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5795 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5796 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5797 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5798 ar
->end
[i
]->value
.integer
) != 0))
5801 /* Following the standard, "(::1)" or - if known at compile time -
5802 "(lbound:ubound)" are not simply contiguous; if strict
5803 is false, they are regarded as simply contiguous. */
5804 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5805 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5806 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5810 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5811 || !ar
->as
->lower
[i
]
5812 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5813 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5814 ar
->as
->lower
[i
]->value
.integer
) != 0))
5818 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5819 || !ar
->as
->upper
[i
]
5820 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5821 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5822 ar
->as
->upper
[i
]->value
.integer
) != 0))
5829 /* Return true if the expression is guaranteed to be non-contiguous,
5830 false if we cannot prove anything. It is probably best to call
5831 this after gfc_is_simply_contiguous. If neither of them returns
5832 true, we cannot say (at compile-time). */
5835 gfc_is_not_contiguous (gfc_expr
*array
)
5838 gfc_array_ref
*ar
= NULL
;
5840 bool previous_incomplete
;
5842 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
5844 /* Array-ref shall be last ref. */
5849 if (ref
->type
== REF_ARRAY
)
5853 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
5856 previous_incomplete
= false;
5858 /* Check if we can prove that the array is not contiguous. */
5860 for (i
= 0; i
< ar
->dimen
; i
++)
5862 mpz_t arr_size
, ref_size
;
5864 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
5866 if (gfc_dep_difference (ar
->as
->lower
[i
], ar
->as
->upper
[i
], &arr_size
))
5868 /* a(2:4,2:) is known to be non-contiguous, but
5869 a(2:4,i:i) can be contiguous. */
5870 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
5872 mpz_clear (arr_size
);
5873 mpz_clear (ref_size
);
5876 else if (mpz_cmp (arr_size
, ref_size
) != 0)
5877 previous_incomplete
= true;
5879 mpz_clear (arr_size
);
5882 /* Check for a(::2), i.e. where the stride is not unity.
5883 This is only done if there is more than one element in
5884 the reference along this dimension. */
5886 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
5887 && ar
->dimen_type
[i
] == DIMEN_RANGE
5888 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5889 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
5892 mpz_clear (ref_size
);
5895 /* We didn't find anything definitive. */
5899 /* Build call to an intrinsic procedure. The number of arguments has to be
5900 passed (rather than ending the list with a NULL value) because we may
5901 want to add arguments but with a NULL-expression. */
5904 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5905 locus where
, unsigned numarg
, ...)
5908 gfc_actual_arglist
* atail
;
5909 gfc_intrinsic_sym
* isym
;
5912 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5914 isym
= gfc_intrinsic_function_by_id (id
);
5917 result
= gfc_get_expr ();
5918 result
->expr_type
= EXPR_FUNCTION
;
5919 result
->ts
= isym
->ts
;
5920 result
->where
= where
;
5921 result
->value
.function
.name
= mangled_name
;
5922 result
->value
.function
.isym
= isym
;
5924 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5925 gfc_commit_symbol (result
->symtree
->n
.sym
);
5926 gcc_assert (result
->symtree
5927 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5928 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5929 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5930 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5931 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5932 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5934 va_start (ap
, numarg
);
5936 for (i
= 0; i
< numarg
; ++i
)
5940 atail
->next
= gfc_get_actual_arglist ();
5941 atail
= atail
->next
;
5944 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5946 atail
->expr
= va_arg (ap
, gfc_expr
*);
5954 /* Check if an expression may appear in a variable definition context
5955 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5956 This is called from the various places when resolving
5957 the pieces that make up such a context.
5958 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5959 variables), some checks are not performed.
5961 Optionally, a possible error message can be suppressed if context is NULL
5962 and just the return status (true / false) be requested. */
5965 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5966 bool own_scope
, const char* context
)
5968 gfc_symbol
* sym
= NULL
;
5970 bool check_intentin
;
5972 symbol_attribute attr
;
5976 if (e
->expr_type
== EXPR_VARIABLE
)
5978 gcc_assert (e
->symtree
);
5979 sym
= e
->symtree
->n
.sym
;
5981 else if (e
->expr_type
== EXPR_FUNCTION
)
5983 gcc_assert (e
->symtree
);
5984 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5987 attr
= gfc_expr_attr (e
);
5988 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5990 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5993 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5994 " context (%s) at %L", context
, &e
->where
);
5998 else if (e
->expr_type
!= EXPR_VARIABLE
)
6001 gfc_error ("Non-variable expression in variable definition context (%s)"
6002 " at %L", context
, &e
->where
);
6006 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
6009 gfc_error ("Named constant %qs in variable definition context (%s)"
6010 " at %L", sym
->name
, context
, &e
->where
);
6013 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
6014 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
6015 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
6018 gfc_error ("%qs in variable definition context (%s) at %L is not"
6019 " a variable", sym
->name
, context
, &e
->where
);
6023 /* Find out whether the expr is a pointer; this also means following
6024 component references to the last one. */
6025 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
6026 if (pointer
&& !is_pointer
)
6029 gfc_error ("Non-POINTER in pointer association context (%s)"
6030 " at %L", context
, &e
->where
);
6034 if (e
->ts
.type
== BT_DERIVED
6035 && e
->ts
.u
.derived
== NULL
)
6038 gfc_error ("Type inaccessible in variable definition context (%s) "
6039 "at %L", context
, &e
->where
);
6046 || (e
->ts
.type
== BT_DERIVED
6047 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6048 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
6051 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6052 context
, &e
->where
);
6056 /* TS18508, C702/C203. */
6059 || (e
->ts
.type
== BT_DERIVED
6060 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6061 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
6064 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6065 context
, &e
->where
);
6069 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6070 component of sub-component of a pointer; we need to distinguish
6071 assignment to a pointer component from pointer-assignment to a pointer
6072 component. Note that (normal) assignment to procedure pointers is not
6074 check_intentin
= !own_scope
;
6075 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
6076 && CLASS_DATA (sym
))
6077 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
6078 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
6080 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
6081 check_intentin
= false;
6082 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
6084 ptr_component
= true;
6086 check_intentin
= false;
6089 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
6091 if (pointer
&& is_pointer
)
6094 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6095 " association context (%s) at %L",
6096 sym
->name
, context
, &e
->where
);
6099 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
6102 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6103 " definition context (%s) at %L",
6104 sym
->name
, context
, &e
->where
);
6109 /* PROTECTED and use-associated. */
6110 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
6112 if (pointer
&& is_pointer
)
6115 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6116 " pointer association context (%s) at %L",
6117 sym
->name
, context
, &e
->where
);
6120 if (!pointer
&& !is_pointer
)
6123 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6124 " variable definition context (%s) at %L",
6125 sym
->name
, context
, &e
->where
);
6130 /* Variable not assignable from a PURE procedure but appears in
6131 variable definition context. */
6132 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6135 gfc_error ("Variable %qs cannot appear in a variable definition"
6136 " context (%s) at %L in PURE procedure",
6137 sym
->name
, context
, &e
->where
);
6141 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6142 && gfc_impure_variable (sym
))
6147 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6149 sym
= ns
->proc_name
;
6152 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6154 sym
->attr
.implicit_pure
= 0;
6159 /* Check variable definition context for associate-names. */
6160 if (!pointer
&& sym
->assoc
)
6163 gfc_association_list
* assoc
;
6165 gcc_assert (sym
->assoc
->target
);
6167 /* If this is a SELECT TYPE temporary (the association is used internally
6168 for SELECT TYPE), silently go over to the target. */
6169 if (sym
->attr
.select_type_temporary
)
6171 gfc_expr
* t
= sym
->assoc
->target
;
6173 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6174 name
= t
->symtree
->name
;
6176 if (t
->symtree
->n
.sym
->assoc
)
6177 assoc
= t
->symtree
->n
.sym
->assoc
;
6186 gcc_assert (name
&& assoc
);
6188 /* Is association to a valid variable? */
6189 if (!assoc
->variable
)
6193 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6194 gfc_error ("%qs at %L associated to vector-indexed target"
6195 " cannot be used in a variable definition"
6197 name
, &e
->where
, context
);
6199 gfc_error ("%qs at %L associated to expression"
6200 " cannot be used in a variable definition"
6202 name
, &e
->where
, context
);
6207 /* Target must be allowed to appear in a variable definition context. */
6208 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6211 gfc_error ("Associate-name %qs cannot appear in a variable"
6212 " definition context (%s) at %L because its target"
6213 " at %L cannot, either",
6214 name
, context
, &e
->where
,
6215 &assoc
->target
->where
);
6220 /* Check for same value in vector expression subscript. */
6223 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6224 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6225 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6226 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6227 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6229 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6230 if (arr
->expr_type
== EXPR_ARRAY
)
6232 gfc_constructor
*c
, *n
;
6235 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6236 c
!= NULL
; c
= gfc_constructor_next (c
))
6238 if (c
== NULL
|| c
->iterator
!= NULL
)
6243 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6244 n
= gfc_constructor_next (n
))
6246 if (n
->iterator
!= NULL
)
6250 if (gfc_dep_compare_expr (ec
, en
) == 0)
6253 gfc_error_now ("Elements with the same value "
6254 "at %L and %L in vector "
6255 "subscript in a variable "
6256 "definition context (%s)",
6257 &(ec
->where
), &(en
->where
),