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
)
1075 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1076 && e
->symtree
->n
.sym
->attr
.dummy
1077 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
1078 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
)
1082 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1084 if (ref
->type
== REF_ARRAY
1085 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1089 && ref
->type
!= REF_ARRAY
)
1096 /* Try to collapse intrinsic expressions. */
1099 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1101 gfc_intrinsic_op op
;
1102 gfc_expr
*op1
, *op2
, *result
;
1104 if (p
->value
.op
.op
== INTRINSIC_USER
)
1107 op1
= p
->value
.op
.op1
;
1108 op2
= p
->value
.op
.op2
;
1109 op
= p
->value
.op
.op
;
1111 if (!gfc_simplify_expr (op1
, type
))
1113 if (!gfc_simplify_expr (op2
, type
))
1116 if (!gfc_is_constant_expr (op1
)
1117 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1121 p
->value
.op
.op1
= NULL
;
1122 p
->value
.op
.op2
= NULL
;
1126 case INTRINSIC_PARENTHESES
:
1127 result
= gfc_parentheses (op1
);
1130 case INTRINSIC_UPLUS
:
1131 result
= gfc_uplus (op1
);
1134 case INTRINSIC_UMINUS
:
1135 result
= gfc_uminus (op1
);
1138 case INTRINSIC_PLUS
:
1139 result
= gfc_add (op1
, op2
);
1142 case INTRINSIC_MINUS
:
1143 result
= gfc_subtract (op1
, op2
);
1146 case INTRINSIC_TIMES
:
1147 result
= gfc_multiply (op1
, op2
);
1150 case INTRINSIC_DIVIDE
:
1151 result
= gfc_divide (op1
, op2
);
1154 case INTRINSIC_POWER
:
1155 result
= gfc_power (op1
, op2
);
1158 case INTRINSIC_CONCAT
:
1159 result
= gfc_concat (op1
, op2
);
1163 case INTRINSIC_EQ_OS
:
1164 result
= gfc_eq (op1
, op2
, op
);
1168 case INTRINSIC_NE_OS
:
1169 result
= gfc_ne (op1
, op2
, op
);
1173 case INTRINSIC_GT_OS
:
1174 result
= gfc_gt (op1
, op2
, op
);
1178 case INTRINSIC_GE_OS
:
1179 result
= gfc_ge (op1
, op2
, op
);
1183 case INTRINSIC_LT_OS
:
1184 result
= gfc_lt (op1
, op2
, op
);
1188 case INTRINSIC_LE_OS
:
1189 result
= gfc_le (op1
, op2
, op
);
1193 result
= gfc_not (op1
);
1197 result
= gfc_and (op1
, op2
);
1201 result
= gfc_or (op1
, op2
);
1205 result
= gfc_eqv (op1
, op2
);
1208 case INTRINSIC_NEQV
:
1209 result
= gfc_neqv (op1
, op2
);
1213 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1218 gfc_free_expr (op1
);
1219 gfc_free_expr (op2
);
1223 result
->rank
= p
->rank
;
1224 result
->where
= p
->where
;
1225 gfc_replace_expr (p
, result
);
1231 /* Subroutine to simplify constructor expressions. Mutually recursive
1232 with gfc_simplify_expr(). */
1235 simplify_constructor (gfc_constructor_base base
, int type
)
1240 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1243 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1244 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1245 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1250 /* Try and simplify a copy. Replace the original if successful
1251 but keep going through the constructor at all costs. Not
1252 doing so can make a dog's dinner of complicated things. */
1253 p
= gfc_copy_expr (c
->expr
);
1255 if (!gfc_simplify_expr (p
, type
))
1261 gfc_replace_expr (c
->expr
, p
);
1269 /* Pull a single array element out of an array constructor. */
1272 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1273 gfc_constructor
**rval
)
1275 unsigned long nelemen
;
1281 gfc_constructor
*cons
;
1288 mpz_init_set_ui (offset
, 0);
1291 mpz_init_set_ui (span
, 1);
1292 for (i
= 0; i
< ar
->dimen
; i
++)
1294 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1295 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1303 if (e
->expr_type
!= EXPR_CONSTANT
)
1309 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1310 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1312 /* Check the bounds. */
1313 if ((ar
->as
->upper
[i
]
1314 && mpz_cmp (e
->value
.integer
,
1315 ar
->as
->upper
[i
]->value
.integer
) > 0)
1316 || (mpz_cmp (e
->value
.integer
,
1317 ar
->as
->lower
[i
]->value
.integer
) < 0))
1319 gfc_error ("Index in dimension %d is out of bounds "
1320 "at %L", i
+ 1, &ar
->c_where
[i
]);
1326 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1327 mpz_mul (delta
, delta
, span
);
1328 mpz_add (offset
, offset
, delta
);
1330 mpz_set_ui (tmp
, 1);
1331 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1332 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1333 mpz_mul (span
, span
, tmp
);
1336 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1337 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1356 /* Find a component of a structure constructor. */
1358 static gfc_constructor
*
1359 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1361 gfc_component
*pick
= ref
->u
.c
.component
;
1362 gfc_constructor
*c
= gfc_constructor_first (base
);
1364 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1365 int ext
= dt
->attr
.extension
;
1367 /* For extended types, check if the desired component is in one of the
1369 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1370 pick
->name
, true, true, NULL
))
1372 dt
= dt
->components
->ts
.u
.derived
;
1373 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1377 gfc_component
*comp
= dt
->components
;
1378 while (comp
!= pick
)
1381 c
= gfc_constructor_next (c
);
1388 /* Replace an expression with the contents of a constructor, removing
1389 the subobject reference in the process. */
1392 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1402 e
= gfc_copy_expr (p
);
1403 e
->ref
= p
->ref
->next
;
1404 p
->ref
->next
= NULL
;
1405 gfc_replace_expr (p
, e
);
1409 /* Pull an array section out of an array constructor. */
1412 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1419 long unsigned one
= 1;
1421 mpz_t start
[GFC_MAX_DIMENSIONS
];
1422 mpz_t end
[GFC_MAX_DIMENSIONS
];
1423 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1424 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1425 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1430 gfc_constructor_base base
;
1431 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1441 base
= expr
->value
.constructor
;
1442 expr
->value
.constructor
= NULL
;
1444 rank
= ref
->u
.ar
.as
->rank
;
1446 if (expr
->shape
== NULL
)
1447 expr
->shape
= gfc_get_shape (rank
);
1449 mpz_init_set_ui (delta_mpz
, one
);
1450 mpz_init_set_ui (nelts
, one
);
1453 /* Do the initialization now, so that we can cleanup without
1454 keeping track of where we were. */
1455 for (d
= 0; d
< rank
; d
++)
1457 mpz_init (delta
[d
]);
1458 mpz_init (start
[d
]);
1461 mpz_init (stride
[d
]);
1465 /* Build the counters to clock through the array reference. */
1467 for (d
= 0; d
< rank
; d
++)
1469 /* Make this stretch of code easier on the eye! */
1470 begin
= ref
->u
.ar
.start
[d
];
1471 finish
= ref
->u
.ar
.end
[d
];
1472 step
= ref
->u
.ar
.stride
[d
];
1473 lower
= ref
->u
.ar
.as
->lower
[d
];
1474 upper
= ref
->u
.ar
.as
->upper
[d
];
1476 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1478 gfc_constructor
*ci
;
1481 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1487 gcc_assert (begin
->rank
== 1);
1488 /* Zero-sized arrays have no shape and no elements, stop early. */
1491 mpz_init_set_ui (nelts
, 0);
1495 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1496 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1497 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1498 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1501 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1503 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1504 || mpz_cmp (ci
->expr
->value
.integer
,
1505 lower
->value
.integer
) < 0)
1507 gfc_error ("index in dimension %d is out of bounds "
1508 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1516 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1517 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1518 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1524 /* Obtain the stride. */
1526 mpz_set (stride
[d
], step
->value
.integer
);
1528 mpz_set_ui (stride
[d
], one
);
1530 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1531 mpz_set_ui (stride
[d
], one
);
1533 /* Obtain the start value for the index. */
1535 mpz_set (start
[d
], begin
->value
.integer
);
1537 mpz_set (start
[d
], lower
->value
.integer
);
1539 mpz_set (ctr
[d
], start
[d
]);
1541 /* Obtain the end value for the index. */
1543 mpz_set (end
[d
], finish
->value
.integer
);
1545 mpz_set (end
[d
], upper
->value
.integer
);
1547 /* Separate 'if' because elements sometimes arrive with
1549 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1550 mpz_set (end
[d
], begin
->value
.integer
);
1552 /* Check the bounds. */
1553 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1554 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1555 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1556 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1558 gfc_error ("index in dimension %d is out of bounds "
1559 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1564 /* Calculate the number of elements and the shape. */
1565 mpz_set (tmp_mpz
, stride
[d
]);
1566 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1567 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1568 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1569 mpz_mul (nelts
, nelts
, tmp_mpz
);
1571 /* An element reference reduces the rank of the expression; don't
1572 add anything to the shape array. */
1573 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1574 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1577 /* Calculate the 'stride' (=delta) for conversion of the
1578 counter values into the index along the constructor. */
1579 mpz_set (delta
[d
], delta_mpz
);
1580 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1581 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1582 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1586 cons
= gfc_constructor_first (base
);
1588 /* Now clock through the array reference, calculating the index in
1589 the source constructor and transferring the elements to the new
1591 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1593 mpz_init_set_ui (ptr
, 0);
1596 for (d
= 0; d
< rank
; d
++)
1598 mpz_set (tmp_mpz
, ctr
[d
]);
1599 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1600 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1601 mpz_add (ptr
, ptr
, tmp_mpz
);
1603 if (!incr_ctr
) continue;
1605 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1607 gcc_assert(vecsub
[d
]);
1609 if (!gfc_constructor_next (vecsub
[d
]))
1610 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1613 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1616 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1620 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1622 if (mpz_cmp_ui (stride
[d
], 0) > 0
1623 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1624 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1625 mpz_set (ctr
[d
], start
[d
]);
1631 limit
= mpz_get_ui (ptr
);
1632 if (limit
>= flag_max_array_constructor
)
1634 gfc_error ("The number of elements in the array constructor "
1635 "at %L requires an increase of the allowed %d "
1636 "upper limit. See -fmax-array-constructor "
1637 "option", &expr
->where
, flag_max_array_constructor
);
1641 cons
= gfc_constructor_lookup (base
, limit
);
1643 gfc_constructor_append_expr (&expr
->value
.constructor
,
1644 gfc_copy_expr (cons
->expr
), NULL
);
1651 mpz_clear (delta_mpz
);
1652 mpz_clear (tmp_mpz
);
1654 for (d
= 0; d
< rank
; d
++)
1656 mpz_clear (delta
[d
]);
1657 mpz_clear (start
[d
]);
1660 mpz_clear (stride
[d
]);
1662 gfc_constructor_free (base
);
1666 /* Pull a substring out of an expression. */
1669 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1672 gfc_charlen_t start
;
1673 gfc_charlen_t length
;
1676 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1677 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1680 *newp
= gfc_copy_expr (p
);
1681 free ((*newp
)->value
.character
.string
);
1683 end
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1684 start
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1686 length
= end
- start
+ 1;
1690 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1691 (*newp
)->value
.character
.length
= length
;
1692 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1693 length
* sizeof (gfc_char_t
));
1699 /* Pull an inquiry result out of an expression. */
1702 find_inquiry_ref (gfc_expr
*p
, gfc_expr
**newp
)
1705 gfc_ref
*inquiry
= NULL
;
1708 tmp
= gfc_copy_expr (p
);
1710 if (tmp
->ref
&& tmp
->ref
->type
== REF_INQUIRY
)
1717 for (ref
= tmp
->ref
; ref
; ref
= ref
->next
)
1718 if (ref
->next
&& ref
->next
->type
== REF_INQUIRY
)
1720 inquiry
= ref
->next
;
1727 gfc_free_expr (tmp
);
1731 gfc_resolve_expr (tmp
);
1733 /* In principle there can be more than one inquiry reference. */
1734 for (; inquiry
; inquiry
= inquiry
->next
)
1736 switch (inquiry
->u
.i
)
1739 if (tmp
->ts
.type
!= BT_CHARACTER
)
1742 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1745 if (!tmp
->ts
.u
.cl
->length
1746 || tmp
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1749 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1753 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1756 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1759 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1760 NULL
, tmp
->ts
.kind
);
1764 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1767 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1770 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1771 mpfr_set ((*newp
)->value
.real
,
1772 mpc_realref (p
->value
.complex), GFC_RND_MODE
);
1776 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1779 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1782 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1783 mpfr_set ((*newp
)->value
.real
,
1784 mpc_imagref (p
->value
.complex), GFC_RND_MODE
);
1787 tmp
= gfc_copy_expr (*newp
);
1792 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1794 gfc_free_expr (*newp
);
1798 gfc_free_expr (tmp
);
1802 gfc_free_expr (tmp
);
1808 /* Simplify a subobject reference of a constructor. This occurs when
1809 parameter variable values are substituted. */
1812 simplify_const_ref (gfc_expr
*p
)
1814 gfc_constructor
*cons
, *c
;
1815 gfc_expr
*newp
= NULL
;
1820 switch (p
->ref
->type
)
1823 switch (p
->ref
->u
.ar
.type
)
1826 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1827 will generate this. */
1828 if (p
->expr_type
!= EXPR_ARRAY
)
1830 remove_subobject_ref (p
, NULL
);
1833 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1839 remove_subobject_ref (p
, cons
);
1843 if (!find_array_section (p
, p
->ref
))
1845 p
->ref
->u
.ar
.type
= AR_FULL
;
1850 if (p
->ref
->next
!= NULL
1851 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1853 for (c
= gfc_constructor_first (p
->value
.constructor
);
1854 c
; c
= gfc_constructor_next (c
))
1856 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1857 if (!simplify_const_ref (c
->expr
))
1861 if (gfc_bt_struct (p
->ts
.type
)
1863 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1865 /* There may have been component references. */
1866 p
->ts
= c
->expr
->ts
;
1870 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1872 if (p
->ts
.type
== BT_CHARACTER
1873 && last_ref
->type
== REF_SUBSTRING
)
1875 /* If this is a CHARACTER array and we possibly took
1876 a substring out of it, update the type-spec's
1877 character length according to the first element
1878 (as all should have the same length). */
1879 gfc_charlen_t string_len
;
1880 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1882 const gfc_expr
* first
= c
->expr
;
1883 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1884 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1885 string_len
= first
->value
.character
.length
;
1891 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1894 gfc_free_expr (p
->ts
.u
.cl
->length
);
1897 = gfc_get_int_expr (gfc_charlen_int_kind
,
1901 gfc_free_ref_list (p
->ref
);
1912 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1913 remove_subobject_ref (p
, cons
);
1917 if (!find_inquiry_ref (p
, &newp
))
1920 gfc_replace_expr (p
, newp
);
1921 gfc_free_ref_list (p
->ref
);
1926 if (!find_substring_ref (p
, &newp
))
1929 gfc_replace_expr (p
, newp
);
1930 gfc_free_ref_list (p
->ref
);
1940 /* Simplify a chain of references. */
1943 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
1948 for (; ref
; ref
= ref
->next
)
1953 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1955 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1957 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1959 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1965 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1967 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1972 if (!find_inquiry_ref (*p
, &newp
))
1975 gfc_replace_expr (*p
, newp
);
1976 gfc_free_ref_list ((*p
)->ref
);
1988 /* Try to substitute the value of a parameter variable. */
1991 simplify_parameter_variable (gfc_expr
*p
, int type
)
1996 if (gfc_is_size_zero_array (p
))
1998 if (p
->expr_type
== EXPR_ARRAY
)
2001 e
= gfc_get_expr ();
2002 e
->expr_type
= EXPR_ARRAY
;
2005 e
->value
.constructor
= NULL
;
2006 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2007 e
->where
= p
->where
;
2008 gfc_replace_expr (p
, e
);
2012 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2018 /* Do not copy subobject refs for constant. */
2019 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2020 e
->ref
= gfc_copy_ref (p
->ref
);
2021 t
= gfc_simplify_expr (e
, type
);
2023 /* Only use the simplification if it eliminated all subobject references. */
2025 gfc_replace_expr (p
, e
);
2034 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2036 /* Given an expression, simplify it by collapsing constant
2037 expressions. Most simplification takes place when the expression
2038 tree is being constructed. If an intrinsic function is simplified
2039 at some point, we get called again to collapse the result against
2042 We work by recursively simplifying expression nodes, simplifying
2043 intrinsic functions where possible, which can lead to further
2044 constant collapsing. If an operator has constant operand(s), we
2045 rip the expression apart, and rebuild it, hoping that it becomes
2048 The expression type is defined for:
2049 0 Basic expression parsing
2050 1 Simplifying array constructors -- will substitute
2052 Returns false on error, true otherwise.
2053 NOTE: Will return true even if the expression cannot be simplified. */
2056 gfc_simplify_expr (gfc_expr
*p
, int type
)
2058 gfc_actual_arglist
*ap
;
2059 gfc_intrinsic_sym
* isym
= NULL
;
2065 switch (p
->expr_type
)
2068 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2069 simplify_ref_chain (p
->ref
, type
, &p
);
2075 // For array-bound functions, we don't need to optimize
2076 // the 'array' argument. In particular, if the argument
2077 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2078 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2079 // can have any lbound.
2080 ap
= p
->value
.function
.actual
;
2081 if (p
->value
.function
.isym
&&
2082 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2083 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2084 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2085 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
))
2088 for ( ; ap
; ap
= ap
->next
)
2089 if (!gfc_simplify_expr (ap
->expr
, type
))
2092 if (p
->value
.function
.isym
!= NULL
2093 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2096 if (p
->expr_type
== EXPR_FUNCTION
)
2099 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2100 if (isym
&& isym
->elemental
)
2101 scalarize_intrinsic_call (p
, false);
2106 case EXPR_SUBSTRING
:
2107 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2110 if (gfc_is_constant_expr (p
))
2113 HOST_WIDE_INT start
, end
;
2116 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2118 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2119 start
--; /* Convert from one-based to zero-based. */
2122 end
= p
->value
.character
.length
;
2123 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2124 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2129 s
= gfc_get_wide_string (end
- start
+ 2);
2130 memcpy (s
, p
->value
.character
.string
+ start
,
2131 (end
- start
) * sizeof (gfc_char_t
));
2132 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2133 free (p
->value
.character
.string
);
2134 p
->value
.character
.string
= s
;
2135 p
->value
.character
.length
= end
- start
;
2136 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2137 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2139 p
->value
.character
.length
);
2140 gfc_free_ref_list (p
->ref
);
2142 p
->expr_type
= EXPR_CONSTANT
;
2147 if (!simplify_intrinsic_op (p
, type
))
2152 /* Only substitute array parameter variables if we are in an
2153 initialization expression, or we want a subsection. */
2154 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2155 && (gfc_init_expr_flag
|| p
->ref
2156 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2158 if (!simplify_parameter_variable (p
, type
))
2165 gfc_simplify_iterator_var (p
);
2168 /* Simplify subcomponent references. */
2169 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2174 case EXPR_STRUCTURE
:
2176 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2179 if (!simplify_constructor (p
->value
.constructor
, type
))
2182 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2183 && p
->ref
->u
.ar
.type
== AR_FULL
)
2184 gfc_expand_constructor (p
, false);
2186 if (!simplify_const_ref (p
))
2200 /* Returns the type of an expression with the exception that iterator
2201 variables are automatically integers no matter what else they may
2207 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2214 /* Scalarize an expression for an elemental intrinsic call. */
2217 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2219 gfc_actual_arglist
*a
, *b
;
2220 gfc_constructor_base ctor
;
2221 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2222 gfc_constructor
*ci
, *new_ctor
;
2223 gfc_expr
*expr
, *old
;
2224 int n
, i
, rank
[5], array_arg
;
2230 a
= e
->value
.function
.actual
;
2231 for (; a
; a
= a
->next
)
2232 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2235 /* Find which, if any, arguments are arrays. Assume that the old
2236 expression carries the type information and that the first arg
2237 that is an array expression carries all the shape information.*/
2239 a
= e
->value
.function
.actual
;
2240 for (; a
; a
= a
->next
)
2243 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2246 expr
= gfc_copy_expr (a
->expr
);
2253 old
= gfc_copy_expr (e
);
2255 gfc_constructor_free (expr
->value
.constructor
);
2256 expr
->value
.constructor
= NULL
;
2258 expr
->where
= old
->where
;
2259 expr
->expr_type
= EXPR_ARRAY
;
2261 /* Copy the array argument constructors into an array, with nulls
2264 a
= old
->value
.function
.actual
;
2265 for (; a
; a
= a
->next
)
2267 /* Check that this is OK for an initialization expression. */
2268 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2272 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2274 rank
[n
] = a
->expr
->rank
;
2275 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2276 args
[n
] = gfc_constructor_first (ctor
);
2278 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2281 rank
[n
] = a
->expr
->rank
;
2284 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2285 args
[n
] = gfc_constructor_first (ctor
);
2293 gfc_get_errors (NULL
, &errors
);
2295 /* Using the array argument as the master, step through the array
2296 calling the function for each element and advancing the array
2297 constructors together. */
2298 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2300 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2301 gfc_copy_expr (old
), NULL
);
2303 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2305 b
= old
->value
.function
.actual
;
2306 for (i
= 0; i
< n
; i
++)
2309 new_ctor
->expr
->value
.function
.actual
2310 = a
= gfc_get_actual_arglist ();
2313 a
->next
= gfc_get_actual_arglist ();
2318 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2320 a
->expr
= gfc_copy_expr (b
->expr
);
2325 /* Simplify the function calls. If the simplification fails, the
2326 error will be flagged up down-stream or the library will deal
2329 gfc_simplify_expr (new_ctor
->expr
, 0);
2331 for (i
= 0; i
< n
; i
++)
2333 args
[i
] = gfc_constructor_next (args
[i
]);
2335 for (i
= 1; i
< n
; i
++)
2336 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2337 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2343 /* Free "expr" but not the pointers it contains. */
2345 gfc_free_expr (old
);
2349 gfc_error_now ("elemental function arguments at %C are not compliant");
2352 gfc_free_expr (expr
);
2353 gfc_free_expr (old
);
2359 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2361 gfc_expr
*op1
= e
->value
.op
.op1
;
2362 gfc_expr
*op2
= e
->value
.op
.op2
;
2364 if (!(*check_function
)(op1
))
2367 switch (e
->value
.op
.op
)
2369 case INTRINSIC_UPLUS
:
2370 case INTRINSIC_UMINUS
:
2371 if (!numeric_type (et0 (op1
)))
2376 case INTRINSIC_EQ_OS
:
2378 case INTRINSIC_NE_OS
:
2380 case INTRINSIC_GT_OS
:
2382 case INTRINSIC_GE_OS
:
2384 case INTRINSIC_LT_OS
:
2386 case INTRINSIC_LE_OS
:
2387 if (!(*check_function
)(op2
))
2390 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2391 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2393 gfc_error ("Numeric or CHARACTER operands are required in "
2394 "expression at %L", &e
->where
);
2399 case INTRINSIC_PLUS
:
2400 case INTRINSIC_MINUS
:
2401 case INTRINSIC_TIMES
:
2402 case INTRINSIC_DIVIDE
:
2403 case INTRINSIC_POWER
:
2404 if (!(*check_function
)(op2
))
2407 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2412 case INTRINSIC_CONCAT
:
2413 if (!(*check_function
)(op2
))
2416 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2418 gfc_error ("Concatenation operator in expression at %L "
2419 "must have two CHARACTER operands", &op1
->where
);
2423 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2425 gfc_error ("Concat operator at %L must concatenate strings of the "
2426 "same kind", &e
->where
);
2433 if (et0 (op1
) != BT_LOGICAL
)
2435 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2436 "operand", &op1
->where
);
2445 case INTRINSIC_NEQV
:
2446 if (!(*check_function
)(op2
))
2449 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2451 gfc_error ("LOGICAL operands are required in expression at %L",
2458 case INTRINSIC_PARENTHESES
:
2462 gfc_error ("Only intrinsic operators can be used in expression at %L",
2470 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2475 /* F2003, 7.1.7 (3): In init expression, allocatable components
2476 must not be data-initialized. */
2478 check_alloc_comp_init (gfc_expr
*e
)
2480 gfc_component
*comp
;
2481 gfc_constructor
*ctor
;
2483 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2484 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2486 for (comp
= e
->ts
.u
.derived
->components
,
2487 ctor
= gfc_constructor_first (e
->value
.constructor
);
2488 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2490 if (comp
->attr
.allocatable
&& ctor
->expr
2491 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2493 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2494 "component %qs in structure constructor at %L",
2495 comp
->name
, &ctor
->expr
->where
);
2504 check_init_expr_arguments (gfc_expr
*e
)
2506 gfc_actual_arglist
*ap
;
2508 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2509 if (!gfc_check_init_expr (ap
->expr
))
2515 static bool check_restricted (gfc_expr
*);
2517 /* F95, 7.1.6.1, Initialization expressions, (7)
2518 F2003, 7.1.7 Initialization expression, (8)
2519 F2008, 7.1.12 Constant expression, (4) */
2522 check_inquiry (gfc_expr
*e
, int not_restricted
)
2525 const char *const *functions
;
2527 static const char *const inquiry_func_f95
[] = {
2528 "lbound", "shape", "size", "ubound",
2529 "bit_size", "len", "kind",
2530 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2531 "precision", "radix", "range", "tiny",
2535 static const char *const inquiry_func_f2003
[] = {
2536 "lbound", "shape", "size", "ubound",
2537 "bit_size", "len", "kind",
2538 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2539 "precision", "radix", "range", "tiny",
2543 /* std=f2008+ or -std=gnu */
2544 static const char *const inquiry_func_gnu
[] = {
2545 "lbound", "shape", "size", "ubound",
2546 "bit_size", "len", "kind",
2547 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2548 "precision", "radix", "range", "tiny",
2549 "new_line", "storage_size", NULL
2553 gfc_actual_arglist
*ap
;
2555 if (!e
->value
.function
.isym
2556 || !e
->value
.function
.isym
->inquiry
)
2559 /* An undeclared parameter will get us here (PR25018). */
2560 if (e
->symtree
== NULL
)
2563 if (e
->symtree
->n
.sym
->from_intmod
)
2565 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2566 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2567 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2570 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2571 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2576 name
= e
->symtree
->n
.sym
->name
;
2578 functions
= inquiry_func_gnu
;
2579 if (gfc_option
.warn_std
& GFC_STD_F2003
)
2580 functions
= inquiry_func_f2003
;
2581 if (gfc_option
.warn_std
& GFC_STD_F95
)
2582 functions
= inquiry_func_f95
;
2584 for (i
= 0; functions
[i
]; i
++)
2585 if (strcmp (functions
[i
], name
) == 0)
2588 if (functions
[i
] == NULL
)
2592 /* At this point we have an inquiry function with a variable argument. The
2593 type of the variable might be undefined, but we need it now, because the
2594 arguments of these functions are not allowed to be undefined. */
2596 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2601 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2603 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2604 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2607 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2610 /* Assumed character length will not reduce to a constant expression
2611 with LEN, as required by the standard. */
2612 if (i
== 5 && not_restricted
&& ap
->expr
->symtree
2613 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2614 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2615 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2617 gfc_error ("Assumed or deferred character length variable %qs "
2618 "in constant expression at %L",
2619 ap
->expr
->symtree
->n
.sym
->name
,
2623 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2626 if (not_restricted
== 0
2627 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2628 && !check_restricted (ap
->expr
))
2631 if (not_restricted
== 0
2632 && ap
->expr
->expr_type
== EXPR_VARIABLE
2633 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2634 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2642 /* F95, 7.1.6.1, Initialization expressions, (5)
2643 F2003, 7.1.7 Initialization expression, (5) */
2646 check_transformational (gfc_expr
*e
)
2648 static const char * const trans_func_f95
[] = {
2649 "repeat", "reshape", "selected_int_kind",
2650 "selected_real_kind", "transfer", "trim", NULL
2653 static const char * const trans_func_f2003
[] = {
2654 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2655 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2656 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2657 "trim", "unpack", NULL
2660 static const char * const trans_func_f2008
[] = {
2661 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2662 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2663 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2664 "trim", "unpack", "findloc", NULL
2669 const char *const *functions
;
2671 if (!e
->value
.function
.isym
2672 || !e
->value
.function
.isym
->transformational
)
2675 name
= e
->symtree
->n
.sym
->name
;
2677 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2678 functions
= trans_func_f2008
;
2679 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2680 functions
= trans_func_f2003
;
2682 functions
= trans_func_f95
;
2684 /* NULL() is dealt with below. */
2685 if (strcmp ("null", name
) == 0)
2688 for (i
= 0; functions
[i
]; i
++)
2689 if (strcmp (functions
[i
], name
) == 0)
2692 if (functions
[i
] == NULL
)
2694 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2695 "in an initialization expression", name
, &e
->where
);
2699 return check_init_expr_arguments (e
);
2703 /* F95, 7.1.6.1, Initialization expressions, (6)
2704 F2003, 7.1.7 Initialization expression, (6) */
2707 check_null (gfc_expr
*e
)
2709 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2712 return check_init_expr_arguments (e
);
2717 check_elemental (gfc_expr
*e
)
2719 if (!e
->value
.function
.isym
2720 || !e
->value
.function
.isym
->elemental
)
2723 if (e
->ts
.type
!= BT_INTEGER
2724 && e
->ts
.type
!= BT_CHARACTER
2725 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2726 "initialization expression at %L", &e
->where
))
2729 return check_init_expr_arguments (e
);
2734 check_conversion (gfc_expr
*e
)
2736 if (!e
->value
.function
.isym
2737 || !e
->value
.function
.isym
->conversion
)
2740 return check_init_expr_arguments (e
);
2744 /* Verify that an expression is an initialization expression. A side
2745 effect is that the expression tree is reduced to a single constant
2746 node if all goes well. This would normally happen when the
2747 expression is constructed but function references are assumed to be
2748 intrinsics in the context of initialization expressions. If
2749 false is returned an error message has been generated. */
2752 gfc_check_init_expr (gfc_expr
*e
)
2760 switch (e
->expr_type
)
2763 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2765 t
= gfc_simplify_expr (e
, 0);
2774 gfc_intrinsic_sym
* isym
= NULL
;
2775 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2777 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2778 IEEE_EXCEPTIONS modules. */
2779 int mod
= sym
->from_intmod
;
2780 if (mod
== INTMOD_NONE
&& sym
->generic
)
2781 mod
= sym
->generic
->sym
->from_intmod
;
2782 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2784 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2787 gfc_replace_expr (e
, new_expr
);
2793 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2794 into an array constructor, we need to skip the error check here.
2795 Conversion errors are caught below in scalarize_intrinsic_call. */
2796 conversion
= e
->value
.function
.isym
2797 && (e
->value
.function
.isym
->conversion
== 1);
2799 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2800 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2802 gfc_error ("Function %qs in initialization expression at %L "
2803 "must be an intrinsic function",
2804 e
->symtree
->n
.sym
->name
, &e
->where
);
2808 if ((m
= check_conversion (e
)) == MATCH_NO
2809 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2810 && (m
= check_null (e
)) == MATCH_NO
2811 && (m
= check_transformational (e
)) == MATCH_NO
2812 && (m
= check_elemental (e
)) == MATCH_NO
)
2814 gfc_error ("Intrinsic function %qs at %L is not permitted "
2815 "in an initialization expression",
2816 e
->symtree
->n
.sym
->name
, &e
->where
);
2820 if (m
== MATCH_ERROR
)
2823 /* Try to scalarize an elemental intrinsic function that has an
2825 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2826 if (isym
&& isym
->elemental
2827 && (t
= scalarize_intrinsic_call (e
, true)))
2832 t
= gfc_simplify_expr (e
, 0);
2839 /* This occurs when parsing pdt templates. */
2840 if (gfc_expr_attr (e
).pdt_kind
)
2843 if (gfc_check_iter_variable (e
))
2846 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2848 /* A PARAMETER shall not be used to define itself, i.e.
2849 REAL, PARAMETER :: x = transfer(0, x)
2851 if (!e
->symtree
->n
.sym
->value
)
2853 gfc_error ("PARAMETER %qs is used at %L before its definition "
2854 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2858 t
= simplify_parameter_variable (e
, 0);
2863 if (gfc_in_match_data ())
2868 if (e
->symtree
->n
.sym
->as
)
2870 switch (e
->symtree
->n
.sym
->as
->type
)
2872 case AS_ASSUMED_SIZE
:
2873 gfc_error ("Assumed size array %qs at %L is not permitted "
2874 "in an initialization expression",
2875 e
->symtree
->n
.sym
->name
, &e
->where
);
2878 case AS_ASSUMED_SHAPE
:
2879 gfc_error ("Assumed shape array %qs at %L is not permitted "
2880 "in an initialization expression",
2881 e
->symtree
->n
.sym
->name
, &e
->where
);
2885 if (!e
->symtree
->n
.sym
->attr
.allocatable
2886 && !e
->symtree
->n
.sym
->attr
.pointer
2887 && e
->symtree
->n
.sym
->attr
.dummy
)
2888 gfc_error ("Assumed-shape array %qs at %L is not permitted "
2889 "in an initialization expression",
2890 e
->symtree
->n
.sym
->name
, &e
->where
);
2892 gfc_error ("Deferred array %qs at %L is not permitted "
2893 "in an initialization expression",
2894 e
->symtree
->n
.sym
->name
, &e
->where
);
2898 gfc_error ("Array %qs at %L is a variable, which does "
2899 "not reduce to a constant expression",
2900 e
->symtree
->n
.sym
->name
, &e
->where
);
2908 gfc_error ("Parameter %qs at %L has not been declared or is "
2909 "a variable, which does not reduce to a constant "
2910 "expression", e
->symtree
->name
, &e
->where
);
2919 case EXPR_SUBSTRING
:
2922 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2926 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2928 t
= gfc_simplify_expr (e
, 0);
2934 case EXPR_STRUCTURE
:
2935 t
= e
->ts
.is_iso_c
? true : false;
2939 t
= check_alloc_comp_init (e
);
2943 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2950 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2954 t
= gfc_expand_constructor (e
, true);
2958 t
= gfc_check_constructor_type (e
);
2962 gfc_internal_error ("check_init_expr(): Unknown expression type");
2968 /* Reduces a general expression to an initialization expression (a constant).
2969 This used to be part of gfc_match_init_expr.
2970 Note that this function doesn't free the given expression on false. */
2973 gfc_reduce_init_expr (gfc_expr
*expr
)
2977 gfc_init_expr_flag
= true;
2978 t
= gfc_resolve_expr (expr
);
2980 t
= gfc_check_init_expr (expr
);
2981 gfc_init_expr_flag
= false;
2986 if (expr
->expr_type
== EXPR_ARRAY
)
2988 if (!gfc_check_constructor_type (expr
))
2990 if (!gfc_expand_constructor (expr
, true))
2998 /* Match an initialization expression. We work by first matching an
2999 expression, then reducing it to a constant. */
3002 gfc_match_init_expr (gfc_expr
**result
)
3010 gfc_init_expr_flag
= true;
3012 m
= gfc_match_expr (&expr
);
3015 gfc_init_expr_flag
= false;
3019 if (gfc_derived_parameter_expr (expr
))
3022 gfc_init_expr_flag
= false;
3026 t
= gfc_reduce_init_expr (expr
);
3029 gfc_free_expr (expr
);
3030 gfc_init_expr_flag
= false;
3035 gfc_init_expr_flag
= false;
3041 /* Given an actual argument list, test to see that each argument is a
3042 restricted expression and optionally if the expression type is
3043 integer or character. */
3046 restricted_args (gfc_actual_arglist
*a
)
3048 for (; a
; a
= a
->next
)
3050 if (!check_restricted (a
->expr
))
3058 /************* Restricted/specification expressions *************/
3061 /* Make sure a non-intrinsic function is a specification function,
3062 * see F08:7.1.11.5. */
3065 external_spec_function (gfc_expr
*e
)
3069 f
= e
->value
.function
.esym
;
3071 /* IEEE functions allowed are "a reference to a transformational function
3072 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3073 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3074 IEEE_EXCEPTIONS". */
3075 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3076 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3078 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3079 || !strcmp (f
->name
, "ieee_support_rounding")
3080 || !strcmp (f
->name
, "ieee_support_flag")
3081 || !strcmp (f
->name
, "ieee_support_halting")
3082 || !strcmp (f
->name
, "ieee_support_datatype")
3083 || !strcmp (f
->name
, "ieee_support_denormal")
3084 || !strcmp (f
->name
, "ieee_support_subnormal")
3085 || !strcmp (f
->name
, "ieee_support_divide")
3086 || !strcmp (f
->name
, "ieee_support_inf")
3087 || !strcmp (f
->name
, "ieee_support_io")
3088 || !strcmp (f
->name
, "ieee_support_nan")
3089 || !strcmp (f
->name
, "ieee_support_sqrt")
3090 || !strcmp (f
->name
, "ieee_support_standard")
3091 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3092 goto function_allowed
;
3095 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3097 gfc_error ("Specification function %qs at %L cannot be a statement "
3098 "function", f
->name
, &e
->where
);
3102 if (f
->attr
.proc
== PROC_INTERNAL
)
3104 gfc_error ("Specification function %qs at %L cannot be an internal "
3105 "function", f
->name
, &e
->where
);
3109 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3111 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3117 if (f
->attr
.recursive
3118 && !gfc_notify_std (GFC_STD_F2003
,
3119 "Specification function %qs "
3120 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3124 return restricted_args (e
->value
.function
.actual
);
3128 /* Check to see that a function reference to an intrinsic is a
3129 restricted expression. */
3132 restricted_intrinsic (gfc_expr
*e
)
3134 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3135 if (check_inquiry (e
, 0) == MATCH_YES
)
3138 return restricted_args (e
->value
.function
.actual
);
3142 /* Check the expressions of an actual arglist. Used by check_restricted. */
3145 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3147 for (; arg
; arg
= arg
->next
)
3148 if (!checker (arg
->expr
))
3155 /* Check the subscription expressions of a reference chain with a checking
3156 function; used by check_restricted. */
3159 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3169 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
3171 if (!checker (ref
->u
.ar
.start
[dim
]))
3173 if (!checker (ref
->u
.ar
.end
[dim
]))
3175 if (!checker (ref
->u
.ar
.stride
[dim
]))
3181 /* Nothing needed, just proceed to next reference. */
3185 if (!checker (ref
->u
.ss
.start
))
3187 if (!checker (ref
->u
.ss
.end
))
3196 return check_references (ref
->next
, checker
);
3199 /* Return true if ns is a parent of the current ns. */
3202 is_parent_of_current_ns (gfc_namespace
*ns
)
3205 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3212 /* Verify that an expression is a restricted expression. Like its
3213 cousin check_init_expr(), an error message is generated if we
3217 check_restricted (gfc_expr
*e
)
3225 switch (e
->expr_type
)
3228 t
= check_intrinsic_op (e
, check_restricted
);
3230 t
= gfc_simplify_expr (e
, 0);
3235 if (e
->value
.function
.esym
)
3237 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3239 t
= external_spec_function (e
);
3243 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3246 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3249 t
= restricted_intrinsic (e
);
3254 sym
= e
->symtree
->n
.sym
;
3257 /* If a dummy argument appears in a context that is valid for a
3258 restricted expression in an elemental procedure, it will have
3259 already been simplified away once we get here. Therefore we
3260 don't need to jump through hoops to distinguish valid from
3262 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3263 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3265 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3266 sym
->name
, &e
->where
);
3270 if (sym
->attr
.optional
)
3272 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3273 sym
->name
, &e
->where
);
3277 if (sym
->attr
.intent
== INTENT_OUT
)
3279 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3280 sym
->name
, &e
->where
);
3284 /* Check reference chain if any. */
3285 if (!check_references (e
->ref
, &check_restricted
))
3288 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3289 processed in resolve.c(resolve_formal_arglist). This is done so
3290 that host associated dummy array indices are accepted (PR23446).
3291 This mechanism also does the same for the specification expressions
3292 of array-valued functions. */
3294 || sym
->attr
.in_common
3295 || sym
->attr
.use_assoc
3297 || sym
->attr
.implied_index
3298 || sym
->attr
.flavor
== FL_PARAMETER
3299 || is_parent_of_current_ns (sym
->ns
)
3300 || (sym
->ns
->proc_name
!= NULL
3301 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3302 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3308 gfc_error ("Variable %qs cannot appear in the expression at %L",
3309 sym
->name
, &e
->where
);
3310 /* Prevent a repetition of the error. */
3319 case EXPR_SUBSTRING
:
3320 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3324 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3326 t
= gfc_simplify_expr (e
, 0);
3330 case EXPR_STRUCTURE
:
3331 t
= gfc_check_constructor (e
, check_restricted
);
3335 t
= gfc_check_constructor (e
, check_restricted
);
3339 gfc_internal_error ("check_restricted(): Unknown expression type");
3346 /* Check to see that an expression is a specification expression. If
3347 we return false, an error has been generated. */
3350 gfc_specification_expr (gfc_expr
*e
)
3352 gfc_component
*comp
;
3357 if (e
->ts
.type
!= BT_INTEGER
)
3359 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3360 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3364 comp
= gfc_get_proc_ptr_comp (e
);
3365 if (e
->expr_type
== EXPR_FUNCTION
3366 && !e
->value
.function
.isym
3367 && !e
->value
.function
.esym
3368 && !gfc_pure (e
->symtree
->n
.sym
)
3369 && (!comp
|| !comp
->attr
.pure
))
3371 gfc_error ("Function %qs at %L must be PURE",
3372 e
->symtree
->n
.sym
->name
, &e
->where
);
3373 /* Prevent repeat error messages. */
3374 e
->symtree
->n
.sym
->attr
.pure
= 1;
3380 gfc_error ("Expression at %L must be scalar", &e
->where
);
3384 if (!gfc_simplify_expr (e
, 0))
3387 return check_restricted (e
);
3391 /************** Expression conformance checks. *************/
3393 /* Given two expressions, make sure that the arrays are conformable. */
3396 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3398 int op1_flag
, op2_flag
, d
;
3399 mpz_t op1_size
, op2_size
;
3405 if (op1
->rank
== 0 || op2
->rank
== 0)
3408 va_start (argp
, optype_msgid
);
3409 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3412 if (op1
->rank
!= op2
->rank
)
3414 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3415 op1
->rank
, op2
->rank
, &op1
->where
);
3421 for (d
= 0; d
< op1
->rank
; d
++)
3423 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3424 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3426 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3428 gfc_error ("Different shape for %s at %L on dimension %d "
3429 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3430 (int) mpz_get_si (op1_size
),
3431 (int) mpz_get_si (op2_size
));
3437 mpz_clear (op1_size
);
3439 mpz_clear (op2_size
);
3449 /* Given an assignable expression and an arbitrary expression, make
3450 sure that the assignment can take place. Only add a call to the intrinsic
3451 conversion routines, when allow_convert is set. When this assign is a
3452 coarray call, then the convert is done by the coarray routine implictly and
3453 adding the intrinsic conversion would do harm in most cases. */
3456 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3463 sym
= lvalue
->symtree
->n
.sym
;
3465 /* See if this is the component or subcomponent of a pointer and guard
3466 against assignment to LEN or KIND part-refs. */
3467 has_pointer
= sym
->attr
.pointer
;
3468 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3470 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3471 && ref
->u
.c
.component
->attr
.pointer
)
3473 else if (ref
->type
== REF_INQUIRY
3474 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3476 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3477 "allowed", &lvalue
->where
);
3482 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3483 variable local to a function subprogram. Its existence begins when
3484 execution of the function is initiated and ends when execution of the
3485 function is terminated...
3486 Therefore, the left hand side is no longer a variable, when it is: */
3487 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3488 && !sym
->attr
.external
)
3493 /* (i) Use associated; */
3494 if (sym
->attr
.use_assoc
)
3497 /* (ii) The assignment is in the main program; or */
3498 if (gfc_current_ns
->proc_name
3499 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3502 /* (iii) A module or internal procedure... */
3503 if (gfc_current_ns
->proc_name
3504 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3505 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3506 && gfc_current_ns
->parent
3507 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3508 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3509 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3511 /* ... that is not a function... */
3512 if (gfc_current_ns
->proc_name
3513 && !gfc_current_ns
->proc_name
->attr
.function
)
3516 /* ... or is not an entry and has a different name. */
3517 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3521 /* (iv) Host associated and not the function symbol or the
3522 parent result. This picks up sibling references, which
3523 cannot be entries. */
3524 if (!sym
->attr
.entry
3525 && sym
->ns
== gfc_current_ns
->parent
3526 && sym
!= gfc_current_ns
->proc_name
3527 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3532 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3538 /* Reject assigning to an external symbol. For initializers, this
3539 was already done before, in resolve_fl_procedure. */
3540 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
3541 && sym
->attr
.proc
!= PROC_MODULE
&& !rvalue
->error
)
3543 gfc_error ("Illegal assignment to external procedure at %L",
3549 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3551 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3552 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3556 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3558 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3563 if (rvalue
->expr_type
== EXPR_NULL
)
3565 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3566 && lvalue
->symtree
->n
.sym
->attr
.data
)
3570 gfc_error ("NULL appears on right-hand side in assignment at %L",
3576 /* This is possibly a typo: x = f() instead of x => f(). */
3578 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3579 gfc_warning (OPT_Wsurprising
,
3580 "POINTER-valued function appears on right-hand side of "
3581 "assignment at %L", &rvalue
->where
);
3583 /* Check size of array assignments. */
3584 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3585 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3588 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3589 && lvalue
->symtree
->n
.sym
->attr
.data
3590 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3591 "initialize non-integer variable %qs",
3592 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3594 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3595 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3596 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3600 /* Handle the case of a BOZ literal on the RHS. */
3601 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3604 if (warn_surprising
)
3605 gfc_warning (OPT_Wsurprising
,
3606 "BOZ literal at %L is bitwise transferred "
3607 "non-integer symbol %qs", &rvalue
->where
,
3608 lvalue
->symtree
->n
.sym
->name
);
3609 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3611 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3613 if (rc
== ARITH_UNDERFLOW
)
3614 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3615 ". This check can be disabled with the option "
3616 "%<-fno-range-check%>", &rvalue
->where
);
3617 else if (rc
== ARITH_OVERFLOW
)
3618 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3619 ". This check can be disabled with the option "
3620 "%<-fno-range-check%>", &rvalue
->where
);
3621 else if (rc
== ARITH_NAN
)
3622 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3623 ". This check can be disabled with the option "
3624 "%<-fno-range-check%>", &rvalue
->where
);
3629 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3631 gfc_error ("The assignment to a KIND or LEN component of a "
3632 "parameterized type at %L is not allowed",
3637 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3640 /* Only DATA Statements come here. */
3645 /* Numeric can be converted to any other numeric. And Hollerith can be
3646 converted to any other type. */
3647 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3648 || rvalue
->ts
.type
== BT_HOLLERITH
)
3651 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3654 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3655 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3656 "conversion of %s to %s", where
,
3657 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3662 /* Assignment is the only case where character variables of different
3663 kind values can be converted into one another. */
3664 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3666 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3667 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3675 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3679 /* Check that a pointer assignment is OK. We first check lvalue, and
3680 we only check rvalue if it's not an assignment to NULL() or a
3681 NULLIFY statement. */
3684 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
,
3685 bool suppress_type_test
)
3687 symbol_attribute attr
, lhs_attr
;
3689 bool is_pure
, is_implicit_pure
, rank_remap
;
3692 lhs_attr
= gfc_expr_attr (lvalue
);
3693 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3695 gfc_error ("Pointer assignment target is not a POINTER at %L",
3700 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3701 && !lhs_attr
.proc_pointer
)
3703 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3704 "l-value since it is a procedure",
3705 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3709 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3712 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3714 if (ref
->type
== REF_COMPONENT
)
3715 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3717 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3721 if (ref
->u
.ar
.type
== AR_FULL
)
3724 if (ref
->u
.ar
.type
!= AR_SECTION
)
3726 gfc_error ("Expected bounds specification for %qs at %L",
3727 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3731 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3732 "for %qs in pointer assignment at %L",
3733 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3736 /* When bounds are given, all lbounds are necessary and either all
3737 or none of the upper bounds; no strides are allowed. If the
3738 upper bounds are present, we may do rank remapping. */
3739 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3741 if (!ref
->u
.ar
.start
[dim
]
3742 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3744 gfc_error ("Lower bound has to be present at %L",
3748 if (ref
->u
.ar
.stride
[dim
])
3750 gfc_error ("Stride must not be present at %L",
3756 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3759 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3760 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3762 gfc_error ("Either all or none of the upper bounds"
3763 " must be specified at %L", &lvalue
->where
);
3771 is_pure
= gfc_pure (NULL
);
3772 is_implicit_pure
= gfc_implicit_pure (NULL
);
3774 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3775 kind, etc for lvalue and rvalue must match, and rvalue must be a
3776 pure variable if we're in a pure function. */
3777 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3780 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3781 if (lvalue
->expr_type
== EXPR_VARIABLE
3782 && gfc_is_coindexed (lvalue
))
3785 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3786 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3788 gfc_error ("Pointer object at %L shall not have a coindex",
3794 /* Checks on rvalue for procedure pointer assignments. */
3799 gfc_component
*comp1
, *comp2
;
3802 attr
= gfc_expr_attr (rvalue
);
3803 if (!((rvalue
->expr_type
== EXPR_NULL
)
3804 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3805 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3806 || (rvalue
->expr_type
== EXPR_VARIABLE
3807 && attr
.flavor
== FL_PROCEDURE
)))
3809 gfc_error ("Invalid procedure pointer assignment at %L",
3814 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3816 /* Check for intrinsics. */
3817 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3818 if (!sym
->attr
.intrinsic
3819 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3820 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3822 sym
->attr
.intrinsic
= 1;
3823 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3824 attr
= gfc_expr_attr (rvalue
);
3826 /* Check for result of embracing function. */
3827 if (sym
->attr
.function
&& sym
->result
== sym
)
3831 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3832 if (sym
== ns
->proc_name
)
3834 gfc_error ("Function result %qs is invalid as proc-target "
3835 "in procedure pointer assignment at %L",
3836 sym
->name
, &rvalue
->where
);
3843 gfc_error ("Abstract interface %qs is invalid "
3844 "in procedure pointer assignment at %L",
3845 rvalue
->symtree
->name
, &rvalue
->where
);
3848 /* Check for F08:C729. */
3849 if (attr
.flavor
== FL_PROCEDURE
)
3851 if (attr
.proc
== PROC_ST_FUNCTION
)
3853 gfc_error ("Statement function %qs is invalid "
3854 "in procedure pointer assignment at %L",
3855 rvalue
->symtree
->name
, &rvalue
->where
);
3858 if (attr
.proc
== PROC_INTERNAL
&&
3859 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3860 "is invalid in procedure pointer assignment "
3861 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3863 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3864 attr
.subroutine
) == 0)
3866 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3867 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3871 /* Check for F08:C730. */
3872 if (attr
.elemental
&& !attr
.intrinsic
)
3874 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3875 "in procedure pointer assignment at %L",
3876 rvalue
->symtree
->name
, &rvalue
->where
);
3880 /* Ensure that the calling convention is the same. As other attributes
3881 such as DLLEXPORT may differ, one explicitly only tests for the
3882 calling conventions. */
3883 if (rvalue
->expr_type
== EXPR_VARIABLE
3884 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3885 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3887 symbol_attribute calls
;
3890 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3891 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3892 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3894 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3895 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3897 gfc_error ("Mismatch in the procedure pointer assignment "
3898 "at %L: mismatch in the calling convention",
3904 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3906 s1
= comp1
->ts
.interface
;
3909 s1
= lvalue
->symtree
->n
.sym
;
3910 if (s1
->ts
.interface
)
3911 s1
= s1
->ts
.interface
;
3914 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3917 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3919 s2
= comp2
->ts
.interface
->result
;
3924 s2
= comp2
->ts
.interface
;
3928 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3930 if (rvalue
->value
.function
.esym
)
3931 s2
= rvalue
->value
.function
.esym
->result
;
3933 s2
= rvalue
->symtree
->n
.sym
->result
;
3939 s2
= rvalue
->symtree
->n
.sym
;
3943 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3944 s2
= s2
->ts
.interface
;
3946 /* Special check for the case of absent interface on the lvalue.
3947 * All other interface checks are done below. */
3948 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3950 gfc_error ("Interface mismatch in procedure pointer assignment "
3951 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
3955 /* F08:7.2.2.4 (4) */
3956 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3960 gfc_error ("Explicit interface required for component %qs at %L: %s",
3961 comp1
->name
, &lvalue
->where
, err
);
3964 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
3966 gfc_error ("Explicit interface required for %qs at %L: %s",
3967 s1
->name
, &lvalue
->where
, err
);
3971 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3975 gfc_error ("Explicit interface required for component %qs at %L: %s",
3976 comp2
->name
, &rvalue
->where
, err
);
3979 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
3981 gfc_error ("Explicit interface required for %qs at %L: %s",
3982 s2
->name
, &rvalue
->where
, err
);
3987 if (s1
== s2
|| !s1
|| !s2
)
3990 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3991 err
, sizeof(err
), NULL
, NULL
))
3993 gfc_error ("Interface mismatch in procedure pointer assignment "
3994 "at %L: %s", &rvalue
->where
, err
);
3998 /* Check F2008Cor2, C729. */
3999 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
4000 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
4002 gfc_error ("Procedure pointer target %qs at %L must be either an "
4003 "intrinsic, host or use associated, referenced or have "
4004 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
4012 /* A non-proc pointer cannot point to a constant. */
4013 if (rvalue
->expr_type
== EXPR_CONSTANT
)
4015 gfc_error_now ("Pointer assignment target cannot be a constant at %L",
4021 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
4023 /* Check for F03:C717. */
4024 if (UNLIMITED_POLY (rvalue
)
4025 && !(UNLIMITED_POLY (lvalue
)
4026 || (lvalue
->ts
.type
== BT_DERIVED
4027 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
4028 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
4029 gfc_error ("Data-pointer-object at %L must be unlimited "
4030 "polymorphic, or of a type with the BIND or SEQUENCE "
4031 "attribute, to be compatible with an unlimited "
4032 "polymorphic target", &lvalue
->where
);
4033 else if (!suppress_type_test
)
4034 gfc_error ("Different types in pointer assignment at %L; "
4035 "attempted assignment of %s to %s", &lvalue
->where
,
4036 gfc_typename (&rvalue
->ts
),
4037 gfc_typename (&lvalue
->ts
));
4041 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
4043 gfc_error ("Different kind type parameters in pointer "
4044 "assignment at %L", &lvalue
->where
);
4048 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4050 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4054 /* Make sure the vtab is present. */
4055 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4056 gfc_find_vtab (&rvalue
->ts
);
4058 /* Check rank remapping. */
4063 /* If this can be determined, check that the target must be at least as
4064 large as the pointer assigned to it is. */
4065 if (gfc_array_size (lvalue
, &lsize
)
4066 && gfc_array_size (rvalue
, &rsize
)
4067 && mpz_cmp (rsize
, lsize
) < 0)
4069 gfc_error ("Rank remapping target is smaller than size of the"
4070 " pointer (%ld < %ld) at %L",
4071 mpz_get_si (rsize
), mpz_get_si (lsize
),
4076 /* The target must be either rank one or it must be simply contiguous
4077 and F2008 must be allowed. */
4078 if (rvalue
->rank
!= 1)
4080 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4082 gfc_error ("Rank remapping target must be rank 1 or"
4083 " simply contiguous at %L", &rvalue
->where
);
4086 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4087 "rank 1 at %L", &rvalue
->where
))
4092 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4093 if (rvalue
->expr_type
== EXPR_NULL
)
4096 if (lvalue
->ts
.type
== BT_CHARACTER
)
4098 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4103 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4104 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4106 attr
= gfc_expr_attr (rvalue
);
4108 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4110 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4111 to caf_get. Map this to the same error message as below when it is
4112 still a variable expression. */
4113 if (rvalue
->value
.function
.isym
4114 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4115 /* The test above might need to be extend when F08, Note 5.4 has to be
4116 interpreted in the way that target and pointer with the same coindex
4118 gfc_error ("Data target at %L shall not have a coindex",
4121 gfc_error ("Target expression in pointer assignment "
4122 "at %L must deliver a pointer result",
4127 if (!attr
.target
&& !attr
.pointer
)
4129 gfc_error ("Pointer assignment target is neither TARGET "
4130 "nor POINTER at %L", &rvalue
->where
);
4134 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4136 gfc_error ("Bad target in pointer assignment in PURE "
4137 "procedure at %L", &rvalue
->where
);
4140 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4141 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4143 if (gfc_has_vector_index (rvalue
))
4145 gfc_error ("Pointer assignment with vector subscript "
4146 "on rhs at %L", &rvalue
->where
);
4150 if (attr
.is_protected
&& attr
.use_assoc
4151 && !(attr
.pointer
|| attr
.proc_pointer
))
4153 gfc_error ("Pointer assignment target has PROTECTED "
4154 "attribute at %L", &rvalue
->where
);
4158 /* F2008, C725. For PURE also C1283. */
4159 if (rvalue
->expr_type
== EXPR_VARIABLE
4160 && gfc_is_coindexed (rvalue
))
4163 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4164 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4166 gfc_error ("Data target at %L shall not have a coindex",
4172 /* Warn for assignments of contiguous pointers to targets which is not
4173 contiguous. Be lenient in the definition of what counts as
4176 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
4177 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4178 "non-contiguous target at %L", &rvalue
->where
);
4180 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4181 if (warn_target_lifetime
4182 && rvalue
->expr_type
== EXPR_VARIABLE
4183 && !rvalue
->symtree
->n
.sym
->attr
.save
4184 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4185 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4186 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4187 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4188 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4193 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4194 || lvalue
->symtree
->n
.sym
->attr
.result
4195 || lvalue
->symtree
->n
.sym
->attr
.function
4196 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4197 && lvalue
->symtree
->n
.sym
->ns
4198 != rvalue
->symtree
->n
.sym
->ns
)
4199 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4200 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4202 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4203 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4204 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4205 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4206 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4208 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4215 gfc_warning (OPT_Wtarget_lifetime
,
4216 "Pointer at %L in pointer assignment might outlive the "
4217 "pointer target", &lvalue
->where
);
4224 /* Relative of gfc_check_assign() except that the lvalue is a single
4225 symbol. Used for initialization assignments. */
4228 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4232 bool pointer
, proc_pointer
;
4234 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4236 lvalue
.expr_type
= EXPR_VARIABLE
;
4237 lvalue
.ts
= sym
->ts
;
4239 lvalue
.rank
= sym
->as
->rank
;
4240 lvalue
.symtree
= XCNEW (gfc_symtree
);
4241 lvalue
.symtree
->n
.sym
= sym
;
4242 lvalue
.where
= sym
->declared_at
;
4246 lvalue
.ref
= gfc_get_ref ();
4247 lvalue
.ref
->type
= REF_COMPONENT
;
4248 lvalue
.ref
->u
.c
.component
= comp
;
4249 lvalue
.ref
->u
.c
.sym
= sym
;
4250 lvalue
.ts
= comp
->ts
;
4251 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4252 lvalue
.where
= comp
->loc
;
4253 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4254 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4255 proc_pointer
= comp
->attr
.proc_pointer
;
4259 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4260 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4261 proc_pointer
= sym
->attr
.proc_pointer
;
4264 if (pointer
|| proc_pointer
)
4265 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
4268 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4269 into an array constructor, we should check if it can be reduced
4270 as an initialization expression. */
4271 if (rvalue
->expr_type
== EXPR_FUNCTION
4272 && rvalue
->value
.function
.isym
4273 && (rvalue
->value
.function
.isym
->conversion
== 1))
4274 gfc_check_init_expr (rvalue
);
4276 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4279 free (lvalue
.symtree
);
4285 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4287 /* F08:C461. Additional checks for pointer initialization. */
4288 symbol_attribute attr
;
4289 attr
= gfc_expr_attr (rvalue
);
4290 if (attr
.allocatable
)
4292 gfc_error ("Pointer initialization target at %L "
4293 "must not be ALLOCATABLE", &rvalue
->where
);
4296 if (!attr
.target
|| attr
.pointer
)
4298 gfc_error ("Pointer initialization target at %L "
4299 "must have the TARGET attribute", &rvalue
->where
);
4303 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4304 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4305 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4307 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4308 attr
.save
= SAVE_IMPLICIT
;
4313 gfc_error ("Pointer initialization target at %L "
4314 "must have the SAVE attribute", &rvalue
->where
);
4319 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4321 /* F08:C1220. Additional checks for procedure pointer initialization. */
4322 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4323 if (attr
.proc_pointer
)
4325 gfc_error ("Procedure pointer initialization target at %L "
4326 "may not be a procedure pointer", &rvalue
->where
);
4334 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4335 * require that an expression be built. */
4338 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4340 return gfc_build_init_expr (ts
, where
, false);
4343 /* Build an initializer for a local integer, real, complex, logical, or
4344 character variable, based on the command line flags finit-local-zero,
4345 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4346 With force, an initializer is ALWAYS generated. */
4349 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4351 gfc_expr
*init_expr
;
4353 /* Try to build an initializer expression. */
4354 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4356 /* If we want to force generation, make sure we default to zero. */
4357 gfc_init_local_real init_real
= flag_init_real
;
4358 int init_logical
= gfc_option
.flag_init_logical
;
4361 if (init_real
== GFC_INIT_REAL_OFF
)
4362 init_real
= GFC_INIT_REAL_ZERO
;
4363 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4364 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4367 /* We will only initialize integers, reals, complex, logicals, and
4368 characters, and only if the corresponding command-line flags
4369 were set. Otherwise, we free init_expr and return null. */
4373 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4374 mpz_set_si (init_expr
->value
.integer
,
4375 gfc_option
.flag_init_integer_value
);
4378 gfc_free_expr (init_expr
);
4386 case GFC_INIT_REAL_SNAN
:
4387 init_expr
->is_snan
= 1;
4389 case GFC_INIT_REAL_NAN
:
4390 mpfr_set_nan (init_expr
->value
.real
);
4393 case GFC_INIT_REAL_INF
:
4394 mpfr_set_inf (init_expr
->value
.real
, 1);
4397 case GFC_INIT_REAL_NEG_INF
:
4398 mpfr_set_inf (init_expr
->value
.real
, -1);
4401 case GFC_INIT_REAL_ZERO
:
4402 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4406 gfc_free_expr (init_expr
);
4415 case GFC_INIT_REAL_SNAN
:
4416 init_expr
->is_snan
= 1;
4418 case GFC_INIT_REAL_NAN
:
4419 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4420 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4423 case GFC_INIT_REAL_INF
:
4424 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4425 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4428 case GFC_INIT_REAL_NEG_INF
:
4429 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4430 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4433 case GFC_INIT_REAL_ZERO
:
4434 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4438 gfc_free_expr (init_expr
);
4445 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4446 init_expr
->value
.logical
= 0;
4447 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4448 init_expr
->value
.logical
= 1;
4451 gfc_free_expr (init_expr
);
4457 /* For characters, the length must be constant in order to
4458 create a default initializer. */
4459 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4461 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4463 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4464 init_expr
->value
.character
.length
= char_len
;
4465 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4466 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4467 init_expr
->value
.character
.string
[i
]
4468 = (unsigned char) gfc_option
.flag_init_character_value
;
4472 gfc_free_expr (init_expr
);
4476 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4477 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4479 gfc_actual_arglist
*arg
;
4480 init_expr
= gfc_get_expr ();
4481 init_expr
->where
= *where
;
4482 init_expr
->ts
= *ts
;
4483 init_expr
->expr_type
= EXPR_FUNCTION
;
4484 init_expr
->value
.function
.isym
=
4485 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4486 init_expr
->value
.function
.name
= "repeat";
4487 arg
= gfc_get_actual_arglist ();
4488 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4489 arg
->expr
->value
.character
.string
[0] =
4490 gfc_option
.flag_init_character_value
;
4491 arg
->next
= gfc_get_actual_arglist ();
4492 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4493 init_expr
->value
.function
.actual
= arg
;
4498 gfc_free_expr (init_expr
);
4505 /* Apply an initialization expression to a typespec. Can be used for symbols or
4506 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4507 combined with some effort. */
4510 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4512 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4515 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
4516 && ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
)
4518 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4520 if (init
->expr_type
== EXPR_CONSTANT
)
4521 gfc_set_constant_character_len (len
, init
, -1);
4523 && init
->ts
.type
== BT_CHARACTER
4524 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4525 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4526 init
->ts
.u
.cl
->length
->value
.integer
))
4528 gfc_constructor
*ctor
;
4529 ctor
= gfc_constructor_first (init
->value
.constructor
);
4533 bool has_ts
= (init
->ts
.u
.cl
4534 && init
->ts
.u
.cl
->length_from_typespec
);
4536 /* Remember the length of the first element for checking
4537 that all elements *in the constructor* have the same
4538 length. This need not be the length of the LHS! */
4539 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4540 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4541 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4543 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4544 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4546 gfc_set_constant_character_len (len
, ctor
->expr
,
4547 has_ts
? -1 : first_len
);
4548 if (!ctor
->expr
->ts
.u
.cl
)
4550 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4552 ctor
->expr
->ts
.u
.cl
->length
4553 = gfc_copy_expr (ts
->u
.cl
->length
);
4561 /* Check whether an expression is a structure constructor and whether it has
4562 other values than NULL. */
4565 is_non_empty_structure_constructor (gfc_expr
* e
)
4567 if (e
->expr_type
!= EXPR_STRUCTURE
)
4570 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4573 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4575 cons
= gfc_constructor_next (cons
);
4581 /* Check for default initializer; sym->value is not enough
4582 as it is also set for EXPR_NULL of allocatables. */
4585 gfc_has_default_initializer (gfc_symbol
*der
)
4589 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4590 for (c
= der
->components
; c
; c
= c
->next
)
4591 if (gfc_bt_struct (c
->ts
.type
))
4593 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4594 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4596 && is_non_empty_structure_constructor (c
->initializer
))
4597 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4599 if (c
->attr
.pointer
&& c
->initializer
)
4613 Generate an initializer expression which initializes the entirety of a union.
4614 A normal structure constructor is insufficient without undue effort, because
4615 components of maps may be oddly aligned/overlapped. (For example if a
4616 character is initialized from one map overtop a real from the other, only one
4617 byte of the real is actually initialized.) Unfortunately we don't know the
4618 size of the union right now, so we can't generate a proper initializer, but
4619 we use a NULL expr as a placeholder and do the right thing later in
4620 gfc_trans_subcomponent_assign.
4623 generate_union_initializer (gfc_component
*un
)
4625 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4628 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4629 placeholder
->ts
= un
->ts
;
4634 /* Get the user-specified initializer for a union, if any. This means the user
4635 has said to initialize component(s) of a map. For simplicity's sake we
4636 only allow the user to initialize the first map. We don't have to worry
4637 about overlapping initializers as they are released early in resolution (see
4638 resolve_fl_struct). */
4641 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4644 gfc_expr
*init
=NULL
;
4646 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4649 for (map
= union_type
->components
; map
; map
= map
->next
)
4651 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4653 init
= gfc_default_initializer (&map
->ts
);
4667 class_allocatable (gfc_component
*comp
)
4669 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4670 && CLASS_DATA (comp
)->attr
.allocatable
;
4674 class_pointer (gfc_component
*comp
)
4676 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4677 && CLASS_DATA (comp
)->attr
.pointer
;
4681 comp_allocatable (gfc_component
*comp
)
4683 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4687 comp_pointer (gfc_component
*comp
)
4689 return comp
->attr
.pointer
4690 || comp
->attr
.pointer
4691 || comp
->attr
.proc_pointer
4692 || comp
->attr
.class_pointer
4693 || class_pointer (comp
);
4696 /* Fetch or generate an initializer for the given component.
4697 Only generate an initializer if generate is true. */
4700 component_initializer (gfc_component
*c
, bool generate
)
4702 gfc_expr
*init
= NULL
;
4704 /* Allocatable components always get EXPR_NULL.
4705 Pointer components are only initialized when generating, and only if they
4706 do not already have an initializer. */
4707 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4709 init
= gfc_get_null_expr (&c
->loc
);
4714 /* See if we can find the initializer immediately. */
4715 if (c
->initializer
|| !generate
)
4716 return c
->initializer
;
4718 /* Recursively handle derived type components. */
4719 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4720 init
= gfc_generate_initializer (&c
->ts
, true);
4722 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4724 gfc_component
*map
= NULL
;
4725 gfc_constructor
*ctor
;
4726 gfc_expr
*user_init
;
4728 /* If we don't have a user initializer and we aren't generating one, this
4729 union has no initializer. */
4730 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4731 if (!user_init
&& !generate
)
4734 /* Otherwise use a structure constructor. */
4735 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4739 /* If we are to generate an initializer for the union, add a constructor
4740 which initializes the whole union first. */
4743 ctor
= gfc_constructor_get ();
4744 ctor
->expr
= generate_union_initializer (c
);
4745 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4748 /* If we found an initializer in one of our maps, apply it. Note this
4749 is applied _after_ the entire-union initializer above if any. */
4752 ctor
= gfc_constructor_get ();
4753 ctor
->expr
= user_init
;
4754 ctor
->n
.component
= map
;
4755 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4759 /* Treat simple components like locals. */
4762 /* We MUST give an initializer, so force generation. */
4763 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4764 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4771 /* Get an expression for a default initializer of a derived type. */
4774 gfc_default_initializer (gfc_typespec
*ts
)
4776 return gfc_generate_initializer (ts
, false);
4779 /* Generate an initializer expression for an iso_c_binding type
4780 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
4783 generate_isocbinding_initializer (gfc_symbol
*derived
)
4785 /* The initializers have already been built into the c_null_[fun]ptr symbols
4786 from gen_special_c_interop_ptr. */
4787 gfc_symtree
*npsym
= NULL
;
4788 if (0 == strcmp (derived
->name
, "c_ptr"))
4789 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
4790 else if (0 == strcmp (derived
->name
, "c_funptr"))
4791 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
4793 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
4794 " type, expected %<c_ptr%> or %<c_funptr%>");
4797 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
4798 init
->symtree
= npsym
;
4799 init
->ts
.is_iso_c
= true;
4806 /* Get or generate an expression for a default initializer of a derived type.
4807 If -finit-derived is specified, generate default initialization expressions
4808 for components that lack them when generate is set. */
4811 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4813 gfc_expr
*init
, *tmp
;
4814 gfc_component
*comp
;
4816 generate
= flag_init_derived
&& generate
;
4818 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
4819 return generate_isocbinding_initializer (ts
->u
.derived
);
4821 /* See if we have a default initializer in this, but not in nested
4822 types (otherwise we could use gfc_has_default_initializer()).
4823 We don't need to check if we are going to generate them. */
4824 comp
= ts
->u
.derived
->components
;
4827 for (; comp
; comp
= comp
->next
)
4828 if (comp
->initializer
|| comp_allocatable (comp
))
4835 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4836 &ts
->u
.derived
->declared_at
);
4839 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4841 gfc_constructor
*ctor
= gfc_constructor_get();
4843 /* Fetch or generate an initializer for the component. */
4844 tmp
= component_initializer (comp
, generate
);
4847 /* Save the component ref for STRUCTUREs and UNIONs. */
4848 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4849 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4850 ctor
->n
.component
= comp
;
4852 /* If the initializer was not generated, we need a copy. */
4853 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4854 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
4855 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4858 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
4864 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4871 /* Given a symbol, create an expression node with that symbol as a
4872 variable. If the symbol is array valued, setup a reference of the
4876 gfc_get_variable_expr (gfc_symtree
*var
)
4880 e
= gfc_get_expr ();
4881 e
->expr_type
= EXPR_VARIABLE
;
4883 e
->ts
= var
->n
.sym
->ts
;
4885 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4886 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4887 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4888 && CLASS_DATA (var
->n
.sym
)->as
)))
4890 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4891 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4892 e
->ref
= gfc_get_ref ();
4893 e
->ref
->type
= REF_ARRAY
;
4894 e
->ref
->u
.ar
.type
= AR_FULL
;
4895 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4896 ? CLASS_DATA (var
->n
.sym
)->as
4904 /* Adds a full array reference to an expression, as needed. */
4907 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4910 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4915 ref
->next
= gfc_get_ref ();
4920 e
->ref
= gfc_get_ref ();
4923 ref
->type
= REF_ARRAY
;
4924 ref
->u
.ar
.type
= AR_FULL
;
4925 ref
->u
.ar
.dimen
= e
->rank
;
4926 ref
->u
.ar
.where
= e
->where
;
4932 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4936 lval
= gfc_get_expr ();
4937 lval
->expr_type
= EXPR_VARIABLE
;
4938 lval
->where
= sym
->declared_at
;
4940 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4942 /* It will always be a full array. */
4943 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4944 lval
->rank
= as
? as
->rank
: 0;
4946 gfc_add_full_array_ref (lval
, as
);
4951 /* Returns the array_spec of a full array expression. A NULL is
4952 returned otherwise. */
4954 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4959 if (expr
->rank
== 0)
4962 /* Follow any component references. */
4963 if (expr
->expr_type
== EXPR_VARIABLE
4964 || expr
->expr_type
== EXPR_CONSTANT
)
4967 as
= expr
->symtree
->n
.sym
->as
;
4971 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4976 as
= ref
->u
.c
.component
->as
;
4985 switch (ref
->u
.ar
.type
)
5008 /* General expression traversal function. */
5011 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
5012 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
5017 gfc_actual_arglist
*args
;
5024 if ((*func
) (expr
, sym
, &f
))
5027 if (expr
->ts
.type
== BT_CHARACTER
5029 && expr
->ts
.u
.cl
->length
5030 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
5031 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
5034 switch (expr
->expr_type
)
5039 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
5041 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5049 case EXPR_SUBSTRING
:
5052 case EXPR_STRUCTURE
:
5054 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5055 c
; c
= gfc_constructor_next (c
))
5057 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5061 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5063 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5065 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5067 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5074 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5076 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5092 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5094 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5096 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5098 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5104 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5106 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5111 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5112 && ref
->u
.c
.component
->ts
.u
.cl
5113 && ref
->u
.c
.component
->ts
.u
.cl
->length
5114 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5116 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5120 if (ref
->u
.c
.component
->as
)
5121 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5122 + ref
->u
.c
.component
->as
->corank
; i
++)
5124 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5127 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5144 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5147 expr_set_symbols_referenced (gfc_expr
*expr
,
5148 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5149 int *f ATTRIBUTE_UNUSED
)
5151 if (expr
->expr_type
!= EXPR_VARIABLE
)
5153 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5158 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5160 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5164 /* Determine if an expression is a procedure pointer component and return
5165 the component in that case. Otherwise return NULL. */
5168 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5172 if (!expr
|| !expr
->ref
)
5179 if (ref
->type
== REF_COMPONENT
5180 && ref
->u
.c
.component
->attr
.proc_pointer
)
5181 return ref
->u
.c
.component
;
5187 /* Determine if an expression is a procedure pointer component. */
5190 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5192 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5196 /* Determine if an expression is a function with an allocatable class scalar
5199 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5201 if (expr
->expr_type
== EXPR_FUNCTION
5202 && expr
->value
.function
.esym
5203 && expr
->value
.function
.esym
->result
5204 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5205 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5206 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5213 /* Determine if an expression is a function with an allocatable class array
5216 gfc_is_class_array_function (gfc_expr
*expr
)
5218 if (expr
->expr_type
== EXPR_FUNCTION
5219 && expr
->value
.function
.esym
5220 && expr
->value
.function
.esym
->result
5221 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5222 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5223 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5224 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5231 /* Walk an expression tree and check each variable encountered for being typed.
5232 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5233 mode as is a basic arithmetic expression using those; this is for things in
5236 INTEGER :: arr(n), n
5237 INTEGER :: arr(n + 1), n
5239 The namespace is needed for IMPLICIT typing. */
5241 static gfc_namespace
* check_typed_ns
;
5244 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5245 int* f ATTRIBUTE_UNUSED
)
5249 if (e
->expr_type
!= EXPR_VARIABLE
)
5252 gcc_assert (e
->symtree
);
5253 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5260 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5264 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5268 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5269 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5271 if (e
->expr_type
== EXPR_OP
)
5275 gcc_assert (e
->value
.op
.op1
);
5276 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5278 if (t
&& e
->value
.op
.op2
)
5279 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5285 /* Otherwise, walk the expression and do it strictly. */
5286 check_typed_ns
= ns
;
5287 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5289 return error_found
? false : true;
5293 /* This function returns true if it contains any references to PDT KIND
5294 or LEN parameters. */
5297 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5298 int* f ATTRIBUTE_UNUSED
)
5300 if (e
->expr_type
!= EXPR_VARIABLE
)
5303 gcc_assert (e
->symtree
);
5304 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5305 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5313 gfc_derived_parameter_expr (gfc_expr
*e
)
5315 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5319 /* This function returns the overall type of a type parameter spec list.
5320 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5321 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5322 unless derived is not NULL. In this latter case, all the LEN parameters
5323 must be either assumed or deferred for the return argument to be set to
5324 anything other than SPEC_EXPLICIT. */
5327 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5329 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5331 bool seen_assumed
= false;
5332 bool seen_deferred
= false;
5334 if (derived
== NULL
)
5336 for (; param_list
; param_list
= param_list
->next
)
5337 if (param_list
->spec_type
== SPEC_ASSUMED
5338 || param_list
->spec_type
== SPEC_DEFERRED
)
5339 return param_list
->spec_type
;
5343 for (; param_list
; param_list
= param_list
->next
)
5345 c
= gfc_find_component (derived
, param_list
->name
,
5347 gcc_assert (c
!= NULL
);
5348 if (c
->attr
.pdt_kind
)
5350 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5351 return SPEC_EXPLICIT
;
5352 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5353 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5354 if (seen_assumed
&& seen_deferred
)
5355 return SPEC_EXPLICIT
;
5357 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5364 gfc_ref_this_image (gfc_ref
*ref
)
5368 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5370 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5371 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5378 gfc_find_team_co (gfc_expr
*e
)
5382 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5383 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5384 return ref
->u
.ar
.team
;
5386 if (e
->value
.function
.actual
->expr
)
5387 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5389 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5390 return ref
->u
.ar
.team
;
5396 gfc_find_stat_co (gfc_expr
*e
)
5400 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5401 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5402 return ref
->u
.ar
.stat
;
5404 if (e
->value
.function
.actual
->expr
)
5405 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5407 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5408 return ref
->u
.ar
.stat
;
5414 gfc_is_coindexed (gfc_expr
*e
)
5418 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5419 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5420 return !gfc_ref_this_image (ref
);
5426 /* Coarrays are variables with a corank but not being coindexed. However, also
5427 the following is a coarray: A subobject of a coarray is a coarray if it does
5428 not have any cosubscripts, vector subscripts, allocatable component
5429 selection, or pointer component selection. (F2008, 2.4.7) */
5432 gfc_is_coarray (gfc_expr
*e
)
5436 gfc_component
*comp
;
5441 if (e
->expr_type
!= EXPR_VARIABLE
)
5445 sym
= e
->symtree
->n
.sym
;
5447 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5448 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5450 coarray
= sym
->attr
.codimension
;
5452 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5456 comp
= ref
->u
.c
.component
;
5457 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5458 && (CLASS_DATA (comp
)->attr
.class_pointer
5459 || CLASS_DATA (comp
)->attr
.allocatable
))
5462 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5464 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5467 coarray
= comp
->attr
.codimension
;
5475 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5481 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5482 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5494 return coarray
&& !coindexed
;
5499 gfc_get_corank (gfc_expr
*e
)
5504 if (!gfc_is_coarray (e
))
5507 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5508 corank
= e
->ts
.u
.derived
->components
->as
5509 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5511 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5513 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5515 if (ref
->type
== REF_ARRAY
)
5516 corank
= ref
->u
.ar
.as
->corank
;
5517 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5524 /* Check whether the expression has an ultimate allocatable component.
5525 Being itself allocatable does not count. */
5527 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5529 gfc_ref
*ref
, *last
= NULL
;
5531 if (e
->expr_type
!= EXPR_VARIABLE
)
5534 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5535 if (ref
->type
== REF_COMPONENT
)
5538 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5539 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5540 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5541 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5545 if (e
->ts
.type
== BT_CLASS
)
5546 return CLASS_DATA (e
)->attr
.alloc_comp
;
5547 else if (e
->ts
.type
== BT_DERIVED
)
5548 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5554 /* Check whether the expression has an pointer component.
5555 Being itself a pointer does not count. */
5557 gfc_has_ultimate_pointer (gfc_expr
*e
)
5559 gfc_ref
*ref
, *last
= NULL
;
5561 if (e
->expr_type
!= EXPR_VARIABLE
)
5564 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5565 if (ref
->type
== REF_COMPONENT
)
5568 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5569 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5570 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5571 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5575 if (e
->ts
.type
== BT_CLASS
)
5576 return CLASS_DATA (e
)->attr
.pointer_comp
;
5577 else if (e
->ts
.type
== BT_DERIVED
)
5578 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5584 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5585 Note: A scalar is not regarded as "simply contiguous" by the standard.
5586 if bool is not strict, some further checks are done - for instance,
5587 a "(::1)" is accepted. */
5590 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5594 gfc_array_ref
*ar
= NULL
;
5595 gfc_ref
*ref
, *part_ref
= NULL
;
5598 if (expr
->expr_type
== EXPR_FUNCTION
)
5600 if (expr
->value
.function
.esym
)
5601 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5604 /* Type-bound procedures. */
5605 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5606 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5610 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5611 if (r
->type
== REF_COMPONENT
)
5614 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5615 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5618 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5621 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5624 if (!permit_element
&& expr
->rank
== 0)
5627 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5630 return false; /* Array shall be last part-ref. */
5632 if (ref
->type
== REF_COMPONENT
)
5634 else if (ref
->type
== REF_SUBSTRING
)
5636 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5640 sym
= expr
->symtree
->n
.sym
;
5641 if (expr
->ts
.type
!= BT_CLASS
5643 && !part_ref
->u
.c
.component
->attr
.contiguous
5644 && part_ref
->u
.c
.component
->attr
.pointer
)
5646 && !sym
->attr
.contiguous
5647 && (sym
->attr
.pointer
5648 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5649 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5652 if (!ar
|| ar
->type
== AR_FULL
)
5655 gcc_assert (ar
->type
== AR_SECTION
);
5657 /* Check for simply contiguous array */
5659 for (i
= 0; i
< ar
->dimen
; i
++)
5661 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5664 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5670 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5673 /* If the previous section was not contiguous, that's an error,
5674 unless we have effective only one element and checking is not
5676 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5677 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5678 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5679 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5680 ar
->end
[i
]->value
.integer
) != 0))
5683 /* Following the standard, "(::1)" or - if known at compile time -
5684 "(lbound:ubound)" are not simply contiguous; if strict
5685 is false, they are regarded as simply contiguous. */
5686 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5687 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5688 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5692 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5693 || !ar
->as
->lower
[i
]
5694 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5695 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5696 ar
->as
->lower
[i
]->value
.integer
) != 0))
5700 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5701 || !ar
->as
->upper
[i
]
5702 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5703 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5704 ar
->as
->upper
[i
]->value
.integer
) != 0))
5711 /* Return true if the expression is guaranteed to be non-contiguous,
5712 false if we cannot prove anything. It is probably best to call
5713 this after gfc_is_simply_contiguous. If neither of them returns
5714 true, we cannot say (at compile-time). */
5717 gfc_is_not_contiguous (gfc_expr
*array
)
5720 gfc_array_ref
*ar
= NULL
;
5722 bool previous_incomplete
;
5724 for (ref
= array
->ref
; ref
; ref
= ref
->next
)
5726 /* Array-ref shall be last ref. */
5731 if (ref
->type
== REF_ARRAY
)
5735 if (ar
== NULL
|| ar
->type
!= AR_SECTION
)
5738 previous_incomplete
= false;
5740 /* Check if we can prove that the array is not contiguous. */
5742 for (i
= 0; i
< ar
->dimen
; i
++)
5744 mpz_t arr_size
, ref_size
;
5746 if (gfc_ref_dimen_size (ar
, i
, &ref_size
, NULL
))
5748 if (gfc_dep_difference (ar
->as
->lower
[i
], ar
->as
->upper
[i
], &arr_size
))
5750 /* a(2:4,2:) is known to be non-contiguous, but
5751 a(2:4,i:i) can be contiguous. */
5752 if (previous_incomplete
&& mpz_cmp_si (ref_size
, 1) != 0)
5754 mpz_clear (arr_size
);
5755 mpz_clear (ref_size
);
5758 else if (mpz_cmp (arr_size
, ref_size
) != 0)
5759 previous_incomplete
= true;
5761 mpz_clear (arr_size
);
5764 /* Check for a(::2), i.e. where the stride is not unity.
5765 This is only done if there is more than one element in
5766 the reference along this dimension. */
5768 if (mpz_cmp_ui (ref_size
, 1) > 0 && ar
->type
== AR_SECTION
5769 && ar
->dimen_type
[i
] == DIMEN_RANGE
5770 && ar
->stride
[i
] && ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
5771 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0)
5774 mpz_clear (ref_size
);
5777 /* We didn't find anything definitive. */
5781 /* Build call to an intrinsic procedure. The number of arguments has to be
5782 passed (rather than ending the list with a NULL value) because we may
5783 want to add arguments but with a NULL-expression. */
5786 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5787 locus where
, unsigned numarg
, ...)
5790 gfc_actual_arglist
* atail
;
5791 gfc_intrinsic_sym
* isym
;
5794 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5796 isym
= gfc_intrinsic_function_by_id (id
);
5799 result
= gfc_get_expr ();
5800 result
->expr_type
= EXPR_FUNCTION
;
5801 result
->ts
= isym
->ts
;
5802 result
->where
= where
;
5803 result
->value
.function
.name
= mangled_name
;
5804 result
->value
.function
.isym
= isym
;
5806 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5807 gfc_commit_symbol (result
->symtree
->n
.sym
);
5808 gcc_assert (result
->symtree
5809 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5810 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5811 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5812 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5813 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5814 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5816 va_start (ap
, numarg
);
5818 for (i
= 0; i
< numarg
; ++i
)
5822 atail
->next
= gfc_get_actual_arglist ();
5823 atail
= atail
->next
;
5826 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5828 atail
->expr
= va_arg (ap
, gfc_expr
*);
5836 /* Check if an expression may appear in a variable definition context
5837 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5838 This is called from the various places when resolving
5839 the pieces that make up such a context.
5840 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5841 variables), some checks are not performed.
5843 Optionally, a possible error message can be suppressed if context is NULL
5844 and just the return status (true / false) be requested. */
5847 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5848 bool own_scope
, const char* context
)
5850 gfc_symbol
* sym
= NULL
;
5852 bool check_intentin
;
5854 symbol_attribute attr
;
5858 if (e
->expr_type
== EXPR_VARIABLE
)
5860 gcc_assert (e
->symtree
);
5861 sym
= e
->symtree
->n
.sym
;
5863 else if (e
->expr_type
== EXPR_FUNCTION
)
5865 gcc_assert (e
->symtree
);
5866 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5869 attr
= gfc_expr_attr (e
);
5870 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5872 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5875 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5876 " context (%s) at %L", context
, &e
->where
);
5880 else if (e
->expr_type
!= EXPR_VARIABLE
)
5883 gfc_error ("Non-variable expression in variable definition context (%s)"
5884 " at %L", context
, &e
->where
);
5888 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5891 gfc_error ("Named constant %qs in variable definition context (%s)"
5892 " at %L", sym
->name
, context
, &e
->where
);
5895 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5896 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5897 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5900 gfc_error ("%qs in variable definition context (%s) at %L is not"
5901 " a variable", sym
->name
, context
, &e
->where
);
5905 /* Find out whether the expr is a pointer; this also means following
5906 component references to the last one. */
5907 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5908 if (pointer
&& !is_pointer
)
5911 gfc_error ("Non-POINTER in pointer association context (%s)"
5912 " at %L", context
, &e
->where
);
5916 if (e
->ts
.type
== BT_DERIVED
5917 && e
->ts
.u
.derived
== NULL
)
5920 gfc_error ("Type inaccessible in variable definition context (%s) "
5921 "at %L", context
, &e
->where
);
5928 || (e
->ts
.type
== BT_DERIVED
5929 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5930 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5933 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5934 context
, &e
->where
);
5938 /* TS18508, C702/C203. */
5941 || (e
->ts
.type
== BT_DERIVED
5942 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5943 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5946 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5947 context
, &e
->where
);
5951 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5952 component of sub-component of a pointer; we need to distinguish
5953 assignment to a pointer component from pointer-assignment to a pointer
5954 component. Note that (normal) assignment to procedure pointers is not
5956 check_intentin
= !own_scope
;
5957 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5958 && CLASS_DATA (sym
))
5959 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5960 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5962 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5963 check_intentin
= false;
5964 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5966 ptr_component
= true;
5968 check_intentin
= false;
5971 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5973 if (pointer
&& is_pointer
)
5976 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5977 " association context (%s) at %L",
5978 sym
->name
, context
, &e
->where
);
5981 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5984 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5985 " definition context (%s) at %L",
5986 sym
->name
, context
, &e
->where
);
5991 /* PROTECTED and use-associated. */
5992 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5994 if (pointer
&& is_pointer
)
5997 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
5998 " pointer association context (%s) at %L",
5999 sym
->name
, context
, &e
->where
);
6002 if (!pointer
&& !is_pointer
)
6005 gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
6006 " variable definition context (%s) at %L",
6007 sym
->name
, context
, &e
->where
);
6012 /* Variable not assignable from a PURE procedure but appears in
6013 variable definition context. */
6014 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
6017 gfc_error ("Variable %qs cannot appear in a variable definition"
6018 " context (%s) at %L in PURE procedure",
6019 sym
->name
, context
, &e
->where
);
6023 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
6024 && gfc_impure_variable (sym
))
6029 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
6031 sym
= ns
->proc_name
;
6034 if (sym
->attr
.flavor
== FL_PROCEDURE
)
6036 sym
->attr
.implicit_pure
= 0;
6041 /* Check variable definition context for associate-names. */
6042 if (!pointer
&& sym
->assoc
)
6045 gfc_association_list
* assoc
;
6047 gcc_assert (sym
->assoc
->target
);
6049 /* If this is a SELECT TYPE temporary (the association is used internally
6050 for SELECT TYPE), silently go over to the target. */
6051 if (sym
->attr
.select_type_temporary
)
6053 gfc_expr
* t
= sym
->assoc
->target
;
6055 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
6056 name
= t
->symtree
->name
;
6058 if (t
->symtree
->n
.sym
->assoc
)
6059 assoc
= t
->symtree
->n
.sym
->assoc
;
6068 gcc_assert (name
&& assoc
);
6070 /* Is association to a valid variable? */
6071 if (!assoc
->variable
)
6075 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
6076 gfc_error ("%qs at %L associated to vector-indexed target"
6077 " cannot be used in a variable definition"
6079 name
, &e
->where
, context
);
6081 gfc_error ("%qs at %L associated to expression"
6082 " cannot be used in a variable definition"
6084 name
, &e
->where
, context
);
6089 /* Target must be allowed to appear in a variable definition context. */
6090 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
6093 gfc_error ("Associate-name %qs cannot appear in a variable"
6094 " definition context (%s) at %L because its target"
6095 " at %L cannot, either",
6096 name
, context
, &e
->where
,
6097 &assoc
->target
->where
);
6102 /* Check for same value in vector expression subscript. */
6105 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
6106 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
6107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
6108 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
6109 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
6111 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
6112 if (arr
->expr_type
== EXPR_ARRAY
)
6114 gfc_constructor
*c
, *n
;
6117 for (c
= gfc_constructor_first (arr
->value
.constructor
);
6118 c
!= NULL
; c
= gfc_constructor_next (c
))
6120 if (c
== NULL
|| c
->iterator
!= NULL
)
6125 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6126 n
= gfc_constructor_next (n
))
6128 if (n
->iterator
!= NULL
)
6132 if (gfc_dep_compare_expr (ec
, en
) == 0)
6135 gfc_error_now ("Elements with the same value "
6136 "at %L and %L in vector "
6137 "subscript in a variable "
6138 "definition context (%s)",
6139 &(ec
->where
), &(en
->where
),