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
);
395 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
397 q
->ref
= gfc_copy_ref (p
->ref
);
400 q
->param_list
= gfc_copy_actual_arglist (p
->param_list
);
407 gfc_clear_shape (mpz_t
*shape
, int rank
)
411 for (i
= 0; i
< rank
; i
++)
412 mpz_clear (shape
[i
]);
417 gfc_free_shape (mpz_t
**shape
, int rank
)
422 gfc_clear_shape (*shape
, rank
);
428 /* Workhorse function for gfc_free_expr() that frees everything
429 beneath an expression node, but not the node itself. This is
430 useful when we want to simplify a node and replace it with
431 something else or the expression node belongs to another structure. */
434 free_expr0 (gfc_expr
*e
)
436 switch (e
->expr_type
)
439 /* Free any parts of the value that need freeing. */
443 mpz_clear (e
->value
.integer
);
447 mpfr_clear (e
->value
.real
);
451 free (e
->value
.character
.string
);
455 mpc_clear (e
->value
.complex);
462 /* Free the representation. */
463 free (e
->representation
.string
);
468 if (e
->value
.op
.op1
!= NULL
)
469 gfc_free_expr (e
->value
.op
.op1
);
470 if (e
->value
.op
.op2
!= NULL
)
471 gfc_free_expr (e
->value
.op
.op2
);
475 gfc_free_actual_arglist (e
->value
.function
.actual
);
480 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
488 gfc_constructor_free (e
->value
.constructor
);
492 free (e
->value
.character
.string
);
499 gfc_internal_error ("free_expr0(): Bad expr type");
502 /* Free a shape array. */
503 gfc_free_shape (&e
->shape
, e
->rank
);
505 gfc_free_ref_list (e
->ref
);
507 gfc_free_actual_arglist (e
->param_list
);
509 memset (e
, '\0', sizeof (gfc_expr
));
513 /* Free an expression node and everything beneath it. */
516 gfc_free_expr (gfc_expr
*e
)
525 /* Free an argument list and everything below it. */
528 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
530 gfc_actual_arglist
*a2
;
536 gfc_free_expr (a1
->expr
);
543 /* Copy an arglist structure and all of the arguments. */
546 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
548 gfc_actual_arglist
*head
, *tail
, *new_arg
;
552 for (; p
; p
= p
->next
)
554 new_arg
= gfc_get_actual_arglist ();
557 new_arg
->expr
= gfc_copy_expr (p
->expr
);
558 new_arg
->next
= NULL
;
563 tail
->next
= new_arg
;
572 /* Free a list of reference structures. */
575 gfc_free_ref_list (gfc_ref
*p
)
587 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
589 gfc_free_expr (p
->u
.ar
.start
[i
]);
590 gfc_free_expr (p
->u
.ar
.end
[i
]);
591 gfc_free_expr (p
->u
.ar
.stride
[i
]);
597 gfc_free_expr (p
->u
.ss
.start
);
598 gfc_free_expr (p
->u
.ss
.end
);
611 /* Graft the *src expression onto the *dest subexpression. */
614 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
622 /* Try to extract an integer constant from the passed expression node.
623 Return true if some error occurred, false on success. If REPORT_ERROR
624 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
625 for negative using gfc_error_now. */
628 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
632 /* A KIND component is a parameter too. The expression for it
633 is stored in the initializer and should be consistent with
635 if (gfc_expr_attr(expr
).pdt_kind
)
637 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
639 if (ref
->u
.c
.component
->attr
.pdt_kind
)
640 expr
= ref
->u
.c
.component
->initializer
;
644 if (expr
->expr_type
!= EXPR_CONSTANT
)
646 if (report_error
> 0)
647 gfc_error ("Constant expression required at %C");
648 else if (report_error
< 0)
649 gfc_error_now ("Constant expression required at %C");
653 if (expr
->ts
.type
!= BT_INTEGER
)
655 if (report_error
> 0)
656 gfc_error ("Integer expression required at %C");
657 else if (report_error
< 0)
658 gfc_error_now ("Integer expression required at %C");
662 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
663 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
665 if (report_error
> 0)
666 gfc_error ("Integer value too large in expression at %C");
667 else if (report_error
< 0)
668 gfc_error_now ("Integer value too large in expression at %C");
672 *result
= (int) mpz_get_si (expr
->value
.integer
);
678 /* Same as gfc_extract_int, but use a HWI. */
681 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
, int report_error
)
685 /* A KIND component is a parameter too. The expression for it is
686 stored in the initializer and should be consistent with the tests
688 if (gfc_expr_attr(expr
).pdt_kind
)
690 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
692 if (ref
->u
.c
.component
->attr
.pdt_kind
)
693 expr
= ref
->u
.c
.component
->initializer
;
697 if (expr
->expr_type
!= EXPR_CONSTANT
)
699 if (report_error
> 0)
700 gfc_error ("Constant expression required at %C");
701 else if (report_error
< 0)
702 gfc_error_now ("Constant expression required at %C");
706 if (expr
->ts
.type
!= BT_INTEGER
)
708 if (report_error
> 0)
709 gfc_error ("Integer expression required at %C");
710 else if (report_error
< 0)
711 gfc_error_now ("Integer expression required at %C");
715 /* Use long_long_integer_type_node to determine when to saturate. */
716 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
717 expr
->value
.integer
, false);
719 if (!wi::fits_shwi_p (val
))
721 if (report_error
> 0)
722 gfc_error ("Integer value too large in expression at %C");
723 else if (report_error
< 0)
724 gfc_error_now ("Integer value too large in expression at %C");
728 *result
= val
.to_shwi ();
734 /* Recursively copy a list of reference structures. */
737 gfc_copy_ref (gfc_ref
*src
)
745 dest
= gfc_get_ref ();
746 dest
->type
= src
->type
;
751 ar
= gfc_copy_array_ref (&src
->u
.ar
);
757 dest
->u
.c
= src
->u
.c
;
761 dest
->u
.i
= src
->u
.i
;
765 dest
->u
.ss
= src
->u
.ss
;
766 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
767 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
771 dest
->next
= gfc_copy_ref (src
->next
);
777 /* Detect whether an expression has any vector index array references. */
780 gfc_has_vector_index (gfc_expr
*e
)
784 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
785 if (ref
->type
== REF_ARRAY
)
786 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
787 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
793 /* Copy a shape array. */
796 gfc_copy_shape (mpz_t
*shape
, int rank
)
804 new_shape
= gfc_get_shape (rank
);
806 for (n
= 0; n
< rank
; n
++)
807 mpz_init_set (new_shape
[n
], shape
[n
]);
813 /* Copy a shape array excluding dimension N, where N is an integer
814 constant expression. Dimensions are numbered in Fortran style --
817 So, if the original shape array contains R elements
818 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
819 the result contains R-1 elements:
820 { s1 ... sN-1 sN+1 ... sR-1}
822 If anything goes wrong -- N is not a constant, its value is out
823 of range -- or anything else, just returns NULL. */
826 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
828 mpz_t
*new_shape
, *s
;
834 || dim
->expr_type
!= EXPR_CONSTANT
835 || dim
->ts
.type
!= BT_INTEGER
)
838 n
= mpz_get_si (dim
->value
.integer
);
839 n
--; /* Convert to zero based index. */
840 if (n
< 0 || n
>= rank
)
843 s
= new_shape
= gfc_get_shape (rank
- 1);
845 for (i
= 0; i
< rank
; i
++)
849 mpz_init_set (*s
, shape
[i
]);
857 /* Return the maximum kind of two expressions. In general, higher
858 kind numbers mean more precision for numeric types. */
861 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
863 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
867 /* Returns nonzero if the type is numeric, zero otherwise. */
870 numeric_type (bt type
)
872 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
876 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
879 gfc_numeric_ts (gfc_typespec
*ts
)
881 return numeric_type (ts
->type
);
885 /* Return an expression node with an optional argument list attached.
886 A variable number of gfc_expr pointers are strung together in an
887 argument list with a NULL pointer terminating the list. */
890 gfc_build_conversion (gfc_expr
*e
)
895 p
->expr_type
= EXPR_FUNCTION
;
897 p
->value
.function
.actual
= gfc_get_actual_arglist ();
898 p
->value
.function
.actual
->expr
= e
;
904 /* Given an expression node with some sort of numeric binary
905 expression, insert type conversions required to make the operands
906 have the same type. Conversion warnings are disabled if wconversion
909 The exception is that the operands of an exponential don't have to
910 have the same type. If possible, the base is promoted to the type
911 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
912 1.0**2 stays as it is. */
915 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
919 op1
= e
->value
.op
.op1
;
920 op2
= e
->value
.op
.op2
;
922 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
924 gfc_clear_ts (&e
->ts
);
928 /* Kind conversions of same type. */
929 if (op1
->ts
.type
== op2
->ts
.type
)
931 if (op1
->ts
.kind
== op2
->ts
.kind
)
933 /* No type conversions. */
938 if (op1
->ts
.kind
> op2
->ts
.kind
)
939 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
941 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
947 /* Integer combined with real or complex. */
948 if (op2
->ts
.type
== BT_INTEGER
)
952 /* Special case for ** operator. */
953 if (e
->value
.op
.op
== INTRINSIC_POWER
)
956 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
960 if (op1
->ts
.type
== BT_INTEGER
)
963 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
967 /* Real combined with complex. */
968 e
->ts
.type
= BT_COMPLEX
;
969 if (op1
->ts
.kind
> op2
->ts
.kind
)
970 e
->ts
.kind
= op1
->ts
.kind
;
972 e
->ts
.kind
= op2
->ts
.kind
;
973 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
974 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
975 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
976 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
983 /* Determine if an expression is constant in the sense of F08:7.1.12.
984 * This function expects that the expression has already been simplified. */
987 gfc_is_constant_expr (gfc_expr
*e
)
990 gfc_actual_arglist
*arg
;
995 switch (e
->expr_type
)
998 return (gfc_is_constant_expr (e
->value
.op
.op1
)
999 && (e
->value
.op
.op2
== NULL
1000 || gfc_is_constant_expr (e
->value
.op
.op2
)));
1003 /* The only context in which this can occur is in a parameterized
1004 derived type declaration, so returning true is OK. */
1005 if (e
->symtree
->n
.sym
->attr
.pdt_len
1006 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1013 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1014 || e
->value
.function
.isym
);
1016 /* Call to intrinsic with at least one argument. */
1017 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1019 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1020 if (!gfc_is_constant_expr (arg
->expr
))
1024 if (e
->value
.function
.isym
1025 && (e
->value
.function
.isym
->elemental
1026 || e
->value
.function
.isym
->pure
1027 || e
->value
.function
.isym
->inquiry
1028 || e
->value
.function
.isym
->transformational
))
1037 case EXPR_SUBSTRING
:
1038 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1039 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1042 case EXPR_STRUCTURE
:
1043 c
= gfc_constructor_first (e
->value
.constructor
);
1044 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1045 return gfc_constant_ac (e
);
1047 for (; c
; c
= gfc_constructor_next (c
))
1048 if (!gfc_is_constant_expr (c
->expr
))
1055 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1061 /* Is true if an array reference is followed by a component or substring
1064 is_subref_array (gfc_expr
* e
)
1069 if (e
->expr_type
!= EXPR_VARIABLE
)
1072 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
1077 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1079 /* If we haven't seen the array reference and this is an intrinsic,
1080 what follows cannot be a subreference array. */
1081 if (!seen_array
&& ref
->type
== REF_COMPONENT
1082 && ref
->u
.c
.component
->ts
.type
!= BT_CLASS
1083 && !gfc_bt_struct (ref
->u
.c
.component
->ts
.type
))
1086 if (ref
->type
== REF_ARRAY
1087 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1091 && ref
->type
!= REF_ARRAY
)
1095 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1096 && e
->symtree
->n
.sym
->attr
.dummy
1097 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
1098 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
)
1105 /* Try to collapse intrinsic expressions. */
1108 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1110 gfc_intrinsic_op op
;
1111 gfc_expr
*op1
, *op2
, *result
;
1113 if (p
->value
.op
.op
== INTRINSIC_USER
)
1116 op1
= p
->value
.op
.op1
;
1117 op2
= p
->value
.op
.op2
;
1118 op
= p
->value
.op
.op
;
1120 if (!gfc_simplify_expr (op1
, type
))
1122 if (!gfc_simplify_expr (op2
, type
))
1125 if (!gfc_is_constant_expr (op1
)
1126 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1130 p
->value
.op
.op1
= NULL
;
1131 p
->value
.op
.op2
= NULL
;
1135 case INTRINSIC_PARENTHESES
:
1136 result
= gfc_parentheses (op1
);
1139 case INTRINSIC_UPLUS
:
1140 result
= gfc_uplus (op1
);
1143 case INTRINSIC_UMINUS
:
1144 result
= gfc_uminus (op1
);
1147 case INTRINSIC_PLUS
:
1148 result
= gfc_add (op1
, op2
);
1151 case INTRINSIC_MINUS
:
1152 result
= gfc_subtract (op1
, op2
);
1155 case INTRINSIC_TIMES
:
1156 result
= gfc_multiply (op1
, op2
);
1159 case INTRINSIC_DIVIDE
:
1160 result
= gfc_divide (op1
, op2
);
1163 case INTRINSIC_POWER
:
1164 result
= gfc_power (op1
, op2
);
1167 case INTRINSIC_CONCAT
:
1168 result
= gfc_concat (op1
, op2
);
1172 case INTRINSIC_EQ_OS
:
1173 result
= gfc_eq (op1
, op2
, op
);
1177 case INTRINSIC_NE_OS
:
1178 result
= gfc_ne (op1
, op2
, op
);
1182 case INTRINSIC_GT_OS
:
1183 result
= gfc_gt (op1
, op2
, op
);
1187 case INTRINSIC_GE_OS
:
1188 result
= gfc_ge (op1
, op2
, op
);
1192 case INTRINSIC_LT_OS
:
1193 result
= gfc_lt (op1
, op2
, op
);
1197 case INTRINSIC_LE_OS
:
1198 result
= gfc_le (op1
, op2
, op
);
1202 result
= gfc_not (op1
);
1206 result
= gfc_and (op1
, op2
);
1210 result
= gfc_or (op1
, op2
);
1214 result
= gfc_eqv (op1
, op2
);
1217 case INTRINSIC_NEQV
:
1218 result
= gfc_neqv (op1
, op2
);
1222 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1227 gfc_free_expr (op1
);
1228 gfc_free_expr (op2
);
1232 result
->rank
= p
->rank
;
1233 result
->where
= p
->where
;
1234 gfc_replace_expr (p
, result
);
1240 /* Subroutine to simplify constructor expressions. Mutually recursive
1241 with gfc_simplify_expr(). */
1244 simplify_constructor (gfc_constructor_base base
, int type
)
1249 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1252 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1253 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1254 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1259 /* Try and simplify a copy. Replace the original if successful
1260 but keep going through the constructor at all costs. Not
1261 doing so can make a dog's dinner of complicated things. */
1262 p
= gfc_copy_expr (c
->expr
);
1264 if (!gfc_simplify_expr (p
, type
))
1270 gfc_replace_expr (c
->expr
, p
);
1278 /* Pull a single array element out of an array constructor. */
1281 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1282 gfc_constructor
**rval
)
1284 unsigned long nelemen
;
1290 gfc_constructor
*cons
;
1297 mpz_init_set_ui (offset
, 0);
1300 mpz_init_set_ui (span
, 1);
1301 for (i
= 0; i
< ar
->dimen
; i
++)
1303 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1304 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1312 if (e
->expr_type
!= EXPR_CONSTANT
)
1318 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1319 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1321 /* Check the bounds. */
1322 if ((ar
->as
->upper
[i
]
1323 && mpz_cmp (e
->value
.integer
,
1324 ar
->as
->upper
[i
]->value
.integer
) > 0)
1325 || (mpz_cmp (e
->value
.integer
,
1326 ar
->as
->lower
[i
]->value
.integer
) < 0))
1328 gfc_error ("Index in dimension %d is out of bounds "
1329 "at %L", i
+ 1, &ar
->c_where
[i
]);
1335 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1336 mpz_mul (delta
, delta
, span
);
1337 mpz_add (offset
, offset
, delta
);
1339 mpz_set_ui (tmp
, 1);
1340 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1341 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1342 mpz_mul (span
, span
, tmp
);
1345 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1346 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1365 /* Find a component of a structure constructor. */
1367 static gfc_constructor
*
1368 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1370 gfc_component
*pick
= ref
->u
.c
.component
;
1371 gfc_constructor
*c
= gfc_constructor_first (base
);
1373 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1374 int ext
= dt
->attr
.extension
;
1376 /* For extended types, check if the desired component is in one of the
1378 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1379 pick
->name
, true, true, NULL
))
1381 dt
= dt
->components
->ts
.u
.derived
;
1382 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1386 gfc_component
*comp
= dt
->components
;
1387 while (comp
!= pick
)
1390 c
= gfc_constructor_next (c
);
1397 /* Replace an expression with the contents of a constructor, removing
1398 the subobject reference in the process. */
1401 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1411 e
= gfc_copy_expr (p
);
1412 e
->ref
= p
->ref
->next
;
1413 p
->ref
->next
= NULL
;
1414 gfc_replace_expr (p
, e
);
1418 /* Pull an array section out of an array constructor. */
1421 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1428 long unsigned one
= 1;
1430 mpz_t start
[GFC_MAX_DIMENSIONS
];
1431 mpz_t end
[GFC_MAX_DIMENSIONS
];
1432 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1433 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1434 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1439 gfc_constructor_base base
;
1440 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1450 base
= expr
->value
.constructor
;
1451 expr
->value
.constructor
= NULL
;
1453 rank
= ref
->u
.ar
.as
->rank
;
1455 if (expr
->shape
== NULL
)
1456 expr
->shape
= gfc_get_shape (rank
);
1458 mpz_init_set_ui (delta_mpz
, one
);
1459 mpz_init_set_ui (nelts
, one
);
1462 /* Do the initialization now, so that we can cleanup without
1463 keeping track of where we were. */
1464 for (d
= 0; d
< rank
; d
++)
1466 mpz_init (delta
[d
]);
1467 mpz_init (start
[d
]);
1470 mpz_init (stride
[d
]);
1474 /* Build the counters to clock through the array reference. */
1476 for (d
= 0; d
< rank
; d
++)
1478 /* Make this stretch of code easier on the eye! */
1479 begin
= ref
->u
.ar
.start
[d
];
1480 finish
= ref
->u
.ar
.end
[d
];
1481 step
= ref
->u
.ar
.stride
[d
];
1482 lower
= ref
->u
.ar
.as
->lower
[d
];
1483 upper
= ref
->u
.ar
.as
->upper
[d
];
1485 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1487 gfc_constructor
*ci
;
1490 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1496 gcc_assert (begin
->rank
== 1);
1497 /* Zero-sized arrays have no shape and no elements, stop early. */
1500 mpz_init_set_ui (nelts
, 0);
1504 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1505 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1506 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1507 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1510 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1512 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1513 || mpz_cmp (ci
->expr
->value
.integer
,
1514 lower
->value
.integer
) < 0)
1516 gfc_error ("index in dimension %d is out of bounds "
1517 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1525 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1526 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1527 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1533 /* Obtain the stride. */
1535 mpz_set (stride
[d
], step
->value
.integer
);
1537 mpz_set_ui (stride
[d
], one
);
1539 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1540 mpz_set_ui (stride
[d
], one
);
1542 /* Obtain the start value for the index. */
1544 mpz_set (start
[d
], begin
->value
.integer
);
1546 mpz_set (start
[d
], lower
->value
.integer
);
1548 mpz_set (ctr
[d
], start
[d
]);
1550 /* Obtain the end value for the index. */
1552 mpz_set (end
[d
], finish
->value
.integer
);
1554 mpz_set (end
[d
], upper
->value
.integer
);
1556 /* Separate 'if' because elements sometimes arrive with
1558 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1559 mpz_set (end
[d
], begin
->value
.integer
);
1561 /* Check the bounds. */
1562 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1563 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1564 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1565 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1567 gfc_error ("index in dimension %d is out of bounds "
1568 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1573 /* Calculate the number of elements and the shape. */
1574 mpz_set (tmp_mpz
, stride
[d
]);
1575 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1576 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1577 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1578 mpz_mul (nelts
, nelts
, tmp_mpz
);
1580 /* An element reference reduces the rank of the expression; don't
1581 add anything to the shape array. */
1582 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1583 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1586 /* Calculate the 'stride' (=delta) for conversion of the
1587 counter values into the index along the constructor. */
1588 mpz_set (delta
[d
], delta_mpz
);
1589 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1590 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1591 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1595 cons
= gfc_constructor_first (base
);
1597 /* Now clock through the array reference, calculating the index in
1598 the source constructor and transferring the elements to the new
1600 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1602 mpz_init_set_ui (ptr
, 0);
1605 for (d
= 0; d
< rank
; d
++)
1607 mpz_set (tmp_mpz
, ctr
[d
]);
1608 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1609 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1610 mpz_add (ptr
, ptr
, tmp_mpz
);
1612 if (!incr_ctr
) continue;
1614 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1616 gcc_assert(vecsub
[d
]);
1618 if (!gfc_constructor_next (vecsub
[d
]))
1619 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1622 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1625 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1629 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1631 if (mpz_cmp_ui (stride
[d
], 0) > 0
1632 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1633 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1634 mpz_set (ctr
[d
], start
[d
]);
1640 limit
= mpz_get_ui (ptr
);
1641 if (limit
>= flag_max_array_constructor
)
1643 gfc_error ("The number of elements in the array constructor "
1644 "at %L requires an increase of the allowed %d "
1645 "upper limit. See %<-fmax-array-constructor%> "
1646 "option", &expr
->where
, flag_max_array_constructor
);
1650 cons
= gfc_constructor_lookup (base
, limit
);
1652 gfc_constructor_append_expr (&expr
->value
.constructor
,
1653 gfc_copy_expr (cons
->expr
), NULL
);
1660 mpz_clear (delta_mpz
);
1661 mpz_clear (tmp_mpz
);
1663 for (d
= 0; d
< rank
; d
++)
1665 mpz_clear (delta
[d
]);
1666 mpz_clear (start
[d
]);
1669 mpz_clear (stride
[d
]);
1671 gfc_constructor_free (base
);
1675 /* Pull a substring out of an expression. */
1678 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1681 gfc_charlen_t start
;
1682 gfc_charlen_t length
;
1685 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1686 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1689 *newp
= gfc_copy_expr (p
);
1690 free ((*newp
)->value
.character
.string
);
1692 end
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1693 start
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1695 length
= end
- start
+ 1;
1699 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1700 (*newp
)->value
.character
.length
= length
;
1701 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1702 length
* sizeof (gfc_char_t
));
1708 /* Pull an inquiry result out of an expression. */
1711 find_inquiry_ref (gfc_expr
*p
, gfc_expr
**newp
)
1714 gfc_ref
*inquiry
= NULL
;
1717 tmp
= gfc_copy_expr (p
);
1719 if (tmp
->ref
&& tmp
->ref
->type
== REF_INQUIRY
)
1726 for (ref
= tmp
->ref
; ref
; ref
= ref
->next
)
1727 if (ref
->next
&& ref
->next
->type
== REF_INQUIRY
)
1729 inquiry
= ref
->next
;
1736 gfc_free_expr (tmp
);
1740 gfc_resolve_expr (tmp
);
1742 /* In principle there can be more than one inquiry reference. */
1743 for (; inquiry
; inquiry
= inquiry
->next
)
1745 switch (inquiry
->u
.i
)
1748 if (tmp
->ts
.type
!= BT_CHARACTER
)
1751 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1754 if (!tmp
->ts
.u
.cl
->length
1755 || tmp
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1758 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1762 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1765 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1768 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1769 NULL
, tmp
->ts
.kind
);
1773 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1776 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1779 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1780 mpfr_set ((*newp
)->value
.real
,
1781 mpc_realref (p
->value
.complex), GFC_RND_MODE
);
1785 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1788 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1791 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1792 mpfr_set ((*newp
)->value
.real
,
1793 mpc_imagref (p
->value
.complex), GFC_RND_MODE
);
1796 tmp
= gfc_copy_expr (*newp
);
1801 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1803 gfc_free_expr (*newp
);
1807 gfc_free_expr (tmp
);
1811 gfc_free_expr (tmp
);
1817 /* Simplify a subobject reference of a constructor. This occurs when
1818 parameter variable values are substituted. */
1821 simplify_const_ref (gfc_expr
*p
)
1823 gfc_constructor
*cons
, *c
;
1824 gfc_expr
*newp
= NULL
;
1829 switch (p
->ref
->type
)
1832 switch (p
->ref
->u
.ar
.type
)
1835 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1836 will generate this. */
1837 if (p
->expr_type
!= EXPR_ARRAY
)
1839 remove_subobject_ref (p
, NULL
);
1842 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1848 remove_subobject_ref (p
, cons
);
1852 if (!find_array_section (p
, p
->ref
))
1854 p
->ref
->u
.ar
.type
= AR_FULL
;
1859 if (p
->ref
->next
!= NULL
1860 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1862 for (c
= gfc_constructor_first (p
->value
.constructor
);
1863 c
; c
= gfc_constructor_next (c
))
1865 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1866 if (!simplify_const_ref (c
->expr
))
1870 if (gfc_bt_struct (p
->ts
.type
)
1872 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1874 /* There may have been component references. */
1875 p
->ts
= c
->expr
->ts
;
1879 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1881 if (p
->ts
.type
== BT_CHARACTER
1882 && last_ref
->type
== REF_SUBSTRING
)
1884 /* If this is a CHARACTER array and we possibly took
1885 a substring out of it, update the type-spec's
1886 character length according to the first element
1887 (as all should have the same length). */
1888 gfc_charlen_t string_len
;
1889 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1891 const gfc_expr
* first
= c
->expr
;
1892 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1893 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1894 string_len
= first
->value
.character
.length
;
1902 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1905 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
,
1909 gfc_free_expr (p
->ts
.u
.cl
->length
);
1912 = gfc_get_int_expr (gfc_charlen_int_kind
,
1916 gfc_free_ref_list (p
->ref
);
1927 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1928 remove_subobject_ref (p
, cons
);
1932 if (!find_inquiry_ref (p
, &newp
))
1935 gfc_replace_expr (p
, newp
);
1936 gfc_free_ref_list (p
->ref
);
1941 if (!find_substring_ref (p
, &newp
))
1944 gfc_replace_expr (p
, newp
);
1945 gfc_free_ref_list (p
->ref
);
1955 /* Simplify a chain of references. */
1958 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
1963 for (; ref
; ref
= ref
->next
)
1968 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1970 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1972 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1974 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1980 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1982 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1987 if (!find_inquiry_ref (*p
, &newp
))
1990 gfc_replace_expr (*p
, newp
);
1991 gfc_free_ref_list ((*p
)->ref
);
2003 /* Try to substitute the value of a parameter variable. */
2006 simplify_parameter_variable (gfc_expr
*p
, int type
)
2011 if (gfc_is_size_zero_array (p
))
2013 if (p
->expr_type
== EXPR_ARRAY
)
2016 e
= gfc_get_expr ();
2017 e
->expr_type
= EXPR_ARRAY
;
2020 e
->value
.constructor
= NULL
;
2021 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2022 e
->where
= p
->where
;
2023 gfc_replace_expr (p
, e
);
2027 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2033 /* Do not copy subobject refs for constant. */
2034 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2035 e
->ref
= gfc_copy_ref (p
->ref
);
2036 t
= gfc_simplify_expr (e
, type
);
2038 /* Only use the simplification if it eliminated all subobject references. */
2040 gfc_replace_expr (p
, e
);
2049 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2051 /* Given an expression, simplify it by collapsing constant
2052 expressions. Most simplification takes place when the expression
2053 tree is being constructed. If an intrinsic function is simplified
2054 at some point, we get called again to collapse the result against
2057 We work by recursively simplifying expression nodes, simplifying
2058 intrinsic functions where possible, which can lead to further
2059 constant collapsing. If an operator has constant operand(s), we
2060 rip the expression apart, and rebuild it, hoping that it becomes
2063 The expression type is defined for:
2064 0 Basic expression parsing
2065 1 Simplifying array constructors -- will substitute
2067 Returns false on error, true otherwise.
2068 NOTE: Will return true even if the expression cannot be simplified. */
2071 gfc_simplify_expr (gfc_expr
*p
, int type
)
2073 gfc_actual_arglist
*ap
;
2074 gfc_intrinsic_sym
* isym
= NULL
;
2080 switch (p
->expr_type
)
2083 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2084 simplify_ref_chain (p
->ref
, type
, &p
);
2090 // For array-bound functions, we don't need to optimize
2091 // the 'array' argument. In particular, if the argument
2092 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2093 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2094 // can have any lbound.
2095 ap
= p
->value
.function
.actual
;
2096 if (p
->value
.function
.isym
&&
2097 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2098 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2099 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2100 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
))
2103 for ( ; ap
; ap
= ap
->next
)
2104 if (!gfc_simplify_expr (ap
->expr
, type
))
2107 if (p
->value
.function
.isym
!= NULL
2108 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2111 if (p
->expr_type
== EXPR_FUNCTION
)
2114 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2115 if (isym
&& isym
->elemental
)
2116 scalarize_intrinsic_call (p
, false);
2121 case EXPR_SUBSTRING
:
2122 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2125 if (gfc_is_constant_expr (p
))
2128 HOST_WIDE_INT start
, end
;
2131 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2133 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2134 start
--; /* Convert from one-based to zero-based. */
2137 end
= p
->value
.character
.length
;
2138 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2139 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2144 s
= gfc_get_wide_string (end
- start
+ 2);
2145 memcpy (s
, p
->value
.character
.string
+ start
,
2146 (end
- start
) * sizeof (gfc_char_t
));
2147 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2148 free (p
->value
.character
.string
);
2149 p
->value
.character
.string
= s
;
2150 p
->value
.character
.length
= end
- start
;
2151 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2152 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2154 p
->value
.character
.length
);
2155 gfc_free_ref_list (p
->ref
);
2157 p
->expr_type
= EXPR_CONSTANT
;
2162 if (!simplify_intrinsic_op (p
, type
))
2167 /* Only substitute array parameter variables if we are in an
2168 initialization expression, or we want a subsection. */
2169 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2170 && (gfc_init_expr_flag
|| p
->ref
2171 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2173 if (!simplify_parameter_variable (p
, type
))
2180 gfc_simplify_iterator_var (p
);
2183 /* Simplify subcomponent references. */
2184 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2189 case EXPR_STRUCTURE
:
2191 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2194 if (!simplify_constructor (p
->value
.constructor
, type
))
2197 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2198 && p
->ref
->u
.ar
.type
== AR_FULL
)
2199 gfc_expand_constructor (p
, false);
2201 if (!simplify_const_ref (p
))
2215 /* Returns the type of an expression with the exception that iterator
2216 variables are automatically integers no matter what else they may
2222 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2229 /* Scalarize an expression for an elemental intrinsic call. */
2232 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2234 gfc_actual_arglist
*a
, *b
;
2235 gfc_constructor_base ctor
;
2236 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2237 gfc_constructor
*ci
, *new_ctor
;
2238 gfc_expr
*expr
, *old
;
2239 int n
, i
, rank
[5], array_arg
;
2245 a
= e
->value
.function
.actual
;
2246 for (; a
; a
= a
->next
)
2247 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2250 /* Find which, if any, arguments are arrays. Assume that the old
2251 expression carries the type information and that the first arg
2252 that is an array expression carries all the shape information.*/
2254 a
= e
->value
.function
.actual
;
2255 for (; a
; a
= a
->next
)
2258 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2261 expr
= gfc_copy_expr (a
->expr
);
2268 old
= gfc_copy_expr (e
);
2270 gfc_constructor_free (expr
->value
.constructor
);
2271 expr
->value
.constructor
= NULL
;
2273 expr
->where
= old
->where
;
2274 expr
->expr_type
= EXPR_ARRAY
;
2276 /* Copy the array argument constructors into an array, with nulls
2279 a
= old
->value
.function
.actual
;
2280 for (; a
; a
= a
->next
)
2282 /* Check that this is OK for an initialization expression. */
2283 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2287 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2289 rank
[n
] = a
->expr
->rank
;
2290 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2291 args
[n
] = gfc_constructor_first (ctor
);
2293 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2296 rank
[n
] = a
->expr
->rank
;
2299 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2300 args
[n
] = gfc_constructor_first (ctor
);
2308 gfc_get_errors (NULL
, &errors
);
2310 /* Using the array argument as the master, step through the array
2311 calling the function for each element and advancing the array
2312 constructors together. */
2313 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2315 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2316 gfc_copy_expr (old
), NULL
);
2318 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2320 b
= old
->value
.function
.actual
;
2321 for (i
= 0; i
< n
; i
++)
2324 new_ctor
->expr
->value
.function
.actual
2325 = a
= gfc_get_actual_arglist ();
2328 a
->next
= gfc_get_actual_arglist ();
2333 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2335 a
->expr
= gfc_copy_expr (b
->expr
);
2340 /* Simplify the function calls. If the simplification fails, the
2341 error will be flagged up down-stream or the library will deal
2344 gfc_simplify_expr (new_ctor
->expr
, 0);
2346 for (i
= 0; i
< n
; i
++)
2348 args
[i
] = gfc_constructor_next (args
[i
]);
2350 for (i
= 1; i
< n
; i
++)
2351 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2352 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2358 /* Free "expr" but not the pointers it contains. */
2360 gfc_free_expr (old
);
2364 gfc_error_now ("elemental function arguments at %C are not compliant");
2367 gfc_free_expr (expr
);
2368 gfc_free_expr (old
);
2374 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2376 gfc_expr
*op1
= e
->value
.op
.op1
;
2377 gfc_expr
*op2
= e
->value
.op
.op2
;
2379 if (!(*check_function
)(op1
))
2382 switch (e
->value
.op
.op
)
2384 case INTRINSIC_UPLUS
:
2385 case INTRINSIC_UMINUS
:
2386 if (!numeric_type (et0 (op1
)))
2391 case INTRINSIC_EQ_OS
:
2393 case INTRINSIC_NE_OS
:
2395 case INTRINSIC_GT_OS
:
2397 case INTRINSIC_GE_OS
:
2399 case INTRINSIC_LT_OS
:
2401 case INTRINSIC_LE_OS
:
2402 if (!(*check_function
)(op2
))
2405 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2406 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2408 gfc_error ("Numeric or CHARACTER operands are required in "
2409 "expression at %L", &e
->where
);
2414 case INTRINSIC_PLUS
:
2415 case INTRINSIC_MINUS
:
2416 case INTRINSIC_TIMES
:
2417 case INTRINSIC_DIVIDE
:
2418 case INTRINSIC_POWER
:
2419 if (!(*check_function
)(op2
))
2422 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2427 case INTRINSIC_CONCAT
:
2428 if (!(*check_function
)(op2
))
2431 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2433 gfc_error ("Concatenation operator in expression at %L "
2434 "must have two CHARACTER operands", &op1
->where
);
2438 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2440 gfc_error ("Concat operator at %L must concatenate strings of the "
2441 "same kind", &e
->where
);
2448 if (et0 (op1
) != BT_LOGICAL
)
2450 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2451 "operand", &op1
->where
);
2460 case INTRINSIC_NEQV
:
2461 if (!(*check_function
)(op2
))
2464 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2466 gfc_error ("LOGICAL operands are required in expression at %L",
2473 case INTRINSIC_PARENTHESES
:
2477 gfc_error ("Only intrinsic operators can be used in expression at %L",
2485 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2490 /* F2003, 7.1.7 (3): In init expression, allocatable components
2491 must not be data-initialized. */
2493 check_alloc_comp_init (gfc_expr
*e
)
2495 gfc_component
*comp
;
2496 gfc_constructor
*ctor
;
2498 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2499 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2501 for (comp
= e
->ts
.u
.derived
->components
,
2502 ctor
= gfc_constructor_first (e
->value
.constructor
);
2503 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2505 if (comp
->attr
.allocatable
&& ctor
->expr
2506 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2508 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2509 "component %qs in structure constructor at %L",
2510 comp
->name
, &ctor
->expr
->where
);
2519 check_init_expr_arguments (gfc_expr
*e
)
2521 gfc_actual_arglist
*ap
;
2523 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2524 if (!gfc_check_init_expr (ap
->expr
))
2530 static bool check_restricted (gfc_expr
*);
2532 /* F95, 7.1.6.1, Initialization expressions, (7)
2533 F2003, 7.1.7 Initialization expression, (8)
2534 F2008, 7.1.12 Constant expression, (4) */
2537 check_inquiry (gfc_expr
*e
, int not_restricted
)
2540 const char *const *functions
;
2542 static const char *const inquiry_func_f95
[] = {
2543 "lbound", "shape", "size", "ubound",
2544 "bit_size", "len", "kind",
2545 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2546 "precision", "radix", "range", "tiny",
2550 static const char *const inquiry_func_f2003
[] = {
2551 "lbound", "shape", "size", "ubound",
2552 "bit_size", "len", "kind",
2553 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2554 "precision", "radix", "range", "tiny",
2558 /* std=f2008+ or -std=gnu */
2559 static const char *const inquiry_func_gnu
[] = {
2560 "lbound", "shape", "size", "ubound",
2561 "bit_size", "len", "kind",
2562 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2563 "precision", "radix", "range", "tiny",
2564 "new_line", "storage_size", NULL
2568 gfc_actual_arglist
*ap
;
2570 if (!e
->value
.function
.isym
2571 || !e
->value
.function
.isym
->inquiry
)
2574 /* An undeclared parameter will get us here (PR25018). */
2575 if (e
->symtree
== NULL
)
2578 if (e
->symtree
->n
.sym
->from_intmod
)
2580 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2581 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2582 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2585 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2586 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2591 name
= e
->symtree
->n
.sym
->name
;
2593 functions
= inquiry_func_gnu
;
2594 if (gfc_option
.warn_std
& GFC_STD_F2003
)
2595 functions
= inquiry_func_f2003
;
2596 if (gfc_option
.warn_std
& GFC_STD_F95
)
2597 functions
= inquiry_func_f95
;
2599 for (i
= 0; functions
[i
]; i
++)
2600 if (strcmp (functions
[i
], name
) == 0)
2603 if (functions
[i
] == NULL
)
2607 /* At this point we have an inquiry function with a variable argument. The
2608 type of the variable might be undefined, but we need it now, because the
2609 arguments of these functions are not allowed to be undefined. */
2611 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2616 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2618 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2619 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2622 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2625 /* Assumed character length will not reduce to a constant expression
2626 with LEN, as required by the standard. */
2627 if (i
== 5 && not_restricted
&& ap
->expr
->symtree
2628 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2629 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2630 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2632 gfc_error ("Assumed or deferred character length variable %qs "
2633 "in constant expression at %L",
2634 ap
->expr
->symtree
->n
.sym
->name
,
2638 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2641 if (not_restricted
== 0
2642 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2643 && !check_restricted (ap
->expr
))
2646 if (not_restricted
== 0
2647 && ap
->expr
->expr_type
== EXPR_VARIABLE
2648 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2649 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2657 /* F95, 7.1.6.1, Initialization expressions, (5)
2658 F2003, 7.1.7 Initialization expression, (5) */
2661 check_transformational (gfc_expr
*e
)
2663 static const char * const trans_func_f95
[] = {
2664 "repeat", "reshape", "selected_int_kind",
2665 "selected_real_kind", "transfer", "trim", NULL
2668 static const char * const trans_func_f2003
[] = {
2669 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2670 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2671 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2672 "trim", "unpack", NULL
2675 static const char * const trans_func_f2008
[] = {
2676 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2677 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2678 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2679 "trim", "unpack", "findloc", NULL
2684 const char *const *functions
;
2686 if (!e
->value
.function
.isym
2687 || !e
->value
.function
.isym
->transformational
)
2690 name
= e
->symtree
->n
.sym
->name
;
2692 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2693 functions
= trans_func_f2008
;
2694 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2695 functions
= trans_func_f2003
;
2697 functions
= trans_func_f95
;
2699 /* NULL() is dealt with below. */
2700 if (strcmp ("null", name
) == 0)
2703 for (i
= 0; functions
[i
]; i
++)
2704 if (strcmp (functions
[i
], name
) == 0)
2707 if (functions
[i
] == NULL
)
2709 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2710 "in an initialization expression", name
, &e
->where
);
2714 return check_init_expr_arguments (e
);
2718 /* F95, 7.1.6.1, Initialization expressions, (6)
2719 F2003, 7.1.7 Initialization expression, (6) */
2722 check_null (gfc_expr
*e
)
2724 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2727 return check_init_expr_arguments (e
);
2732 check_elemental (gfc_expr
*e
)
2734 if (!e
->value
.function
.isym
2735 || !e
->value
.function
.isym
->elemental
)
2738 if (e
->ts
.type
!= BT_INTEGER
2739 && e
->ts
.type
!= BT_CHARACTER
2740 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2741 "initialization expression at %L", &e
->where
))
2744 return check_init_expr_arguments (e
);
2749 check_conversion (gfc_expr
*e
)
2751 if (!e
->value
.function
.isym
2752 || !e
->value
.function
.isym
->conversion
)
2755 return check_init_expr_arguments (e
);
2759 /* Verify that an expression is an initialization expression. A side
2760 effect is that the expression tree is reduced to a single constant
2761 node if all goes well. This would normally happen when the
2762 expression is constructed but function references are assumed to be
2763 intrinsics in the context of initialization expressions. If
2764 false is returned an error message has been generated. */
2767 gfc_check_init_expr (gfc_expr
*e
)
2775 switch (e
->expr_type
)
2778 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2780 t
= gfc_simplify_expr (e
, 0);
2789 gfc_intrinsic_sym
* isym
= NULL
;
2790 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2792 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2793 IEEE_EXCEPTIONS modules. */
2794 int mod
= sym
->from_intmod
;
2795 if (mod
== INTMOD_NONE
&& sym
->generic
)
2796 mod
= sym
->generic
->sym
->from_intmod
;
2797 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2799 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2802 gfc_replace_expr (e
, new_expr
);
2808 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2809 into an array constructor, we need to skip the error check here.
2810 Conversion errors are caught below in scalarize_intrinsic_call. */
2811 conversion
= e
->value
.function
.isym
2812 && (e
->value
.function
.isym
->conversion
== 1);
2814 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2815 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2817 gfc_error ("Function %qs in initialization expression at %L "
2818 "must be an intrinsic function",
2819 e
->symtree
->n
.sym
->name
, &e
->where
);
2823 if ((m
= check_conversion (e
)) == MATCH_NO
2824 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2825 && (m
= check_null (e
)) == MATCH_NO
2826 && (m
= check_transformational (e
)) == MATCH_NO
2827 && (m
= check_elemental (e
)) == MATCH_NO
)
2829 gfc_error ("Intrinsic function %qs at %L is not permitted "
2830 "in an initialization expression",
2831 e
->symtree
->n
.sym
->name
, &e
->where
);
2835 if (m
== MATCH_ERROR
)
2838 /* Try to scalarize an elemental intrinsic function that has an
2840 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2841 if (isym
&& isym
->elemental
2842 && (t
= scalarize_intrinsic_call (e
, true)))
2847 t
= gfc_simplify_expr (e
, 0);
2854 /* This occurs when parsing pdt templates. */
2855 if (gfc_expr_attr (e
).pdt_kind
)
2858 if (gfc_check_iter_variable (e
))
2861 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2863 /* A PARAMETER shall not be used to define itself, i.e.
2864 REAL, PARAMETER :: x = transfer(0, x)
2866 if (!e
->symtree
->n
.sym
->value
)
2868 gfc_error ("PARAMETER %qs is used at %L before its definition "
2869 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2873 t
= simplify_parameter_variable (e
, 0);
2878 if (gfc_in_match_data ())
2883 if (e
->symtree
->n
.sym
->as
)
2885 switch (e
->symtree
->n
.sym
->as
->type
)
2887 case AS_ASSUMED_SIZE
:
2888 gfc_error ("Assumed size array %qs at %L is not permitted "
2889 "in an initialization expression",
2890 e
->symtree
->n
.sym
->name
, &e
->where
);
2893 case AS_ASSUMED_SHAPE
:
2894 gfc_error ("Assumed shape array %qs at %L is not permitted "
2895 "in an initialization expression",
2896 e
->symtree
->n
.sym
->name
, &e
->where
);
2900 if (!e
->symtree
->n
.sym
->attr
.allocatable
2901 && !e
->symtree
->n
.sym
->attr
.pointer
2902 && e
->symtree
->n
.sym
->attr
.dummy
)
2903 gfc_error ("Assumed-shape array %qs at %L is not permitted "
2904 "in an initialization expression",
2905 e
->symtree
->n
.sym
->name
, &e
->where
);
2907 gfc_error ("Deferred array %qs at %L is not permitted "
2908 "in an initialization expression",
2909 e
->symtree
->n
.sym
->name
, &e
->where
);
2913 gfc_error ("Array %qs at %L is a variable, which does "
2914 "not reduce to a constant expression",
2915 e
->symtree
->n
.sym
->name
, &e
->where
);
2923 gfc_error ("Parameter %qs at %L has not been declared or is "
2924 "a variable, which does not reduce to a constant "
2925 "expression", e
->symtree
->name
, &e
->where
);
2934 case EXPR_SUBSTRING
:
2937 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2941 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2943 t
= gfc_simplify_expr (e
, 0);
2949 case EXPR_STRUCTURE
:
2950 t
= e
->ts
.is_iso_c
? true : false;
2954 t
= check_alloc_comp_init (e
);
2958 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2965 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2969 t
= gfc_expand_constructor (e
, true);
2973 t
= gfc_check_constructor_type (e
);
2977 gfc_internal_error ("check_init_expr(): Unknown expression type");
2983 /* Reduces a general expression to an initialization expression (a constant).
2984 This used to be part of gfc_match_init_expr.
2985 Note that this function doesn't free the given expression on false. */
2988 gfc_reduce_init_expr (gfc_expr
*expr
)
2992 gfc_init_expr_flag
= true;
2993 t
= gfc_resolve_expr (expr
);
2995 t
= gfc_check_init_expr (expr
);
2996 gfc_init_expr_flag
= false;
3001 if (expr
->expr_type
== EXPR_ARRAY
)
3003 if (!gfc_check_constructor_type (expr
))
3005 if (!gfc_expand_constructor (expr
, true))
3013 /* Match an initialization expression. We work by first matching an
3014 expression, then reducing it to a constant. */
3017 gfc_match_init_expr (gfc_expr
**result
)
3025 gfc_init_expr_flag
= true;
3027 m
= gfc_match_expr (&expr
);
3030 gfc_init_expr_flag
= false;
3034 if (gfc_derived_parameter_expr (expr
))
3037 gfc_init_expr_flag
= false;
3041 t
= gfc_reduce_init_expr (expr
);
3044 gfc_free_expr (expr
);
3045 gfc_init_expr_flag
= false;
3050 gfc_init_expr_flag
= false;
3056 /* Given an actual argument list, test to see that each argument is a
3057 restricted expression and optionally if the expression type is
3058 integer or character. */
3061 restricted_args (gfc_actual_arglist
*a
)
3063 for (; a
; a
= a
->next
)
3065 if (!check_restricted (a
->expr
))
3073 /************* Restricted/specification expressions *************/
3076 /* Make sure a non-intrinsic function is a specification function,
3077 * see F08:7.1.11.5. */
3080 external_spec_function (gfc_expr
*e
)
3084 f
= e
->value
.function
.esym
;
3086 /* IEEE functions allowed are "a reference to a transformational function
3087 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3088 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3089 IEEE_EXCEPTIONS". */
3090 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3091 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3093 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3094 || !strcmp (f
->name
, "ieee_support_rounding")
3095 || !strcmp (f
->name
, "ieee_support_flag")
3096 || !strcmp (f
->name
, "ieee_support_halting")
3097 || !strcmp (f
->name
, "ieee_support_datatype")
3098 || !strcmp (f
->name
, "ieee_support_denormal")
3099 || !strcmp (f
->name
, "ieee_support_subnormal")
3100 || !strcmp (f
->name
, "ieee_support_divide")
3101 || !strcmp (f
->name
, "ieee_support_inf")
3102 || !strcmp (f
->name
, "ieee_support_io")
3103 || !strcmp (f
->name
, "ieee_support_nan")
3104 || !strcmp (f
->name
, "ieee_support_sqrt")
3105 || !strcmp (f
->name
, "ieee_support_standard")
3106 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3107 goto function_allowed
;
3110 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3112 gfc_error ("Specification function %qs at %L cannot be a statement "
3113 "function", f
->name
, &e
->where
);
3117 if (f
->attr
.proc
== PROC_INTERNAL
)
3119 gfc_error ("Specification function %qs at %L cannot be an internal "
3120 "function", f
->name
, &e
->where
);
3124 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3126 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3132 if (f
->attr
.recursive
3133 && !gfc_notify_std (GFC_STD_F2003
,
3134 "Specification function %qs "
3135 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3139 return restricted_args (e
->value
.function
.actual
);
3143 /* Check to see that a function reference to an intrinsic is a
3144 restricted expression. */
3147 restricted_intrinsic (gfc_expr
*e
)
3149 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3150 if (check_inquiry (e
, 0) == MATCH_YES
)
3153 return restricted_args (e
->value
.function
.actual
);
3157 /* Check the expressions of an actual arglist. Used by check_restricted. */
3160 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3162 for (; arg
; arg
= arg
->next
)
3163 if (!checker (arg
->expr
))
3170 /* Check the subscription expressions of a reference chain with a checking
3171 function; used by check_restricted. */
3174 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3184 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
3186 if (!checker (ref
->u
.ar
.start
[dim
]))
3188 if (!checker (ref
->u
.ar
.end
[dim
]))
3190 if (!checker (ref
->u
.ar
.stride
[dim
]))
3196 /* Nothing needed, just proceed to next reference. */
3200 if (!checker (ref
->u
.ss
.start
))
3202 if (!checker (ref
->u
.ss
.end
))
3211 return check_references (ref
->next
, checker
);
3214 /* Return true if ns is a parent of the current ns. */
3217 is_parent_of_current_ns (gfc_namespace
*ns
)
3220 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3227 /* Verify that an expression is a restricted expression. Like its
3228 cousin check_init_expr(), an error message is generated if we
3232 check_restricted (gfc_expr
*e
)
3240 switch (e
->expr_type
)
3243 t
= check_intrinsic_op (e
, check_restricted
);
3245 t
= gfc_simplify_expr (e
, 0);
3250 if (e
->value
.function
.esym
)
3252 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3254 t
= external_spec_function (e
);
3258 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3261 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3264 t
= restricted_intrinsic (e
);
3269 sym
= e
->symtree
->n
.sym
;
3272 /* If a dummy argument appears in a context that is valid for a
3273 restricted expression in an elemental procedure, it will have
3274 already been simplified away once we get here. Therefore we
3275 don't need to jump through hoops to distinguish valid from
3277 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3278 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3280 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3281 sym
->name
, &e
->where
);
3285 if (sym
->attr
.optional
)
3287 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3288 sym
->name
, &e
->where
);
3292 if (sym
->attr
.intent
== INTENT_OUT
)
3294 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3295 sym
->name
, &e
->where
);
3299 /* Check reference chain if any. */
3300 if (!check_references (e
->ref
, &check_restricted
))
3303 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3304 processed in resolve.c(resolve_formal_arglist). This is done so
3305 that host associated dummy array indices are accepted (PR23446).
3306 This mechanism also does the same for the specification expressions
3307 of array-valued functions. */
3309 || sym
->attr
.in_common
3310 || sym
->attr
.use_assoc
3312 || sym
->attr
.implied_index
3313 || sym
->attr
.flavor
== FL_PARAMETER
3314 || is_parent_of_current_ns (sym
->ns
)
3315 || (sym
->ns
->proc_name
!= NULL
3316 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3317 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3323 gfc_error ("Variable %qs cannot appear in the expression at %L",
3324 sym
->name
, &e
->where
);
3325 /* Prevent a repetition of the error. */
3334 case EXPR_SUBSTRING
:
3335 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3339 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3341 t
= gfc_simplify_expr (e
, 0);
3345 case EXPR_STRUCTURE
:
3346 t
= gfc_check_constructor (e
, check_restricted
);
3350 t
= gfc_check_constructor (e
, check_restricted
);
3354 gfc_internal_error ("check_restricted(): Unknown expression type");
3361 /* Check to see that an expression is a specification expression. If
3362 we return false, an error has been generated. */
3365 gfc_specification_expr (gfc_expr
*e
)
3367 gfc_component
*comp
;
3372 if (e
->ts
.type
!= BT_INTEGER
)
3374 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3375 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3379 comp
= gfc_get_proc_ptr_comp (e
);
3380 if (e
->expr_type
== EXPR_FUNCTION
3381 && !e
->value
.function
.isym
3382 && !e
->value
.function
.esym
3383 && !gfc_pure (e
->symtree
->n
.sym
)
3384 && (!comp
|| !comp
->attr
.pure
))
3386 gfc_error ("Function %qs at %L must be PURE",
3387 e
->symtree
->n
.sym
->name
, &e
->where
);
3388 /* Prevent repeat error messages. */
3389 e
->symtree
->n
.sym
->attr
.pure
= 1;
3395 gfc_error ("Expression at %L must be scalar", &e
->where
);
3399 if (!gfc_simplify_expr (e
, 0))
3402 return check_restricted (e
);
3406 /************** Expression conformance checks. *************/
3408 /* Given two expressions, make sure that the arrays are conformable. */
3411 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3413 int op1_flag
, op2_flag
, d
;
3414 mpz_t op1_size
, op2_size
;
3420 if (op1
->rank
== 0 || op2
->rank
== 0)
3423 va_start (argp
, optype_msgid
);
3424 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3427 if (op1
->rank
!= op2
->rank
)
3429 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3430 op1
->rank
, op2
->rank
, &op1
->where
);
3436 for (d
= 0; d
< op1
->rank
; d
++)
3438 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3439 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3441 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3443 gfc_error ("Different shape for %s at %L on dimension %d "
3444 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3445 (int) mpz_get_si (op1_size
),
3446 (int) mpz_get_si (op2_size
));
3452 mpz_clear (op1_size
);
3454 mpz_clear (op2_size
);
3464 /* Given an assignable expression and an arbitrary expression, make
3465 sure that the assignment can take place. Only add a call to the intrinsic
3466 conversion routines, when allow_convert is set. When this assign is a
3467 coarray call, then the convert is done by the coarray routine implictly and
3468 adding the intrinsic conversion would do harm in most cases. */
3471 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3478 sym
= lvalue
->symtree
->n
.sym
;
3480 /* See if this is the component or subcomponent of a pointer and guard
3481 against assignment to LEN or KIND part-refs. */
3482 has_pointer
= sym
->attr
.pointer
;
3483 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3485 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3486 && ref
->u
.c
.component
->attr
.pointer
)
3488 else if (ref
->type
== REF_INQUIRY
3489 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3491 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3492 "allowed", &lvalue
->where
);
3497 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3498 variable local to a function subprogram. Its existence begins when
3499 execution of the function is initiated and ends when execution of the
3500 function is terminated...
3501 Therefore, the left hand side is no longer a variable, when it is: */
3502 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3503 && !sym
->attr
.external
)
3508 /* (i) Use associated; */
3509 if (sym
->attr
.use_assoc
)
3512 /* (ii) The assignment is in the main program; or */
3513 if (gfc_current_ns
->proc_name
3514 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3517 /* (iii) A module or internal procedure... */
3518 if (gfc_current_ns
->proc_name
3519 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3520 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3521 && gfc_current_ns
->parent
3522 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3523 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3524 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3526 /* ... that is not a function... */
3527 if (gfc_current_ns
->proc_name
3528 && !gfc_current_ns
->proc_name
->attr
.function
)
3531 /* ... or is not an entry and has a different name. */
3532 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3536 /* (iv) Host associated and not the function symbol or the
3537 parent result. This picks up sibling references, which
3538 cannot be entries. */
3539 if (!sym
->attr
.entry
3540 && sym
->ns
== gfc_current_ns
->parent
3541 && sym
!= gfc_current_ns
->proc_name
3542 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3547 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3553 /* Reject assigning to an external symbol. For initializers, this
3554 was already done before, in resolve_fl_procedure. */
3555 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
3556 && sym
->attr
.proc
!= PROC_MODULE
&& !rvalue
->error
)
3558 gfc_error ("Illegal assignment to external procedure at %L",
3564 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3566 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3567 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3571 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3573 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3578 if (rvalue
->expr_type
== EXPR_NULL
)
3580 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3581 && lvalue
->symtree
->n
.sym
->attr
.data
)
3585 gfc_error ("NULL appears on right-hand side in assignment at %L",
3591 /* This is possibly a typo: x = f() instead of x => f(). */
3593 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3594 gfc_warning (OPT_Wsurprising
,
3595 "POINTER-valued function appears on right-hand side of "
3596 "assignment at %L", &rvalue
->where
);
3598 /* Check size of array assignments. */
3599 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3600 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3603 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3604 && lvalue
->symtree
->n
.sym
->attr
.data
3605 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3606 "initialize non-integer variable %qs",
3607 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3609 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3610 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3611 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3615 /* Handle the case of a BOZ literal on the RHS. */
3616 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3619 if (warn_surprising
)
3620 gfc_warning (OPT_Wsurprising
,
3621 "BOZ literal at %L is bitwise transferred "
3622 "non-integer symbol %qs", &rvalue
->where
,
3623 lvalue
->symtree
->n
.sym
->name
);
3624 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3626 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3628 if (rc
== ARITH_UNDERFLOW
)
3629 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3630 ". This check can be disabled with the option "
3631 "%<-fno-range-check%>", &rvalue
->where
);
3632 else if (rc
== ARITH_OVERFLOW
)
3633 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3634 ". This check can be disabled with the option "
3635 "%<-fno-range-check%>", &rvalue
->where
);
3636 else if (rc
== ARITH_NAN
)
3637 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3638 ". This check can be disabled with the option "
3639 "%<-fno-range-check%>", &rvalue
->where
);
3644 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3646 gfc_error ("The assignment to a KIND or LEN component of a "
3647 "parameterized type at %L is not allowed",
3652 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3655 /* Only DATA Statements come here. */
3660 /* Numeric can be converted to any other numeric. And Hollerith can be
3661 converted to any other type. */
3662 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3663 || rvalue
->ts
.type
== BT_HOLLERITH
)
3666 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3669 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3670 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3671 "conversion of %s to %s", where
,
3672 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3677 /* Assignment is the only case where character variables of different
3678 kind values can be converted into one another. */
3679 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3681 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3682 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3690 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3694 /* Check that a pointer assignment is OK. We first check lvalue, and
3695 we only check rvalue if it's not an assignment to NULL() or a
3696 NULLIFY statement. */
3699 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
3700 bool suppress_type_test
, bool is_init_expr
)
3702 symbol_attribute attr
, lhs_attr
;
3704 bool is_pure
, is_implicit_pure
, rank_remap
;
3708 lhs_attr
= gfc_expr_attr (lvalue
);
3709 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3711 gfc_error ("Pointer assignment target is not a POINTER at %L",
3716 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3717 && !lhs_attr
.proc_pointer
)
3719 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3720 "l-value since it is a procedure",
3721 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3725 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3728 same_rank
= lvalue
->rank
== rvalue
->rank
;
3729 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3731 if (ref
->type
== REF_COMPONENT
)
3732 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3734 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3738 if (ref
->u
.ar
.type
== AR_FULL
)
3741 if (ref
->u
.ar
.type
!= AR_SECTION
)
3743 gfc_error ("Expected bounds specification for %qs at %L",
3744 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3748 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3749 "for %qs in pointer assignment at %L",
3750 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3753 /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
3755 * (C1017) If bounds-spec-list is specified, the number of
3756 * bounds-specs shall equal the rank of data-pointer-object.
3758 * If bounds-spec-list appears, it specifies the lower bounds.
3760 * (C1018) If bounds-remapping-list is specified, the number of
3761 * bounds-remappings shall equal the rank of data-pointer-object.
3763 * If bounds-remapping-list appears, it specifies the upper and
3764 * lower bounds of each dimension of the pointer; the pointer target
3765 * shall be simply contiguous or of rank one.
3767 * (C1019) If bounds-remapping-list is not specified, the ranks of
3768 * data-pointer-object and data-target shall be the same.
3770 * Thus when bounds are given, all lbounds are necessary and either
3771 * all or none of the upper bounds; no strides are allowed. If the
3772 * upper bounds are present, we may do rank remapping. */
3773 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3775 if (ref
->u
.ar
.stride
[dim
])
3777 gfc_error ("Stride must not be present at %L",
3781 if (!same_rank
&& (!ref
->u
.ar
.start
[dim
] ||!ref
->u
.ar
.end
[dim
]))
3783 gfc_error ("Rank remapping requires a "
3784 "list of %<lower-bound : upper-bound%> "
3785 "specifications at %L", &lvalue
->where
);
3788 if (!ref
->u
.ar
.start
[dim
]
3789 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3791 gfc_error ("Expected list of %<lower-bound :%> or "
3792 "list of %<lower-bound : upper-bound%> "
3793 "specifications at %L", &lvalue
->where
);
3798 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3801 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
]))
3803 gfc_error ("Rank remapping requires a "
3804 "list of %<lower-bound : upper-bound%> "
3805 "specifications at %L", &lvalue
->where
);
3808 if (!rank_remap
&& ref
->u
.ar
.end
[dim
])
3810 gfc_error ("Expected list of %<lower-bound :%> or "
3811 "list of %<lower-bound : upper-bound%> "
3812 "specifications at %L", &lvalue
->where
);
3820 is_pure
= gfc_pure (NULL
);
3821 is_implicit_pure
= gfc_implicit_pure (NULL
);
3823 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3824 kind, etc for lvalue and rvalue must match, and rvalue must be a
3825 pure variable if we're in a pure function. */
3826 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3829 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3830 if (lvalue
->expr_type
== EXPR_VARIABLE
3831 && gfc_is_coindexed (lvalue
))
3834 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3835 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3837 gfc_error ("Pointer object at %L shall not have a coindex",
3843 /* Checks on rvalue for procedure pointer assignments. */
3848 gfc_component
*comp1
, *comp2
;
3851 attr
= gfc_expr_attr (rvalue
);
3852 if (!((rvalue
->expr_type
== EXPR_NULL
)
3853 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3854 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3855 || (rvalue
->expr_type
== EXPR_VARIABLE
3856 && attr
.flavor
== FL_PROCEDURE
)))
3858 gfc_error ("Invalid procedure pointer assignment at %L",
3863 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3865 /* Check for intrinsics. */
3866 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3867 if (!sym
->attr
.intrinsic
3868 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3869 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3871 sym
->attr
.intrinsic
= 1;
3872 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3873 attr
= gfc_expr_attr (rvalue
);
3875 /* Check for result of embracing function. */
3876 if (sym
->attr
.function
&& sym
->result
== sym
)
3880 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3881 if (sym
== ns
->proc_name
)
3883 gfc_error ("Function result %qs is invalid as proc-target "
3884 "in procedure pointer assignment at %L",
3885 sym
->name
, &rvalue
->where
);
3892 gfc_error ("Abstract interface %qs is invalid "
3893 "in procedure pointer assignment at %L",
3894 rvalue
->symtree
->name
, &rvalue
->where
);
3897 /* Check for F08:C729. */
3898 if (attr
.flavor
== FL_PROCEDURE
)
3900 if (attr
.proc
== PROC_ST_FUNCTION
)
3902 gfc_error ("Statement function %qs is invalid "
3903 "in procedure pointer assignment at %L",
3904 rvalue
->symtree
->name
, &rvalue
->where
);
3907 if (attr
.proc
== PROC_INTERNAL
&&
3908 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3909 "is invalid in procedure pointer assignment "
3910 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3912 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3913 attr
.subroutine
) == 0)
3915 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3916 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3920 /* Check for F08:C730. */
3921 if (attr
.elemental
&& !attr
.intrinsic
)
3923 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3924 "in procedure pointer assignment at %L",
3925 rvalue
->symtree
->name
, &rvalue
->where
);
3929 /* Ensure that the calling convention is the same. As other attributes
3930 such as DLLEXPORT may differ, one explicitly only tests for the
3931 calling conventions. */
3932 if (rvalue
->expr_type
== EXPR_VARIABLE
3933 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3934 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3936 symbol_attribute calls
;
3939 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3940 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3941 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3943 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3944 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3946 gfc_error ("Mismatch in the procedure pointer assignment "
3947 "at %L: mismatch in the calling convention",
3953 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3955 s1
= comp1
->ts
.interface
;
3958 s1
= lvalue
->symtree
->n
.sym
;
3959 if (s1
->ts
.interface
)
3960 s1
= s1
->ts
.interface
;
3963 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3966 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3968 s2
= comp2
->ts
.interface
->result
;
3973 s2
= comp2
->ts
.interface
;
3977 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3979 if (rvalue
->value
.function
.esym
)
3980 s2
= rvalue
->value
.function
.esym
->result
;
3982 s2
= rvalue
->symtree
->n
.sym
->result
;
3988 s2
= rvalue
->symtree
->n
.sym
;
3992 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3993 s2
= s2
->ts
.interface
;
3995 /* Special check for the case of absent interface on the lvalue.
3996 * All other interface checks are done below. */
3997 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3999 gfc_error ("Interface mismatch in procedure pointer assignment "
4000 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
4004 /* F08:7.2.2.4 (4) */
4005 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
4009 gfc_error ("Explicit interface required for component %qs at %L: %s",
4010 comp1
->name
, &lvalue
->where
, err
);
4013 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
4015 gfc_error ("Explicit interface required for %qs at %L: %s",
4016 s1
->name
, &lvalue
->where
, err
);
4020 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
4024 gfc_error ("Explicit interface required for component %qs at %L: %s",
4025 comp2
->name
, &rvalue
->where
, err
);
4028 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
4030 gfc_error ("Explicit interface required for %qs at %L: %s",
4031 s2
->name
, &rvalue
->where
, err
);
4036 if (s1
== s2
|| !s1
|| !s2
)
4039 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
4040 err
, sizeof(err
), NULL
, NULL
))
4042 gfc_error ("Interface mismatch in procedure pointer assignment "
4043 "at %L: %s", &rvalue
->where
, err
);
4047 /* Check F2008Cor2, C729. */
4048 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4049 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4051 gfc_error ("Procedure pointer target %qs at %L must be either an "
4052 "intrinsic, host or use associated, referenced or have "
4053 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4061 /* A non-proc pointer cannot point to a constant. */
4062 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4064 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4070 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4072 /* Check for F03:C717. */
4073 if (UNLIMITED_POLY (rvalue
)
4074 && !(UNLIMITED_POLY (lvalue
)
4075 || (lvalue
->ts
.type
== BT_DERIVED
4076 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4077 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4078 gfc_error ("Data-pointer-object at %L must be unlimited "
4079 "polymorphic, or of a type with the BIND or SEQUENCE "
4080 "attribute, to be compatible with an unlimited "
4081 "polymorphic target", &lvalue
->where
);
4082 else if (!suppress_type_test
)
4083 gfc_error ("Different types in pointer assignment at %L; "
4084 "attempted assignment of %s to %s", &lvalue
->where
,
4085 gfc_typename (&rvalue
->ts
),
4086 gfc_typename (&lvalue
->ts
));
4090 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4092 gfc_error ("Different kind type parameters in pointer "
4093 "assignment at %L", &lvalue
->where
);
4097 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4099 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4103 /* Make sure the vtab is present. */
4104 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4105 gfc_find_vtab (&rvalue
->ts
);
4107 /* Check rank remapping. */
4112 /* If this can be determined, check that the target must be at least as
4113 large as the pointer assigned to it is. */
4114 if (gfc_array_size (lvalue
, &lsize
)
4115 && gfc_array_size (rvalue
, &rsize
)
4116 && mpz_cmp (rsize
, lsize
) < 0)
4118 gfc_error ("Rank remapping target is smaller than size of the"
4119 " pointer (%ld < %ld) at %L",
4120 mpz_get_si (rsize
), mpz_get_si (lsize
),
4125 /* The target must be either rank one or it must be simply contiguous
4126 and F2008 must be allowed. */
4127 if (rvalue
->rank
!= 1)
4129 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4131 gfc_error ("Rank remapping target must be rank 1 or"
4132 " simply contiguous at %L", &rvalue
->where
);
4135 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4136 "rank 1 at %L", &rvalue
->where
))
4141 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4142 if (rvalue
->expr_type
== EXPR_NULL
)
4145 if (lvalue
->ts
.type
== BT_CHARACTER
)
4147 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4152 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4153 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4155 attr
= gfc_expr_attr (rvalue
);
4157 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4159 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4160 to caf_get. Map this to the same error message as below when it is
4161 still a variable expression. */
4162 if (rvalue
->value
.function
.isym
4163 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4164 /* The test above might need to be extend when F08, Note 5.4 has to be
4165 interpreted in the way that target and pointer with the same coindex
4167 gfc_error ("Data target at %L shall not have a coindex",
4170 gfc_error ("Target expression in pointer assignment "
4171 "at %L must deliver a pointer result",
4181 gcc_assert (rvalue
->symtree
);
4182 sym
= rvalue
->symtree
->n
.sym
;
4184 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4185 target
= CLASS_DATA (sym
)->attr
.target
;
4187 target
= sym
->attr
.target
;
4189 if (!target
&& !proc_pointer
)
4191 gfc_error ("Pointer assignment target in initialization expression "
4192 "does not have the TARGET attribute at %L",
4199 if (!attr
.target
&& !attr
.pointer
)
4201 gfc_error ("Pointer assignment target is neither TARGET "
4202 "nor POINTER at %L", &rvalue
->where
);
4207 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4209 gfc_error ("Bad target in pointer assignment in PURE "
4210 "procedure at %L", &rvalue
->where
);
4213 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4214 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4216 if (gfc_has_vector_index (rvalue
))
4218 gfc_error ("Pointer assignment with vector subscript "
4219 "on rhs at %L", &rvalue
->where
);
4223 if (attr
.is_protected
&& attr
.use_assoc
4224 && !(attr
.pointer
|| attr
.proc_pointer
))
4226 gfc_error ("Pointer assignment target has PROTECTED "
4227 "attribute at %L", &rvalue
->where
);
4231 /* F2008, C725. For PURE also C1283. */
4232 if (rvalue
->expr_type
== EXPR_VARIABLE
4233 && gfc_is_coindexed (rvalue
))
4236 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4237 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4239 gfc_error ("Data target at %L shall not have a coindex",
4245 /* Warn for assignments of contiguous pointers to targets which is not
4246 contiguous. Be lenient in the definition of what counts as
4249 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
4250 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4251 "non-contiguous target at %L", &rvalue
->where
);
4253 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4254 if (warn_target_lifetime
4255 && rvalue
->expr_type
== EXPR_VARIABLE
4256 && !rvalue
->symtree
->n
.sym
->attr
.save
4257 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4258 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4259 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4260 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4261 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4266 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4267 || lvalue
->symtree
->n
.sym
->attr
.result
4268 || lvalue
->symtree
->n
.sym
->attr
.function
4269 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4270 && lvalue
->symtree
->n
.sym
->ns
4271 != rvalue
->symtree
->n
.sym
->ns
)
4272 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4273 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4275 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4276 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4277 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4278 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4279 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4281 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4288 gfc_warning (OPT_Wtarget_lifetime
,
4289 "Pointer at %L in pointer assignment might outlive the "
4290 "pointer target", &lvalue
->where
);
4297 /* Relative of gfc_check_assign() except that the lvalue is a single
4298 symbol. Used for initialization assignments. */
4301 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4305 bool pointer
, proc_pointer
;
4307 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4309 lvalue
.expr_type
= EXPR_VARIABLE
;
4310 lvalue
.ts
= sym
->ts
;
4312 lvalue
.rank
= sym
->as
->rank
;
4313 lvalue
.symtree
= XCNEW (gfc_symtree
);
4314 lvalue
.symtree
->n
.sym
= sym
;
4315 lvalue
.where
= sym
->declared_at
;
4319 lvalue
.ref
= gfc_get_ref ();
4320 lvalue
.ref
->type
= REF_COMPONENT
;
4321 lvalue
.ref
->u
.c
.component
= comp
;
4322 lvalue
.ref
->u
.c
.sym
= sym
;
4323 lvalue
.ts
= comp
->ts
;
4324 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4325 lvalue
.where
= comp
->loc
;
4326 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4327 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4328 proc_pointer
= comp
->attr
.proc_pointer
;
4332 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4333 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4334 proc_pointer
= sym
->attr
.proc_pointer
;
4337 if (pointer
|| proc_pointer
)
4338 r
= gfc_check_pointer_assign (&lvalue
, rvalue
, false, true);
4341 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4342 into an array constructor, we should check if it can be reduced
4343 as an initialization expression. */
4344 if (rvalue
->expr_type
== EXPR_FUNCTION
4345 && rvalue
->value
.function
.isym
4346 && (rvalue
->value
.function
.isym
->conversion
== 1))
4347 gfc_check_init_expr (rvalue
);
4349 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4352 free (lvalue
.symtree
);
4358 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
&& !proc_pointer
)
4360 /* F08:C461. Additional checks for pointer initialization. */
4361 symbol_attribute attr
;
4362 attr
= gfc_expr_attr (rvalue
);
4363 if (attr
.allocatable
)
4365 gfc_error ("Pointer initialization target at %L "
4366 "must not be ALLOCATABLE", &rvalue
->where
);
4369 if (!attr
.target
|| attr
.pointer
)
4371 gfc_error ("Pointer initialization target at %L "
4372 "must have the TARGET attribute", &rvalue
->where
);
4376 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4377 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4378 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4380 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4381 attr
.save
= SAVE_IMPLICIT
;
4386 gfc_error ("Pointer initialization target at %L "
4387 "must have the SAVE attribute", &rvalue
->where
);
4392 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4394 /* F08:C1220. Additional checks for procedure pointer initialization. */
4395 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4396 if (attr
.proc_pointer
)
4398 gfc_error ("Procedure pointer initialization target at %L "
4399 "may not be a procedure pointer", &rvalue
->where
);
4407 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4408 * require that an expression be built. */
4411 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4413 return gfc_build_init_expr (ts
, where
, false);
4416 /* Build an initializer for a local integer, real, complex, logical, or
4417 character variable, based on the command line flags finit-local-zero,
4418 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4419 With force, an initializer is ALWAYS generated. */
4422 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4424 gfc_expr
*init_expr
;
4426 /* Try to build an initializer expression. */
4427 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4429 /* If we want to force generation, make sure we default to zero. */
4430 gfc_init_local_real init_real
= flag_init_real
;
4431 int init_logical
= gfc_option
.flag_init_logical
;
4434 if (init_real
== GFC_INIT_REAL_OFF
)
4435 init_real
= GFC_INIT_REAL_ZERO
;
4436 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4437 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4440 /* We will only initialize integers, reals, complex, logicals, and
4441 characters, and only if the corresponding command-line flags
4442 were set. Otherwise, we free init_expr and return null. */
4446 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4447 mpz_set_si (init_expr
->value
.integer
,
4448 gfc_option
.flag_init_integer_value
);
4451 gfc_free_expr (init_expr
);
4459 case GFC_INIT_REAL_SNAN
:
4460 init_expr
->is_snan
= 1;
4462 case GFC_INIT_REAL_NAN
:
4463 mpfr_set_nan (init_expr
->value
.real
);
4466 case GFC_INIT_REAL_INF
:
4467 mpfr_set_inf (init_expr
->value
.real
, 1);
4470 case GFC_INIT_REAL_NEG_INF
:
4471 mpfr_set_inf (init_expr
->value
.real
, -1);
4474 case GFC_INIT_REAL_ZERO
:
4475 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4479 gfc_free_expr (init_expr
);
4488 case GFC_INIT_REAL_SNAN
:
4489 init_expr
->is_snan
= 1;
4491 case GFC_INIT_REAL_NAN
:
4492 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4493 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4496 case GFC_INIT_REAL_INF
:
4497 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4498 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4501 case GFC_INIT_REAL_NEG_INF
:
4502 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4503 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4506 case GFC_INIT_REAL_ZERO
:
4507 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4511 gfc_free_expr (init_expr
);
4518 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4519 init_expr
->value
.logical
= 0;
4520 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4521 init_expr
->value
.logical
= 1;
4524 gfc_free_expr (init_expr
);
4530 /* For characters, the length must be constant in order to
4531 create a default initializer. */
4532 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4534 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4536 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4537 init_expr
->value
.character
.length
= char_len
;
4538 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4539 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4540 init_expr
->value
.character
.string
[i
]
4541 = (unsigned char) gfc_option
.flag_init_character_value
;
4545 gfc_free_expr (init_expr
);
4549 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4550 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4552 gfc_actual_arglist
*arg
;
4553 init_expr
= gfc_get_expr ();
4554 init_expr
->where
= *where
;
4555 init_expr
->ts
= *ts
;
4556 init_expr
->expr_type
= EXPR_FUNCTION
;
4557 init_expr
->value
.function
.isym
=
4558 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4559 init_expr
->value
.function
.name
= "repeat";
4560 arg
= gfc_get_actual_arglist ();
4561 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4562 arg
->expr
->value
.character
.string
[0] =
4563 gfc_option
.flag_init_character_value
;
4564 arg
->next
= gfc_get_actual_arglist ();
4565 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4566 init_expr
->value
.function
.actual
= arg
;
4571 gfc_free_expr (init_expr
);
4578 /* Apply an initialization expression to a typespec. Can be used for symbols or
4579 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4580 combined with some effort. */
4583 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4585 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4588 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4589 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4591 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4593 if (init
->expr_type
== EXPR_CONSTANT
)
4594 gfc_set_constant_character_len (len
, init
, -1);
4596 && init
->ts
.type
== BT_CHARACTER
4597 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4598 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4599 init
->ts
.u
.cl
->length
->value
.integer
))
4601 gfc_constructor
*ctor
;
4602 ctor
= gfc_constructor_first (init
->value
.constructor
);
4606 bool has_ts
= (init
->ts
.u
.cl
4607 && init
->ts
.u
.cl
->length_from_typespec
);
4609 /* Remember the length of the first element for checking
4610 that all elements *in the constructor* have the same
4611 length. This need not be the length of the LHS! */
4612 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4613 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4614 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4616 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4617 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4619 gfc_set_constant_character_len (len
, ctor
->expr
,
4620 has_ts
? -1 : first_len
);
4621 if (!ctor
->expr
->ts
.u
.cl
)
4623 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4625 ctor
->expr
->ts
.u
.cl
->length
4626 = gfc_copy_expr (ts
->u
.cl
->length
);
4634 /* Check whether an expression is a structure constructor and whether it has
4635 other values than NULL. */
4638 is_non_empty_structure_constructor (gfc_expr
* e
)
4640 if (e
->expr_type
!= EXPR_STRUCTURE
)
4643 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4646 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4648 cons
= gfc_constructor_next (cons
);
4654 /* Check for default initializer; sym->value is not enough
4655 as it is also set for EXPR_NULL of allocatables. */
4658 gfc_has_default_initializer (gfc_symbol
*der
)
4662 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4663 for (c
= der
->components
; c
; c
= c
->next
)
4664 if (gfc_bt_struct (c
->ts
.type
))
4666 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4667 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4669 && is_non_empty_structure_constructor (c
->initializer
))
4670 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4672 if (c
->attr
.pointer
&& c
->initializer
)
4686 Generate an initializer expression which initializes the entirety of a union.
4687 A normal structure constructor is insufficient without undue effort, because
4688 components of maps may be oddly aligned/overlapped. (For example if a
4689 character is initialized from one map overtop a real from the other, only one
4690 byte of the real is actually initialized.) Unfortunately we don't know the
4691 size of the union right now, so we can't generate a proper initializer, but
4692 we use a NULL expr as a placeholder and do the right thing later in
4693 gfc_trans_subcomponent_assign.
4696 generate_union_initializer (gfc_component
*un
)
4698 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4701 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4702 placeholder
->ts
= un
->ts
;
4707 /* Get the user-specified initializer for a union, if any. This means the user
4708 has said to initialize component(s) of a map. For simplicity's sake we
4709 only allow the user to initialize the first map. We don't have to worry
4710 about overlapping initializers as they are released early in resolution (see
4711 resolve_fl_struct). */
4714 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4717 gfc_expr
*init
=NULL
;
4719 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4722 for (map
= union_type
->components
; map
; map
= map
->next
)
4724 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4726 init
= gfc_default_initializer (&map
->ts
);
4740 class_allocatable (gfc_component
*comp
)
4742 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4743 && CLASS_DATA (comp
)->attr
.allocatable
;
4747 class_pointer (gfc_component
*comp
)
4749 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4750 && CLASS_DATA (comp
)->attr
.pointer
;
4754 comp_allocatable (gfc_component
*comp
)
4756 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4760 comp_pointer (gfc_component
*comp
)
4762 return comp
->attr
.pointer
4763 || comp
->attr
.pointer
4764 || comp
->attr
.proc_pointer
4765 || comp
->attr
.class_pointer
4766 || class_pointer (comp
);
4769 /* Fetch or generate an initializer for the given component.
4770 Only generate an initializer if generate is true. */
4773 component_initializer (gfc_component
*c
, bool generate
)
4775 gfc_expr
*init
= NULL
;
4777 /* Allocatable components always get EXPR_NULL.
4778 Pointer components are only initialized when generating, and only if they
4779 do not already have an initializer. */
4780 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4782 init
= gfc_get_null_expr (&c
->loc
);
4787 /* See if we can find the initializer immediately. */
4788 if (c
->initializer
|| !generate
)
4789 return c
->initializer
;
4791 /* Recursively handle derived type components. */
4792 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4793 init
= gfc_generate_initializer (&c
->ts
, true);
4795 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4797 gfc_component
*map
= NULL
;
4798 gfc_constructor
*ctor
;
4799 gfc_expr
*user_init
;
4801 /* If we don't have a user initializer and we aren't generating one, this
4802 union has no initializer. */
4803 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4804 if (!user_init
&& !generate
)
4807 /* Otherwise use a structure constructor. */
4808 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4812 /* If we are to generate an initializer for the union, add a constructor
4813 which initializes the whole union first. */
4816 ctor
= gfc_constructor_get ();
4817 ctor
->expr
= generate_union_initializer (c
);
4818 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4821 /* If we found an initializer in one of our maps, apply it. Note this
4822 is applied _after_ the entire-union initializer above if any. */
4825 ctor
= gfc_constructor_get ();
4826 ctor
->expr
= user_init
;
4827 ctor
->n
.component
= map
;
4828 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4832 /* Treat simple components like locals. */
4835 /* We MUST give an initializer, so force generation. */
4836 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4837 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4844 /* Get an expression for a default initializer of a derived type. */
4847 gfc_default_initializer (gfc_typespec
*ts
)
4849 return gfc_generate_initializer (ts
, false);
4852 /* Generate an initializer expression for an iso_c_binding type
4853 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
4856 generate_isocbinding_initializer (gfc_symbol
*derived
)
4858 /* The initializers have already been built into the c_null_[fun]ptr symbols
4859 from gen_special_c_interop_ptr. */
4860 gfc_symtree
*npsym
= NULL
;
4861 if (0 == strcmp (derived
->name
, "c_ptr"))
4862 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
4863 else if (0 == strcmp (derived
->name
, "c_funptr"))
4864 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
4866 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
4867 " type, expected %<c_ptr%> or %<c_funptr%>");
4870 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
4871 init
->symtree
= npsym
;
4872 init
->ts
.is_iso_c
= true;
4879 /* Get or generate an expression for a default initializer of a derived type.
4880 If -finit-derived is specified, generate default initialization expressions
4881 for components that lack them when generate is set. */
4884 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4886 gfc_expr
*init
, *tmp
;
4887 gfc_component
*comp
;
4889 generate
= flag_init_derived
&& generate
;
4891 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
4892 return generate_isocbinding_initializer (ts
->u
.derived
);
4894 /* See if we have a default initializer in this, but not in nested
4895 types (otherwise we could use gfc_has_default_initializer()).
4896 We don't need to check if we are going to generate them. */
4897 comp
= ts
->u
.derived
->components
;
4900 for (; comp
; comp
= comp
->next
)
4901 if (comp
->initializer
|| comp_allocatable (comp
))
4908 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4909 &ts
->u
.derived
->declared_at
);
4912 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4914 gfc_constructor
*ctor
= gfc_constructor_get();
4916 /* Fetch or generate an initializer for the component. */
4917 tmp
= component_initializer (comp
, generate
);
4920 /* Save the component ref for STRUCTUREs and UNIONs. */
4921 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4922 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4923 ctor
->n
.component
= comp
;
4925 /* If the initializer was not generated, we need a copy. */
4926 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4927 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
4928 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4931 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
4937 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4944 /* Given a symbol, create an expression node with that symbol as a
4945 variable. If the symbol is array valued, setup a reference of the
4949 gfc_get_variable_expr (gfc_symtree
*var
)
4953 e
= gfc_get_expr ();
4954 e
->expr_type
= EXPR_VARIABLE
;
4956 e
->ts
= var
->n
.sym
->ts
;
4958 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4959 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4960 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4961 && CLASS_DATA (var
->n
.sym
)->as
)))
4963 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4964 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4965 e
->ref
= gfc_get_ref ();
4966 e
->ref
->type
= REF_ARRAY
;
4967 e
->ref
->u
.ar
.type
= AR_FULL
;
4968 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4969 ? CLASS_DATA (var
->n
.sym
)->as
4977 /* Adds a full array reference to an expression, as needed. */
4980 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4983 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4988 ref
->next
= gfc_get_ref ();
4993 e
->ref
= gfc_get_ref ();
4996 ref
->type
= REF_ARRAY
;
4997 ref
->u
.ar
.type
= AR_FULL
;
4998 ref
->u
.ar
.dimen
= e
->rank
;
4999 ref
->u
.ar
.where
= e
->where
;
5005 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
5009 lval
= gfc_get_expr ();
5010 lval
->expr_type
= EXPR_VARIABLE
;
5011 lval
->where
= sym
->declared_at
;
5013 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
5015 /* It will always be a full array. */
5016 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
5017 lval
->rank
= as
? as
->rank
: 0;
5019 gfc_add_full_array_ref (lval
, as
);
5024 /* Returns the array_spec of a full array expression. A NULL is
5025 returned otherwise. */
5027 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
5032 if (expr
->rank
== 0)
5035 /* Follow any component references. */
5036 if (expr
->expr_type
== EXPR_VARIABLE
5037 || expr
->expr_type
== EXPR_CONSTANT
)
5040 as
= expr
->symtree
->n
.sym
->as
;
5044 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5049 as
= ref
->u
.c
.component
->as
;
5058 switch (ref
->u
.ar
.type
)
5081 /* General expression traversal function. */
5084 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5085 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5090 gfc_actual_arglist
*args
;
5097 if ((*func
) (expr
, sym
, &f
))
5100 if (expr
->ts
.type
== BT_CHARACTER
5102 && expr
->ts
.u
.cl
->length
5103 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5104 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5107 switch (expr
->expr_type
)
5112 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5114 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5122 case EXPR_SUBSTRING
:
5125 case EXPR_STRUCTURE
:
5127 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5128 c
; c
= gfc_constructor_next (c
))
5130 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5134 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5136 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5138 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5140 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5147 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5149 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5165 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5167 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5169 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5171 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5177 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5179 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5184 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5185 && ref
->u
.c
.component
->ts
.u
.cl
5186 && ref
->u
.c
.component
->ts
.u
.cl
->length
5187 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5189 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5193 if (ref
->u
.c
.component
->as
)
5194 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5195 + ref
->u
.c
.component
->as
->corank
; i
++)
5197 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5200 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5217 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5220 expr_set_symbols_referenced (gfc_expr
*expr
,
5221 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5222 int *f ATTRIBUTE_UNUSED
)
5224 if (expr
->expr_type
!= EXPR_VARIABLE
)
5226 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5231 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5233 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5237 /* Determine if an expression is a procedure pointer component and return
5238 the component in that case. Otherwise return NULL. */
5241 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5245 if (!expr
|| !expr
->ref
)
5252 if (ref
->type
== REF_COMPONENT
5253 && ref
->u
.c
.component
->attr
.proc_pointer
)
5254 return ref
->u
.c
.component
;
5260 /* Determine if an expression is a procedure pointer component. */
5263 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5265 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5269 /* Determine if an expression is a function with an allocatable class scalar
5272 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5274 if (expr
->expr_type
== EXPR_FUNCTION
5275 && expr
->value
.function
.esym
5276 && expr
->value
.function
.esym
->result
5277 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5278 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5279 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5286 /* Determine if an expression is a function with an allocatable class array
5289 gfc_is_class_array_function (gfc_expr
*expr
)
5291 if (expr
->expr_type
== EXPR_FUNCTION
5292 && expr
->value
.function
.esym
5293 && expr
->value
.function
.esym
->result
5294 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5295 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5296 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5297 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5304 /* Walk an expression tree and check each variable encountered for being typed.
5305 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5306 mode as is a basic arithmetic expression using those; this is for things in
5309 INTEGER :: arr(n), n
5310 INTEGER :: arr(n + 1), n
5312 The namespace is needed for IMPLICIT typing. */
5314 static gfc_namespace
* check_typed_ns
;
5317 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5318 int* f ATTRIBUTE_UNUSED
)
5322 if (e
->expr_type
!= EXPR_VARIABLE
)
5325 gcc_assert (e
->symtree
);
5326 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5333 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5337 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5341 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5342 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5344 if (e
->expr_type
== EXPR_OP
)
5348 gcc_assert (e
->value
.op
.op1
);
5349 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5351 if (t
&& e
->value
.op
.op2
)
5352 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5358 /* Otherwise, walk the expression and do it strictly. */
5359 check_typed_ns
= ns
;
5360 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5362 return error_found
? false : true;
5366 /* This function returns true if it contains any references to PDT KIND
5367 or LEN parameters. */
5370 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5371 int* f ATTRIBUTE_UNUSED
)
5373 if (e
->expr_type
!= EXPR_VARIABLE
)
5376 gcc_assert (e
->symtree
);
5377 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5378 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5386 gfc_derived_parameter_expr (gfc_expr
*e
)
5388 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5392 /* This function returns the overall type of a type parameter spec list.
5393 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5394 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5395 unless derived is not NULL. In this latter case, all the LEN parameters
5396 must be either assumed or deferred for the return argument to be set to
5397 anything other than SPEC_EXPLICIT. */
5400 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5402 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5404 bool seen_assumed
= false;
5405 bool seen_deferred
= false;
5407 if (derived
== NULL
)
5409 for (; param_list
; param_list
= param_list
->next
)
5410 if (param_list
->spec_type
== SPEC_ASSUMED
5411 || param_list
->spec_type
== SPEC_DEFERRED
)
5412 return param_list
->spec_type
;
5416 for (; param_list
; param_list
= param_list
->next
)
5418 c
= gfc_find_component (derived
, param_list
->name
,
5420 gcc_assert (c
!= NULL
);
5421 if (c
->attr
.pdt_kind
)
5423 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5424 return SPEC_EXPLICIT
;
5425 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5426 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5427 if (seen_assumed
&& seen_deferred
)
5428 return SPEC_EXPLICIT
;
5430 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5437 gfc_ref_this_image (gfc_ref
*ref
)
5441 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5443 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5444 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5451 gfc_find_team_co (gfc_expr
*e
)
5455 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5456 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5457 return ref
->u
.ar
.team
;
5459 if (e
->value
.function
.actual
->expr
)
5460 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5462 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5463 return ref
->u
.ar
.team
;
5469 gfc_find_stat_co (gfc_expr
*e
)
5473 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5474 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5475 return ref
->u
.ar
.stat
;
5477 if (e
->value
.function
.actual
->expr
)
5478 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5480 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5481 return ref
->u
.ar
.stat
;
5487 gfc_is_coindexed (gfc_expr
*e
)
5491 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5492 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5493 return !gfc_ref_this_image (ref
);
5499 /* Coarrays are variables with a corank but not being coindexed. However, also
5500 the following is a coarray: A subobject of a coarray is a coarray if it does
5501 not have any cosubscripts, vector subscripts, allocatable component
5502 selection, or pointer component selection. (F2008, 2.4.7) */
5505 gfc_is_coarray (gfc_expr
*e
)
5509 gfc_component
*comp
;
5514 if (e
->expr_type
!= EXPR_VARIABLE
)
5518 sym
= e
->symtree
->n
.sym
;
5520 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5521 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5523 coarray
= sym
->attr
.codimension
;
5525 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5529 comp
= ref
->u
.c
.component
;
5530 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5531 && (CLASS_DATA (comp
)->attr
.class_pointer
5532 || CLASS_DATA (comp
)->attr
.allocatable
))
5535 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5537 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5540 coarray
= comp
->attr
.codimension
;
5548 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5554 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5555 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5567 return coarray
&& !coindexed
;
5572 gfc_get_corank (gfc_expr
*e
)
5577 if (!gfc_is_coarray (e
))
5580 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5581 corank
= e
->ts
.u
.derived
->components
->as
5582 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5584 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5586 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5588 if (ref
->type
== REF_ARRAY
)
5589 corank
= ref
->u
.ar
.as
->corank
;
5590 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5597 /* Check whether the expression has an ultimate allocatable component.
5598 Being itself allocatable does not count. */
5600 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5602 gfc_ref
*ref
, *last
= NULL
;
5604 if (e
->expr_type
!= EXPR_VARIABLE
)
5607 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5608 if (ref
->type
== REF_COMPONENT
)
5611 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5612 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5613 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5614 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5618 if (e
->ts
.type
== BT_CLASS
)
5619 return CLASS_DATA (e
)->attr
.alloc_comp
;
5620 else if (e
->ts
.type
== BT_DERIVED
)
5621 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5627 /* Check whether the expression has an pointer component.
5628 Being itself a pointer does not count. */
5630 gfc_has_ultimate_pointer (gfc_expr
*e
)
5632 gfc_ref
*ref
, *last
= NULL
;
5634 if (e
->expr_type
!= EXPR_VARIABLE
)
5637 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5638 if (ref
->type
== REF_COMPONENT
)
5641 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5642 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5643 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5644 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5648 if (e
->ts
.type
== BT_CLASS
)
5649 return CLASS_DATA (e
)->attr
.pointer_comp
;
5650 else if (e
->ts
.type
== BT_DERIVED
)
5651 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5657 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5658 Note: A scalar is not regarded as "simply contiguous" by the standard.
5659 if bool is not strict, some further checks are done - for instance,
5660 a "(::1)" is accepted. */
5663 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5667 gfc_array_ref
*ar
= NULL
;
5668 gfc_ref
*ref
, *part_ref
= NULL
;
5671 if (expr
->expr_type
== EXPR_FUNCTION
)
5673 if (expr
->value
.function
.esym
)
5674 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5677 /* Type-bound procedures. */
5678 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5679 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5683 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5684 if (r
->type
== REF_COMPONENT
)
5687 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5688 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5691 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5694 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5697 if (!permit_element
&& expr
->rank
== 0)
5700 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5703 return false; /* Array shall be last part-ref. */
5705 if (ref
->type
== REF_COMPONENT
)
5707 else if (ref
->type
== REF_SUBSTRING
)
5709 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5713 sym
= expr
->symtree
->n
.sym
;
5714 if (expr
->ts
.type
!= BT_CLASS
5716 && !part_ref
->u
.c
.component
->attr
.contiguous
5717 && part_ref
->u
.c
.component
->attr
.pointer
)
5719 && !sym
->attr
.contiguous
5720 && (sym
->attr
.pointer
5721 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5722 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5725 if (!ar
|| ar
->type
== AR_FULL
)
5728 gcc_assert (ar
->type
== AR_SECTION
);
5730 /* Check for simply contiguous array */
5732 for (i
= 0; i
< ar
->dimen
; i
++)
5734 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5737 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5743 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5746 /* If the previous section was not contiguous, that's an error,
5747 unless we have effective only one element and checking is not
5749 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5750 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5751 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5752 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5753 ar
->end
[i
]->value
.integer
) != 0))
5756 /* Following the standard, "(::1)" or - if known at compile time -
5757 "(lbound:ubound)" are not simply contiguous; if strict
5758 is false, they are regarded as simply contiguous. */
5759 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5760 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5761 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5765 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5766 || !ar
->as
->lower
[i
]
5767 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5768 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5769 ar
->as
->lower
[i
]->value
.integer
) != 0))
5773 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5774 || !ar
->as
->upper
[i
]
5775 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5776 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5777 ar
->as
->upper
[i
]->value
.integer
) != 0))
5784 /* Return true if the expression is guaranteed to be non-contiguous,
5785 false if we cannot prove anything. It is probably best to call
5786 this after gfc_is_simply_contiguous. If neither of them returns
5787 true, we cannot say (at compile-time). */
5790 gfc_is_not_contiguous (gfc_expr
*array
)
5793 gfc_array_ref
*ar
= NULL
;
5795 bool previous_incomplete
;
5797 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
5799 /* Array-ref shall be last ref. */
5804 if (ref
->type
== REF_ARRAY
)
5808 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
5811 previous_incomplete
= false;
5813 /* Check if we can prove that the array is not contiguous. */
5815 for (i
= 0; i
< ar
->dimen
; i
++)
5817 mpz_t arr_size
, ref_size
;
5819 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
5821 if (gfc_dep_difference (ar
->as
->lower
[i
], ar
->as
->upper
[i
], &arr_size
))
5823 /* a(2:4,2:) is known to be non-contiguous, but
5824 a(2:4,i:i) can be contiguous. */
5825 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
5827 mpz_clear (arr_size
);
5828 mpz_clear (ref_size
);
5831 else if (mpz_cmp (arr_size
, ref_size
) != 0)
5832 previous_incomplete
= true;
5834 mpz_clear (arr_size
);
5837 /* Check for a(::2), i.e. where the stride is not unity.
5838 This is only done if there is more than one element in
5839 the reference along this dimension. */
5841 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
5842 && ar
->dimen_type
[i
] == DIMEN_RANGE
5843 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5844 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
5847 mpz_clear (ref_size
);
5850 /* We didn't find anything definitive. */
5854 /* Build call to an intrinsic procedure. The number of arguments has to be
5855 passed (rather than ending the list with a NULL value) because we may
5856 want to add arguments but with a NULL-expression. */
5859 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5860 locus where
, unsigned numarg
, ...)
5863 gfc_actual_arglist
* atail
;
5864 gfc_intrinsic_sym
* isym
;
5867 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5869 isym
= gfc_intrinsic_function_by_id (id
);
5872 result
= gfc_get_expr ();
5873 result
->expr_type
= EXPR_FUNCTION
;
5874 result
->ts
= isym
->ts
;
5875 result
->where
= where
;
5876 result
->value
.function
.name
= mangled_name
;
5877 result
->value
.function
.isym
= isym
;
5879 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5880 gfc_commit_symbol (result
->symtree
->n
.sym
);
5881 gcc_assert (result
->symtree
5882 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5883 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5884 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5885 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5886 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5887 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5889 va_start (ap
, numarg
);
5891 for (i
= 0; i
< numarg
; ++i
)
5895 atail
->next
= gfc_get_actual_arglist ();
5896 atail
= atail
->next
;
5899 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5901 atail
->expr
= va_arg (ap
, gfc_expr
*);
5909 /* Check if an expression may appear in a variable definition context
5910 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5911 This is called from the various places when resolving
5912 the pieces that make up such a context.
5913 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5914 variables), some checks are not performed.
5916 Optionally, a possible error message can be suppressed if context is NULL
5917 and just the return status (true / false) be requested. */
5920 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5921 bool own_scope
, const char* context
)
5923 gfc_symbol
* sym
= NULL
;
5925 bool check_intentin
;
5927 symbol_attribute attr
;
5931 if (e
->expr_type
== EXPR_VARIABLE
)
5933 gcc_assert (e
->symtree
);
5934 sym
= e
->symtree
->n
.sym
;
5936 else if (e
->expr_type
== EXPR_FUNCTION
)
5938 gcc_assert (e
->symtree
);
5939 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5942 attr
= gfc_expr_attr (e
);
5943 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5945 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5948 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5949 " context (%s) at %L", context
, &e
->where
);
5953 else if (e
->expr_type
!= EXPR_VARIABLE
)
5956 gfc_error ("Non-variable expression in variable definition context (%s)"
5957 " at %L", context
, &e
->where
);
5961 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5964 gfc_error ("Named constant %qs in variable definition context (%s)"
5965 " at %L", sym
->name
, context
, &e
->where
);
5968 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5969 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5970 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5973 gfc_error ("%qs in variable definition context (%s) at %L is not"
5974 " a variable", sym
->name
, context
, &e
->where
);
5978 /* Find out whether the expr is a pointer; this also means following
5979 component references to the last one. */
5980 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5981 if (pointer
&& !is_pointer
)
5984 gfc_error ("Non-POINTER in pointer association context (%s)"
5985 " at %L", context
, &e
->where
);
5989 if (e
->ts
.type
== BT_DERIVED
5990 && e
->ts
.u
.derived
== NULL
)
5993 gfc_error ("Type inaccessible in variable definition context (%s) "
5994 "at %L", context
, &e
->where
);
6001 || (e
->ts
.type
== BT_DERIVED
6002 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6003 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
6006 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
6007 context
, &e
->where
);
6011 /* TS18508, C702/C203. */
6014 || (e
->ts
.type
== BT_DERIVED
6015 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
6016 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
6019 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
6020 context
, &e
->where
);
6024 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
6025 component of sub-component of a pointer; we need to distinguish
6026 assignment to a pointer component from pointer-assignment to a pointer
6027 component. Note that (normal) assignment to procedure pointers is not
6029 check_intentin
= !own_scope
;
6030 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
6031 && CLASS_DATA (sym
))
6032 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
6033 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
6035 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
6036 check_intentin
= false;
6037 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
6039 ptr_component
= true;
6041 check_intentin
= false;
6044 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
6046 if (pointer
&& is_pointer
)
6049 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
6050 " association context (%s) at %L",
6051 sym
->name
, context
, &e
->where
);
6054 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
6057 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
6058 " definition context (%s) at %L",
6059 sym
->name
, context
, &e
->where
);
6064 /* PROTECTED and use-associated. */
6065 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
6067 if (pointer
&& is_pointer
)
6070 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6071 " pointer association context (%s) at %L",
6072 sym
->name
, context
, &e
->where
);
6075 if (!pointer
&& !is_pointer
)
6078 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6079 " variable definition context (%s) at %L",
6080 sym
->name
, context
, &e
->where
);
6085 /* Variable not assignable from a PURE procedure but appears in
6086 variable definition context. */
6087 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6090 gfc_error ("Variable %qs cannot appear in a variable definition"
6091 " context (%s) at %L in PURE procedure",
6092 sym
->name
, context
, &e
->where
);
6096 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6097 && gfc_impure_variable (sym
))
6102 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6104 sym
= ns
->proc_name
;
6107 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6109 sym
->attr
.implicit_pure
= 0;
6114 /* Check variable definition context for associate-names. */
6115 if (!pointer
&& sym
->assoc
)
6118 gfc_association_list
* assoc
;
6120 gcc_assert (sym
->assoc
->target
);
6122 /* If this is a SELECT TYPE temporary (the association is used internally
6123 for SELECT TYPE), silently go over to the target. */
6124 if (sym
->attr
.select_type_temporary
)
6126 gfc_expr
* t
= sym
->assoc
->target
;
6128 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6129 name
= t
->symtree
->name
;
6131 if (t
->symtree
->n
.sym
->assoc
)
6132 assoc
= t
->symtree
->n
.sym
->assoc
;
6141 gcc_assert (name
&& assoc
);
6143 /* Is association to a valid variable? */
6144 if (!assoc
->variable
)
6148 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6149 gfc_error ("%qs at %L associated to vector-indexed target"
6150 " cannot be used in a variable definition"
6152 name
, &e
->where
, context
);
6154 gfc_error ("%qs at %L associated to expression"
6155 " cannot be used in a variable definition"
6157 name
, &e
->where
, context
);
6162 /* Target must be allowed to appear in a variable definition context. */
6163 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6166 gfc_error ("Associate-name %qs cannot appear in a variable"
6167 " definition context (%s) at %L because its target"
6168 " at %L cannot, either",
6169 name
, context
, &e
->where
,
6170 &assoc
->target
->where
);
6175 /* Check for same value in vector expression subscript. */
6178 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6179 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6180 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6181 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6182 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6184 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6185 if (arr
->expr_type
== EXPR_ARRAY
)
6187 gfc_constructor
*c
, *n
;
6190 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6191 c
!= NULL
; c
= gfc_constructor_next (c
))
6193 if (c
== NULL
|| c
->iterator
!= NULL
)
6198 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6199 n
= gfc_constructor_next (n
))
6201 if (n
->iterator
!= NULL
)
6205 if (gfc_dep_compare_expr (ec
, en
) == 0)
6208 gfc_error_now ("Elements with the same value "
6209 "at %L and %L in vector "
6210 "subscript in a variable "
6211 "definition context (%s)",
6212 &(ec
->where
), &(en
->where
),