1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2018 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 switch (inquiry
->u
.i
)
1736 if (tmp
->ts
.type
!= BT_CHARACTER
)
1739 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
1742 if (!tmp
->ts
.u
.cl
->length
1743 || tmp
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1746 *newp
= gfc_copy_expr (tmp
->ts
.u
.cl
->length
);
1750 if (tmp
->ts
.type
== BT_DERIVED
|| tmp
->ts
.type
== BT_CLASS
)
1753 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
1756 *newp
= gfc_get_int_expr (gfc_default_integer_kind
,
1757 NULL
, tmp
->ts
.kind
);
1761 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1764 if (!gfc_notify_std (GFC_STD_F2008
, "RE part_ref at %C"))
1767 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1768 mpfr_set ((*newp
)->value
.real
,
1769 mpc_realref (p
->value
.complex), GFC_RND_MODE
);
1773 if (tmp
->ts
.type
!= BT_COMPLEX
|| tmp
->expr_type
!= EXPR_CONSTANT
)
1776 if (!gfc_notify_std (GFC_STD_F2008
, "IM part_ref at %C"))
1779 *newp
= gfc_get_constant_expr (BT_REAL
, tmp
->ts
.kind
, &tmp
->where
);
1780 mpfr_set ((*newp
)->value
.real
,
1781 mpc_imagref (p
->value
.complex), GFC_RND_MODE
);
1787 else if ((*newp
)->expr_type
!= EXPR_CONSTANT
)
1789 gfc_free_expr (*newp
);
1793 gfc_free_expr (tmp
);
1797 gfc_free_expr (tmp
);
1803 /* Simplify a subobject reference of a constructor. This occurs when
1804 parameter variable values are substituted. */
1807 simplify_const_ref (gfc_expr
*p
)
1809 gfc_constructor
*cons
, *c
;
1810 gfc_expr
*newp
= NULL
;
1815 switch (p
->ref
->type
)
1818 switch (p
->ref
->u
.ar
.type
)
1821 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1822 will generate this. */
1823 if (p
->expr_type
!= EXPR_ARRAY
)
1825 remove_subobject_ref (p
, NULL
);
1828 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1834 remove_subobject_ref (p
, cons
);
1838 if (!find_array_section (p
, p
->ref
))
1840 p
->ref
->u
.ar
.type
= AR_FULL
;
1845 if (p
->ref
->next
!= NULL
1846 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1848 for (c
= gfc_constructor_first (p
->value
.constructor
);
1849 c
; c
= gfc_constructor_next (c
))
1851 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1852 if (!simplify_const_ref (c
->expr
))
1856 if (gfc_bt_struct (p
->ts
.type
)
1858 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1860 /* There may have been component references. */
1861 p
->ts
= c
->expr
->ts
;
1865 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1867 if (p
->ts
.type
== BT_CHARACTER
1868 && last_ref
->type
== REF_SUBSTRING
)
1870 /* If this is a CHARACTER array and we possibly took
1871 a substring out of it, update the type-spec's
1872 character length according to the first element
1873 (as all should have the same length). */
1874 gfc_charlen_t string_len
;
1875 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1877 const gfc_expr
* first
= c
->expr
;
1878 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1879 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1880 string_len
= first
->value
.character
.length
;
1886 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1889 gfc_free_expr (p
->ts
.u
.cl
->length
);
1892 = gfc_get_int_expr (gfc_charlen_int_kind
,
1896 gfc_free_ref_list (p
->ref
);
1907 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1908 remove_subobject_ref (p
, cons
);
1912 if (!find_inquiry_ref (p
, &newp
))
1915 gfc_replace_expr (p
, newp
);
1916 gfc_free_ref_list (p
->ref
);
1921 if (!find_substring_ref (p
, &newp
))
1924 gfc_replace_expr (p
, newp
);
1925 gfc_free_ref_list (p
->ref
);
1935 /* Simplify a chain of references. */
1938 simplify_ref_chain (gfc_ref
*ref
, int type
, gfc_expr
**p
)
1943 for (; ref
; ref
= ref
->next
)
1948 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1950 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1952 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1954 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1960 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1962 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1967 if (!find_inquiry_ref (*p
, &newp
))
1970 gfc_replace_expr (*p
, newp
);
1971 gfc_free_ref_list ((*p
)->ref
);
1983 /* Try to substitute the value of a parameter variable. */
1986 simplify_parameter_variable (gfc_expr
*p
, int type
)
1991 if (gfc_is_size_zero_array (p
))
1993 if (p
->expr_type
== EXPR_ARRAY
)
1996 e
= gfc_get_expr ();
1997 e
->expr_type
= EXPR_ARRAY
;
2000 e
->value
.constructor
= NULL
;
2001 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
2002 e
->where
= p
->where
;
2003 gfc_replace_expr (p
, e
);
2007 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
2013 /* Do not copy subobject refs for constant. */
2014 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
2015 e
->ref
= gfc_copy_ref (p
->ref
);
2016 t
= gfc_simplify_expr (e
, type
);
2018 /* Only use the simplification if it eliminated all subobject references. */
2020 gfc_replace_expr (p
, e
);
2029 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
2031 /* Given an expression, simplify it by collapsing constant
2032 expressions. Most simplification takes place when the expression
2033 tree is being constructed. If an intrinsic function is simplified
2034 at some point, we get called again to collapse the result against
2037 We work by recursively simplifying expression nodes, simplifying
2038 intrinsic functions where possible, which can lead to further
2039 constant collapsing. If an operator has constant operand(s), we
2040 rip the expression apart, and rebuild it, hoping that it becomes
2043 The expression type is defined for:
2044 0 Basic expression parsing
2045 1 Simplifying array constructors -- will substitute
2047 Returns false on error, true otherwise.
2048 NOTE: Will return true even if the expression can not be simplified. */
2051 gfc_simplify_expr (gfc_expr
*p
, int type
)
2053 gfc_actual_arglist
*ap
;
2054 gfc_intrinsic_sym
* isym
= NULL
;
2060 switch (p
->expr_type
)
2063 if (p
->ref
&& p
->ref
->type
== REF_INQUIRY
)
2064 simplify_ref_chain (p
->ref
, type
, &p
);
2070 // For array-bound functions, we don't need to optimize
2071 // the 'array' argument. In particular, if the argument
2072 // is a PARAMETER, simplifying might convert an EXPR_VARIABLE
2073 // into an EXPR_ARRAY; the latter has lbound = 1, the former
2074 // can have any lbound.
2075 ap
= p
->value
.function
.actual
;
2076 if (p
->value
.function
.isym
&&
2077 (p
->value
.function
.isym
->id
== GFC_ISYM_LBOUND
2078 || p
->value
.function
.isym
->id
== GFC_ISYM_UBOUND
2079 || p
->value
.function
.isym
->id
== GFC_ISYM_LCOBOUND
2080 || p
->value
.function
.isym
->id
== GFC_ISYM_UCOBOUND
))
2083 for ( ; ap
; ap
= ap
->next
)
2084 if (!gfc_simplify_expr (ap
->expr
, type
))
2087 if (p
->value
.function
.isym
!= NULL
2088 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
2091 if (p
->expr_type
== EXPR_FUNCTION
)
2094 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
2095 if (isym
&& isym
->elemental
)
2096 scalarize_intrinsic_call (p
, false);
2101 case EXPR_SUBSTRING
:
2102 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2105 if (gfc_is_constant_expr (p
))
2108 HOST_WIDE_INT start
, end
;
2111 if (p
->ref
&& p
->ref
->u
.ss
.start
)
2113 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
2114 start
--; /* Convert from one-based to zero-based. */
2117 end
= p
->value
.character
.length
;
2118 if (p
->ref
&& p
->ref
->u
.ss
.end
)
2119 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
2124 s
= gfc_get_wide_string (end
- start
+ 2);
2125 memcpy (s
, p
->value
.character
.string
+ start
,
2126 (end
- start
) * sizeof (gfc_char_t
));
2127 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
2128 free (p
->value
.character
.string
);
2129 p
->value
.character
.string
= s
;
2130 p
->value
.character
.length
= end
- start
;
2131 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2132 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
2134 p
->value
.character
.length
);
2135 gfc_free_ref_list (p
->ref
);
2137 p
->expr_type
= EXPR_CONSTANT
;
2142 if (!simplify_intrinsic_op (p
, type
))
2147 /* Only substitute array parameter variables if we are in an
2148 initialization expression, or we want a subsection. */
2149 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2150 && (gfc_init_expr_flag
|| p
->ref
2151 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2153 if (!simplify_parameter_variable (p
, type
))
2160 gfc_simplify_iterator_var (p
);
2163 /* Simplify subcomponent references. */
2164 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2169 case EXPR_STRUCTURE
:
2171 if (!simplify_ref_chain (p
->ref
, type
, &p
))
2174 if (!simplify_constructor (p
->value
.constructor
, type
))
2177 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2178 && p
->ref
->u
.ar
.type
== AR_FULL
)
2179 gfc_expand_constructor (p
, false);
2181 if (!simplify_const_ref (p
))
2195 /* Returns the type of an expression with the exception that iterator
2196 variables are automatically integers no matter what else they may
2202 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2209 /* Scalarize an expression for an elemental intrinsic call. */
2212 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2214 gfc_actual_arglist
*a
, *b
;
2215 gfc_constructor_base ctor
;
2216 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2217 gfc_constructor
*ci
, *new_ctor
;
2218 gfc_expr
*expr
, *old
;
2219 int n
, i
, rank
[5], array_arg
;
2225 a
= e
->value
.function
.actual
;
2226 for (; a
; a
= a
->next
)
2227 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2230 /* Find which, if any, arguments are arrays. Assume that the old
2231 expression carries the type information and that the first arg
2232 that is an array expression carries all the shape information.*/
2234 a
= e
->value
.function
.actual
;
2235 for (; a
; a
= a
->next
)
2238 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2241 expr
= gfc_copy_expr (a
->expr
);
2248 old
= gfc_copy_expr (e
);
2250 gfc_constructor_free (expr
->value
.constructor
);
2251 expr
->value
.constructor
= NULL
;
2253 expr
->where
= old
->where
;
2254 expr
->expr_type
= EXPR_ARRAY
;
2256 /* Copy the array argument constructors into an array, with nulls
2259 a
= old
->value
.function
.actual
;
2260 for (; a
; a
= a
->next
)
2262 /* Check that this is OK for an initialization expression. */
2263 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2267 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2269 rank
[n
] = a
->expr
->rank
;
2270 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2271 args
[n
] = gfc_constructor_first (ctor
);
2273 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2276 rank
[n
] = a
->expr
->rank
;
2279 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2280 args
[n
] = gfc_constructor_first (ctor
);
2288 gfc_get_errors (NULL
, &errors
);
2290 /* Using the array argument as the master, step through the array
2291 calling the function for each element and advancing the array
2292 constructors together. */
2293 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2295 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2296 gfc_copy_expr (old
), NULL
);
2298 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2300 b
= old
->value
.function
.actual
;
2301 for (i
= 0; i
< n
; i
++)
2304 new_ctor
->expr
->value
.function
.actual
2305 = a
= gfc_get_actual_arglist ();
2308 a
->next
= gfc_get_actual_arglist ();
2313 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2315 a
->expr
= gfc_copy_expr (b
->expr
);
2320 /* Simplify the function calls. If the simplification fails, the
2321 error will be flagged up down-stream or the library will deal
2324 gfc_simplify_expr (new_ctor
->expr
, 0);
2326 for (i
= 0; i
< n
; i
++)
2328 args
[i
] = gfc_constructor_next (args
[i
]);
2330 for (i
= 1; i
< n
; i
++)
2331 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2332 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2338 /* Free "expr" but not the pointers it contains. */
2340 gfc_free_expr (old
);
2344 gfc_error_now ("elemental function arguments at %C are not compliant");
2347 gfc_free_expr (expr
);
2348 gfc_free_expr (old
);
2354 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2356 gfc_expr
*op1
= e
->value
.op
.op1
;
2357 gfc_expr
*op2
= e
->value
.op
.op2
;
2359 if (!(*check_function
)(op1
))
2362 switch (e
->value
.op
.op
)
2364 case INTRINSIC_UPLUS
:
2365 case INTRINSIC_UMINUS
:
2366 if (!numeric_type (et0 (op1
)))
2371 case INTRINSIC_EQ_OS
:
2373 case INTRINSIC_NE_OS
:
2375 case INTRINSIC_GT_OS
:
2377 case INTRINSIC_GE_OS
:
2379 case INTRINSIC_LT_OS
:
2381 case INTRINSIC_LE_OS
:
2382 if (!(*check_function
)(op2
))
2385 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2386 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2388 gfc_error ("Numeric or CHARACTER operands are required in "
2389 "expression at %L", &e
->where
);
2394 case INTRINSIC_PLUS
:
2395 case INTRINSIC_MINUS
:
2396 case INTRINSIC_TIMES
:
2397 case INTRINSIC_DIVIDE
:
2398 case INTRINSIC_POWER
:
2399 if (!(*check_function
)(op2
))
2402 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2407 case INTRINSIC_CONCAT
:
2408 if (!(*check_function
)(op2
))
2411 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2413 gfc_error ("Concatenation operator in expression at %L "
2414 "must have two CHARACTER operands", &op1
->where
);
2418 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2420 gfc_error ("Concat operator at %L must concatenate strings of the "
2421 "same kind", &e
->where
);
2428 if (et0 (op1
) != BT_LOGICAL
)
2430 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2431 "operand", &op1
->where
);
2440 case INTRINSIC_NEQV
:
2441 if (!(*check_function
)(op2
))
2444 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2446 gfc_error ("LOGICAL operands are required in expression at %L",
2453 case INTRINSIC_PARENTHESES
:
2457 gfc_error ("Only intrinsic operators can be used in expression at %L",
2465 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2470 /* F2003, 7.1.7 (3): In init expression, allocatable components
2471 must not be data-initialized. */
2473 check_alloc_comp_init (gfc_expr
*e
)
2475 gfc_component
*comp
;
2476 gfc_constructor
*ctor
;
2478 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2479 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2481 for (comp
= e
->ts
.u
.derived
->components
,
2482 ctor
= gfc_constructor_first (e
->value
.constructor
);
2483 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2485 if (comp
->attr
.allocatable
&& ctor
->expr
2486 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2488 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2489 "component %qs in structure constructor at %L",
2490 comp
->name
, &ctor
->expr
->where
);
2499 check_init_expr_arguments (gfc_expr
*e
)
2501 gfc_actual_arglist
*ap
;
2503 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2504 if (!gfc_check_init_expr (ap
->expr
))
2510 static bool check_restricted (gfc_expr
*);
2512 /* F95, 7.1.6.1, Initialization expressions, (7)
2513 F2003, 7.1.7 Initialization expression, (8) */
2516 check_inquiry (gfc_expr
*e
, int not_restricted
)
2519 const char *const *functions
;
2521 static const char *const inquiry_func_f95
[] = {
2522 "lbound", "shape", "size", "ubound",
2523 "bit_size", "len", "kind",
2524 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2525 "precision", "radix", "range", "tiny",
2529 static const char *const inquiry_func_f2003
[] = {
2530 "lbound", "shape", "size", "ubound",
2531 "bit_size", "len", "kind",
2532 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2533 "precision", "radix", "range", "tiny",
2538 gfc_actual_arglist
*ap
;
2540 if (!e
->value
.function
.isym
2541 || !e
->value
.function
.isym
->inquiry
)
2544 /* An undeclared parameter will get us here (PR25018). */
2545 if (e
->symtree
== NULL
)
2548 if (e
->symtree
->n
.sym
->from_intmod
)
2550 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2551 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2552 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2555 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2556 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2561 name
= e
->symtree
->n
.sym
->name
;
2563 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2564 ? inquiry_func_f2003
: inquiry_func_f95
;
2566 for (i
= 0; functions
[i
]; i
++)
2567 if (strcmp (functions
[i
], name
) == 0)
2570 if (functions
[i
] == NULL
)
2574 /* At this point we have an inquiry function with a variable argument. The
2575 type of the variable might be undefined, but we need it now, because the
2576 arguments of these functions are not allowed to be undefined. */
2578 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2583 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2585 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2586 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2589 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2592 /* Assumed character length will not reduce to a constant expression
2593 with LEN, as required by the standard. */
2594 if (i
== 5 && not_restricted
&& ap
->expr
->symtree
2595 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2596 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2597 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2599 gfc_error ("Assumed or deferred character length variable %qs "
2600 "in constant expression at %L",
2601 ap
->expr
->symtree
->n
.sym
->name
,
2605 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2608 if (not_restricted
== 0
2609 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2610 && !check_restricted (ap
->expr
))
2613 if (not_restricted
== 0
2614 && ap
->expr
->expr_type
== EXPR_VARIABLE
2615 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2616 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2624 /* F95, 7.1.6.1, Initialization expressions, (5)
2625 F2003, 7.1.7 Initialization expression, (5) */
2628 check_transformational (gfc_expr
*e
)
2630 static const char * const trans_func_f95
[] = {
2631 "repeat", "reshape", "selected_int_kind",
2632 "selected_real_kind", "transfer", "trim", NULL
2635 static const char * const trans_func_f2003
[] = {
2636 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2637 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2638 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2639 "trim", "unpack", NULL
2642 static const char * const trans_func_f2008
[] = {
2643 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2644 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2645 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2646 "trim", "unpack", "findloc", NULL
2651 const char *const *functions
;
2653 if (!e
->value
.function
.isym
2654 || !e
->value
.function
.isym
->transformational
)
2657 name
= e
->symtree
->n
.sym
->name
;
2659 if (gfc_option
.allow_std
& GFC_STD_F2008
)
2660 functions
= trans_func_f2008
;
2661 else if (gfc_option
.allow_std
& GFC_STD_F2003
)
2662 functions
= trans_func_f2003
;
2664 functions
= trans_func_f95
;
2666 /* NULL() is dealt with below. */
2667 if (strcmp ("null", name
) == 0)
2670 for (i
= 0; functions
[i
]; i
++)
2671 if (strcmp (functions
[i
], name
) == 0)
2674 if (functions
[i
] == NULL
)
2676 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2677 "in an initialization expression", name
, &e
->where
);
2681 return check_init_expr_arguments (e
);
2685 /* F95, 7.1.6.1, Initialization expressions, (6)
2686 F2003, 7.1.7 Initialization expression, (6) */
2689 check_null (gfc_expr
*e
)
2691 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2694 return check_init_expr_arguments (e
);
2699 check_elemental (gfc_expr
*e
)
2701 if (!e
->value
.function
.isym
2702 || !e
->value
.function
.isym
->elemental
)
2705 if (e
->ts
.type
!= BT_INTEGER
2706 && e
->ts
.type
!= BT_CHARACTER
2707 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2708 "initialization expression at %L", &e
->where
))
2711 return check_init_expr_arguments (e
);
2716 check_conversion (gfc_expr
*e
)
2718 if (!e
->value
.function
.isym
2719 || !e
->value
.function
.isym
->conversion
)
2722 return check_init_expr_arguments (e
);
2726 /* Verify that an expression is an initialization expression. A side
2727 effect is that the expression tree is reduced to a single constant
2728 node if all goes well. This would normally happen when the
2729 expression is constructed but function references are assumed to be
2730 intrinsics in the context of initialization expressions. If
2731 false is returned an error message has been generated. */
2734 gfc_check_init_expr (gfc_expr
*e
)
2742 switch (e
->expr_type
)
2745 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2747 t
= gfc_simplify_expr (e
, 0);
2756 gfc_intrinsic_sym
* isym
= NULL
;
2757 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2759 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2760 IEEE_EXCEPTIONS modules. */
2761 int mod
= sym
->from_intmod
;
2762 if (mod
== INTMOD_NONE
&& sym
->generic
)
2763 mod
= sym
->generic
->sym
->from_intmod
;
2764 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2766 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2769 gfc_replace_expr (e
, new_expr
);
2775 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2776 into an array constructor, we need to skip the error check here.
2777 Conversion errors are caught below in scalarize_intrinsic_call. */
2778 conversion
= e
->value
.function
.isym
2779 && (e
->value
.function
.isym
->conversion
== 1);
2781 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2782 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2784 gfc_error ("Function %qs in initialization expression at %L "
2785 "must be an intrinsic function",
2786 e
->symtree
->n
.sym
->name
, &e
->where
);
2790 if ((m
= check_conversion (e
)) == MATCH_NO
2791 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2792 && (m
= check_null (e
)) == MATCH_NO
2793 && (m
= check_transformational (e
)) == MATCH_NO
2794 && (m
= check_elemental (e
)) == MATCH_NO
)
2796 gfc_error ("Intrinsic function %qs at %L is not permitted "
2797 "in an initialization expression",
2798 e
->symtree
->n
.sym
->name
, &e
->where
);
2802 if (m
== MATCH_ERROR
)
2805 /* Try to scalarize an elemental intrinsic function that has an
2807 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2808 if (isym
&& isym
->elemental
2809 && (t
= scalarize_intrinsic_call (e
, true)))
2814 t
= gfc_simplify_expr (e
, 0);
2821 /* This occurs when parsing pdt templates. */
2822 if (gfc_expr_attr (e
).pdt_kind
)
2825 if (gfc_check_iter_variable (e
))
2828 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2830 /* A PARAMETER shall not be used to define itself, i.e.
2831 REAL, PARAMETER :: x = transfer(0, x)
2833 if (!e
->symtree
->n
.sym
->value
)
2835 gfc_error ("PARAMETER %qs is used at %L before its definition "
2836 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2840 t
= simplify_parameter_variable (e
, 0);
2845 if (gfc_in_match_data ())
2850 if (e
->symtree
->n
.sym
->as
)
2852 switch (e
->symtree
->n
.sym
->as
->type
)
2854 case AS_ASSUMED_SIZE
:
2855 gfc_error ("Assumed size array %qs at %L is not permitted "
2856 "in an initialization expression",
2857 e
->symtree
->n
.sym
->name
, &e
->where
);
2860 case AS_ASSUMED_SHAPE
:
2861 gfc_error ("Assumed shape array %qs at %L is not permitted "
2862 "in an initialization expression",
2863 e
->symtree
->n
.sym
->name
, &e
->where
);
2867 gfc_error ("Deferred array %qs at %L is not permitted "
2868 "in an initialization expression",
2869 e
->symtree
->n
.sym
->name
, &e
->where
);
2873 gfc_error ("Array %qs at %L is a variable, which does "
2874 "not reduce to a constant expression",
2875 e
->symtree
->n
.sym
->name
, &e
->where
);
2883 gfc_error ("Parameter %qs at %L has not been declared or is "
2884 "a variable, which does not reduce to a constant "
2885 "expression", e
->symtree
->name
, &e
->where
);
2894 case EXPR_SUBSTRING
:
2897 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2901 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2903 t
= gfc_simplify_expr (e
, 0);
2909 case EXPR_STRUCTURE
:
2910 t
= e
->ts
.is_iso_c
? true : false;
2914 t
= check_alloc_comp_init (e
);
2918 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2925 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2929 t
= gfc_expand_constructor (e
, true);
2933 t
= gfc_check_constructor_type (e
);
2937 gfc_internal_error ("check_init_expr(): Unknown expression type");
2943 /* Reduces a general expression to an initialization expression (a constant).
2944 This used to be part of gfc_match_init_expr.
2945 Note that this function doesn't free the given expression on false. */
2948 gfc_reduce_init_expr (gfc_expr
*expr
)
2952 gfc_init_expr_flag
= true;
2953 t
= gfc_resolve_expr (expr
);
2955 t
= gfc_check_init_expr (expr
);
2956 gfc_init_expr_flag
= false;
2961 if (expr
->expr_type
== EXPR_ARRAY
)
2963 if (!gfc_check_constructor_type (expr
))
2965 if (!gfc_expand_constructor (expr
, true))
2973 /* Match an initialization expression. We work by first matching an
2974 expression, then reducing it to a constant. */
2977 gfc_match_init_expr (gfc_expr
**result
)
2985 gfc_init_expr_flag
= true;
2987 m
= gfc_match_expr (&expr
);
2990 gfc_init_expr_flag
= false;
2994 if (gfc_derived_parameter_expr (expr
))
2997 gfc_init_expr_flag
= false;
3001 t
= gfc_reduce_init_expr (expr
);
3004 gfc_free_expr (expr
);
3005 gfc_init_expr_flag
= false;
3010 gfc_init_expr_flag
= false;
3016 /* Given an actual argument list, test to see that each argument is a
3017 restricted expression and optionally if the expression type is
3018 integer or character. */
3021 restricted_args (gfc_actual_arglist
*a
)
3023 for (; a
; a
= a
->next
)
3025 if (!check_restricted (a
->expr
))
3033 /************* Restricted/specification expressions *************/
3036 /* Make sure a non-intrinsic function is a specification function,
3037 * see F08:7.1.11.5. */
3040 external_spec_function (gfc_expr
*e
)
3044 f
= e
->value
.function
.esym
;
3046 /* IEEE functions allowed are "a reference to a transformational function
3047 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
3048 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
3049 IEEE_EXCEPTIONS". */
3050 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
3051 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
3053 if (!strcmp (f
->name
, "ieee_selected_real_kind")
3054 || !strcmp (f
->name
, "ieee_support_rounding")
3055 || !strcmp (f
->name
, "ieee_support_flag")
3056 || !strcmp (f
->name
, "ieee_support_halting")
3057 || !strcmp (f
->name
, "ieee_support_datatype")
3058 || !strcmp (f
->name
, "ieee_support_denormal")
3059 || !strcmp (f
->name
, "ieee_support_divide")
3060 || !strcmp (f
->name
, "ieee_support_inf")
3061 || !strcmp (f
->name
, "ieee_support_io")
3062 || !strcmp (f
->name
, "ieee_support_nan")
3063 || !strcmp (f
->name
, "ieee_support_sqrt")
3064 || !strcmp (f
->name
, "ieee_support_standard")
3065 || !strcmp (f
->name
, "ieee_support_underflow_control"))
3066 goto function_allowed
;
3069 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
3071 gfc_error ("Specification function %qs at %L cannot be a statement "
3072 "function", f
->name
, &e
->where
);
3076 if (f
->attr
.proc
== PROC_INTERNAL
)
3078 gfc_error ("Specification function %qs at %L cannot be an internal "
3079 "function", f
->name
, &e
->where
);
3083 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
3085 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
3091 if (f
->attr
.recursive
3092 && !gfc_notify_std (GFC_STD_F2003
,
3093 "Specification function %qs "
3094 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
3098 return restricted_args (e
->value
.function
.actual
);
3102 /* Check to see that a function reference to an intrinsic is a
3103 restricted expression. */
3106 restricted_intrinsic (gfc_expr
*e
)
3108 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
3109 if (check_inquiry (e
, 0) == MATCH_YES
)
3112 return restricted_args (e
->value
.function
.actual
);
3116 /* Check the expressions of an actual arglist. Used by check_restricted. */
3119 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
3121 for (; arg
; arg
= arg
->next
)
3122 if (!checker (arg
->expr
))
3129 /* Check the subscription expressions of a reference chain with a checking
3130 function; used by check_restricted. */
3133 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
3143 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
3145 if (!checker (ref
->u
.ar
.start
[dim
]))
3147 if (!checker (ref
->u
.ar
.end
[dim
]))
3149 if (!checker (ref
->u
.ar
.stride
[dim
]))
3155 /* Nothing needed, just proceed to next reference. */
3159 if (!checker (ref
->u
.ss
.start
))
3161 if (!checker (ref
->u
.ss
.end
))
3170 return check_references (ref
->next
, checker
);
3173 /* Return true if ns is a parent of the current ns. */
3176 is_parent_of_current_ns (gfc_namespace
*ns
)
3179 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3186 /* Verify that an expression is a restricted expression. Like its
3187 cousin check_init_expr(), an error message is generated if we
3191 check_restricted (gfc_expr
*e
)
3199 switch (e
->expr_type
)
3202 t
= check_intrinsic_op (e
, check_restricted
);
3204 t
= gfc_simplify_expr (e
, 0);
3209 if (e
->value
.function
.esym
)
3211 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3213 t
= external_spec_function (e
);
3217 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3220 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3223 t
= restricted_intrinsic (e
);
3228 sym
= e
->symtree
->n
.sym
;
3231 /* If a dummy argument appears in a context that is valid for a
3232 restricted expression in an elemental procedure, it will have
3233 already been simplified away once we get here. Therefore we
3234 don't need to jump through hoops to distinguish valid from
3236 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3237 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3239 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3240 sym
->name
, &e
->where
);
3244 if (sym
->attr
.optional
)
3246 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3247 sym
->name
, &e
->where
);
3251 if (sym
->attr
.intent
== INTENT_OUT
)
3253 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3254 sym
->name
, &e
->where
);
3258 /* Check reference chain if any. */
3259 if (!check_references (e
->ref
, &check_restricted
))
3262 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3263 processed in resolve.c(resolve_formal_arglist). This is done so
3264 that host associated dummy array indices are accepted (PR23446).
3265 This mechanism also does the same for the specification expressions
3266 of array-valued functions. */
3268 || sym
->attr
.in_common
3269 || sym
->attr
.use_assoc
3271 || sym
->attr
.implied_index
3272 || sym
->attr
.flavor
== FL_PARAMETER
3273 || is_parent_of_current_ns (sym
->ns
)
3274 || (sym
->ns
->proc_name
!= NULL
3275 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3276 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3282 gfc_error ("Variable %qs cannot appear in the expression at %L",
3283 sym
->name
, &e
->where
);
3284 /* Prevent a repetition of the error. */
3293 case EXPR_SUBSTRING
:
3294 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3298 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3300 t
= gfc_simplify_expr (e
, 0);
3304 case EXPR_STRUCTURE
:
3305 t
= gfc_check_constructor (e
, check_restricted
);
3309 t
= gfc_check_constructor (e
, check_restricted
);
3313 gfc_internal_error ("check_restricted(): Unknown expression type");
3320 /* Check to see that an expression is a specification expression. If
3321 we return false, an error has been generated. */
3324 gfc_specification_expr (gfc_expr
*e
)
3326 gfc_component
*comp
;
3331 if (e
->ts
.type
!= BT_INTEGER
)
3333 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3334 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3338 comp
= gfc_get_proc_ptr_comp (e
);
3339 if (e
->expr_type
== EXPR_FUNCTION
3340 && !e
->value
.function
.isym
3341 && !e
->value
.function
.esym
3342 && !gfc_pure (e
->symtree
->n
.sym
)
3343 && (!comp
|| !comp
->attr
.pure
))
3345 gfc_error ("Function %qs at %L must be PURE",
3346 e
->symtree
->n
.sym
->name
, &e
->where
);
3347 /* Prevent repeat error messages. */
3348 e
->symtree
->n
.sym
->attr
.pure
= 1;
3354 gfc_error ("Expression at %L must be scalar", &e
->where
);
3358 if (!gfc_simplify_expr (e
, 0))
3361 return check_restricted (e
);
3365 /************** Expression conformance checks. *************/
3367 /* Given two expressions, make sure that the arrays are conformable. */
3370 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3372 int op1_flag
, op2_flag
, d
;
3373 mpz_t op1_size
, op2_size
;
3379 if (op1
->rank
== 0 || op2
->rank
== 0)
3382 va_start (argp
, optype_msgid
);
3383 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3386 if (op1
->rank
!= op2
->rank
)
3388 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3389 op1
->rank
, op2
->rank
, &op1
->where
);
3395 for (d
= 0; d
< op1
->rank
; d
++)
3397 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3398 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3400 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3402 gfc_error ("Different shape for %s at %L on dimension %d "
3403 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3404 (int) mpz_get_si (op1_size
),
3405 (int) mpz_get_si (op2_size
));
3411 mpz_clear (op1_size
);
3413 mpz_clear (op2_size
);
3423 /* Given an assignable expression and an arbitrary expression, make
3424 sure that the assignment can take place. Only add a call to the intrinsic
3425 conversion routines, when allow_convert is set. When this assign is a
3426 coarray call, then the convert is done by the coarray routine implictly and
3427 adding the intrinsic conversion would do harm in most cases. */
3430 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3437 sym
= lvalue
->symtree
->n
.sym
;
3439 /* See if this is the component or subcomponent of a pointer and guard
3440 against assignment to LEN or KIND part-refs. */
3441 has_pointer
= sym
->attr
.pointer
;
3442 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3444 if (!has_pointer
&& ref
->type
== REF_COMPONENT
3445 && ref
->u
.c
.component
->attr
.pointer
)
3447 else if (ref
->type
== REF_INQUIRY
3448 && (ref
->u
.i
== INQUIRY_LEN
|| ref
->u
.i
== INQUIRY_KIND
))
3450 gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
3451 "allowed", &lvalue
->where
);
3456 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3457 variable local to a function subprogram. Its existence begins when
3458 execution of the function is initiated and ends when execution of the
3459 function is terminated...
3460 Therefore, the left hand side is no longer a variable, when it is: */
3461 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3462 && !sym
->attr
.external
)
3467 /* (i) Use associated; */
3468 if (sym
->attr
.use_assoc
)
3471 /* (ii) The assignment is in the main program; or */
3472 if (gfc_current_ns
->proc_name
3473 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3476 /* (iii) A module or internal procedure... */
3477 if (gfc_current_ns
->proc_name
3478 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3479 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3480 && gfc_current_ns
->parent
3481 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3482 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3483 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3485 /* ... that is not a function... */
3486 if (gfc_current_ns
->proc_name
3487 && !gfc_current_ns
->proc_name
->attr
.function
)
3490 /* ... or is not an entry and has a different name. */
3491 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3495 /* (iv) Host associated and not the function symbol or the
3496 parent result. This picks up sibling references, which
3497 cannot be entries. */
3498 if (!sym
->attr
.entry
3499 && sym
->ns
== gfc_current_ns
->parent
3500 && sym
!= gfc_current_ns
->proc_name
3501 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3506 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3511 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3513 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3514 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3518 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3520 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3525 if (rvalue
->expr_type
== EXPR_NULL
)
3527 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3528 && lvalue
->symtree
->n
.sym
->attr
.data
)
3532 gfc_error ("NULL appears on right-hand side in assignment at %L",
3538 /* This is possibly a typo: x = f() instead of x => f(). */
3540 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3541 gfc_warning (OPT_Wsurprising
,
3542 "POINTER-valued function appears on right-hand side of "
3543 "assignment at %L", &rvalue
->where
);
3545 /* Check size of array assignments. */
3546 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3547 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3550 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3551 && lvalue
->symtree
->n
.sym
->attr
.data
3552 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3553 "initialize non-integer variable %qs",
3554 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3556 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3557 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3558 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3562 /* Handle the case of a BOZ literal on the RHS. */
3563 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3566 if (warn_surprising
)
3567 gfc_warning (OPT_Wsurprising
,
3568 "BOZ literal at %L is bitwise transferred "
3569 "non-integer symbol %qs", &rvalue
->where
,
3570 lvalue
->symtree
->n
.sym
->name
);
3571 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3573 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3575 if (rc
== ARITH_UNDERFLOW
)
3576 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3577 ". This check can be disabled with the option "
3578 "%<-fno-range-check%>", &rvalue
->where
);
3579 else if (rc
== ARITH_OVERFLOW
)
3580 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3581 ". This check can be disabled with the option "
3582 "%<-fno-range-check%>", &rvalue
->where
);
3583 else if (rc
== ARITH_NAN
)
3584 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3585 ". This check can be disabled with the option "
3586 "%<-fno-range-check%>", &rvalue
->where
);
3591 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3593 gfc_error ("The assignment to a KIND or LEN component of a "
3594 "parameterized type at %L is not allowed",
3599 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3602 /* Only DATA Statements come here. */
3607 /* Numeric can be converted to any other numeric. And Hollerith can be
3608 converted to any other type. */
3609 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3610 || rvalue
->ts
.type
== BT_HOLLERITH
)
3613 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3616 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3617 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3618 "conversion of %s to %s", where
,
3619 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3624 /* Assignment is the only case where character variables of different
3625 kind values can be converted into one another. */
3626 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3628 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3629 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3637 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3641 /* Check that a pointer assignment is OK. We first check lvalue, and
3642 we only check rvalue if it's not an assignment to NULL() or a
3643 NULLIFY statement. */
3646 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3648 symbol_attribute attr
, lhs_attr
;
3650 bool is_pure
, is_implicit_pure
, rank_remap
;
3653 lhs_attr
= gfc_expr_attr (lvalue
);
3654 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3656 gfc_error ("Pointer assignment target is not a POINTER at %L",
3661 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3662 && !lhs_attr
.proc_pointer
)
3664 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3665 "l-value since it is a procedure",
3666 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3670 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3673 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3675 if (ref
->type
== REF_COMPONENT
)
3676 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3678 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3682 if (ref
->u
.ar
.type
== AR_FULL
)
3685 if (ref
->u
.ar
.type
!= AR_SECTION
)
3687 gfc_error ("Expected bounds specification for %qs at %L",
3688 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3692 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3693 "for %qs in pointer assignment at %L",
3694 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3697 /* When bounds are given, all lbounds are necessary and either all
3698 or none of the upper bounds; no strides are allowed. If the
3699 upper bounds are present, we may do rank remapping. */
3700 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3702 if (!ref
->u
.ar
.start
[dim
]
3703 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3705 gfc_error ("Lower bound has to be present at %L",
3709 if (ref
->u
.ar
.stride
[dim
])
3711 gfc_error ("Stride must not be present at %L",
3717 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3720 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3721 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3723 gfc_error ("Either all or none of the upper bounds"
3724 " must be specified at %L", &lvalue
->where
);
3732 is_pure
= gfc_pure (NULL
);
3733 is_implicit_pure
= gfc_implicit_pure (NULL
);
3735 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3736 kind, etc for lvalue and rvalue must match, and rvalue must be a
3737 pure variable if we're in a pure function. */
3738 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3741 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3742 if (lvalue
->expr_type
== EXPR_VARIABLE
3743 && gfc_is_coindexed (lvalue
))
3746 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3747 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3749 gfc_error ("Pointer object at %L shall not have a coindex",
3755 /* Checks on rvalue for procedure pointer assignments. */
3760 gfc_component
*comp1
, *comp2
;
3763 attr
= gfc_expr_attr (rvalue
);
3764 if (!((rvalue
->expr_type
== EXPR_NULL
)
3765 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3766 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3767 || (rvalue
->expr_type
== EXPR_VARIABLE
3768 && attr
.flavor
== FL_PROCEDURE
)))
3770 gfc_error ("Invalid procedure pointer assignment at %L",
3774 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3776 /* Check for intrinsics. */
3777 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3778 if (!sym
->attr
.intrinsic
3779 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3780 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3782 sym
->attr
.intrinsic
= 1;
3783 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3784 attr
= gfc_expr_attr (rvalue
);
3786 /* Check for result of embracing function. */
3787 if (sym
->attr
.function
&& sym
->result
== sym
)
3791 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3792 if (sym
== ns
->proc_name
)
3794 gfc_error ("Function result %qs is invalid as proc-target "
3795 "in procedure pointer assignment at %L",
3796 sym
->name
, &rvalue
->where
);
3803 gfc_error ("Abstract interface %qs is invalid "
3804 "in procedure pointer assignment at %L",
3805 rvalue
->symtree
->name
, &rvalue
->where
);
3808 /* Check for F08:C729. */
3809 if (attr
.flavor
== FL_PROCEDURE
)
3811 if (attr
.proc
== PROC_ST_FUNCTION
)
3813 gfc_error ("Statement function %qs is invalid "
3814 "in procedure pointer assignment at %L",
3815 rvalue
->symtree
->name
, &rvalue
->where
);
3818 if (attr
.proc
== PROC_INTERNAL
&&
3819 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3820 "is invalid in procedure pointer assignment "
3821 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3823 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3824 attr
.subroutine
) == 0)
3826 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3827 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3831 /* Check for F08:C730. */
3832 if (attr
.elemental
&& !attr
.intrinsic
)
3834 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3835 "in procedure pointer assignment at %L",
3836 rvalue
->symtree
->name
, &rvalue
->where
);
3840 /* Ensure that the calling convention is the same. As other attributes
3841 such as DLLEXPORT may differ, one explicitly only tests for the
3842 calling conventions. */
3843 if (rvalue
->expr_type
== EXPR_VARIABLE
3844 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3845 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3847 symbol_attribute calls
;
3850 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3851 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3852 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3854 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3855 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3857 gfc_error ("Mismatch in the procedure pointer assignment "
3858 "at %L: mismatch in the calling convention",
3864 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3866 s1
= comp1
->ts
.interface
;
3869 s1
= lvalue
->symtree
->n
.sym
;
3870 if (s1
->ts
.interface
)
3871 s1
= s1
->ts
.interface
;
3874 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3877 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3879 s2
= comp2
->ts
.interface
->result
;
3884 s2
= comp2
->ts
.interface
;
3888 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3890 if (rvalue
->value
.function
.esym
)
3891 s2
= rvalue
->value
.function
.esym
->result
;
3893 s2
= rvalue
->symtree
->n
.sym
->result
;
3899 s2
= rvalue
->symtree
->n
.sym
;
3903 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3904 s2
= s2
->ts
.interface
;
3906 /* Special check for the case of absent interface on the lvalue.
3907 * All other interface checks are done below. */
3908 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3910 gfc_error ("Interface mismatch in procedure pointer assignment "
3911 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
3915 /* F08:7.2.2.4 (4) */
3916 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3920 gfc_error ("Explicit interface required for component %qs at %L: %s",
3921 comp1
->name
, &lvalue
->where
, err
);
3924 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
3926 gfc_error ("Explicit interface required for %qs at %L: %s",
3927 s1
->name
, &lvalue
->where
, err
);
3931 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3935 gfc_error ("Explicit interface required for component %qs at %L: %s",
3936 comp2
->name
, &rvalue
->where
, err
);
3939 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
3941 gfc_error ("Explicit interface required for %qs at %L: %s",
3942 s2
->name
, &rvalue
->where
, err
);
3947 if (s1
== s2
|| !s1
|| !s2
)
3950 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3951 err
, sizeof(err
), NULL
, NULL
))
3953 gfc_error ("Interface mismatch in procedure pointer assignment "
3954 "at %L: %s", &rvalue
->where
, err
);
3958 /* Check F2008Cor2, C729. */
3959 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3960 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3962 gfc_error ("Procedure pointer target %qs at %L must be either an "
3963 "intrinsic, host or use associated, referenced or have "
3964 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3971 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3973 /* Check for F03:C717. */
3974 if (UNLIMITED_POLY (rvalue
)
3975 && !(UNLIMITED_POLY (lvalue
)
3976 || (lvalue
->ts
.type
== BT_DERIVED
3977 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3978 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3979 gfc_error ("Data-pointer-object at %L must be unlimited "
3980 "polymorphic, or of a type with the BIND or SEQUENCE "
3981 "attribute, to be compatible with an unlimited "
3982 "polymorphic target", &lvalue
->where
);
3984 gfc_error ("Different types in pointer assignment at %L; "
3985 "attempted assignment of %s to %s", &lvalue
->where
,
3986 gfc_typename (&rvalue
->ts
),
3987 gfc_typename (&lvalue
->ts
));
3991 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3993 gfc_error ("Different kind type parameters in pointer "
3994 "assignment at %L", &lvalue
->where
);
3998 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
4000 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
4004 /* Make sure the vtab is present. */
4005 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
4006 gfc_find_vtab (&rvalue
->ts
);
4008 /* Check rank remapping. */
4013 /* If this can be determined, check that the target must be at least as
4014 large as the pointer assigned to it is. */
4015 if (gfc_array_size (lvalue
, &lsize
)
4016 && gfc_array_size (rvalue
, &rsize
)
4017 && mpz_cmp (rsize
, lsize
) < 0)
4019 gfc_error ("Rank remapping target is smaller than size of the"
4020 " pointer (%ld < %ld) at %L",
4021 mpz_get_si (rsize
), mpz_get_si (lsize
),
4026 /* The target must be either rank one or it must be simply contiguous
4027 and F2008 must be allowed. */
4028 if (rvalue
->rank
!= 1)
4030 if (!gfc_is_simply_contiguous (rvalue
, true, false))
4032 gfc_error ("Rank remapping target must be rank 1 or"
4033 " simply contiguous at %L", &rvalue
->where
);
4036 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
4037 "rank 1 at %L", &rvalue
->where
))
4042 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
4043 if (rvalue
->expr_type
== EXPR_NULL
)
4046 if (lvalue
->ts
.type
== BT_CHARACTER
)
4048 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
4053 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
4054 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
4056 attr
= gfc_expr_attr (rvalue
);
4058 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
4060 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
4061 to caf_get. Map this to the same error message as below when it is
4062 still a variable expression. */
4063 if (rvalue
->value
.function
.isym
4064 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
4065 /* The test above might need to be extend when F08, Note 5.4 has to be
4066 interpreted in the way that target and pointer with the same coindex
4068 gfc_error ("Data target at %L shall not have a coindex",
4071 gfc_error ("Target expression in pointer assignment "
4072 "at %L must deliver a pointer result",
4077 if (!attr
.target
&& !attr
.pointer
)
4079 gfc_error ("Pointer assignment target is neither TARGET "
4080 "nor POINTER at %L", &rvalue
->where
);
4084 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4086 gfc_error ("Bad target in pointer assignment in PURE "
4087 "procedure at %L", &rvalue
->where
);
4090 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
4091 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
4093 if (gfc_has_vector_index (rvalue
))
4095 gfc_error ("Pointer assignment with vector subscript "
4096 "on rhs at %L", &rvalue
->where
);
4100 if (attr
.is_protected
&& attr
.use_assoc
4101 && !(attr
.pointer
|| attr
.proc_pointer
))
4103 gfc_error ("Pointer assignment target has PROTECTED "
4104 "attribute at %L", &rvalue
->where
);
4108 /* F2008, C725. For PURE also C1283. */
4109 if (rvalue
->expr_type
== EXPR_VARIABLE
4110 && gfc_is_coindexed (rvalue
))
4113 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
4114 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
4116 gfc_error ("Data target at %L shall not have a coindex",
4122 /* Warn for assignments of contiguous pointers to targets which is not
4123 contiguous. Be lenient in the definition of what counts as
4126 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
4127 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
4128 "non-contiguous target at %L", &rvalue
->where
);
4130 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
4131 if (warn_target_lifetime
4132 && rvalue
->expr_type
== EXPR_VARIABLE
4133 && !rvalue
->symtree
->n
.sym
->attr
.save
4134 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
4135 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
4136 && !rvalue
->symtree
->n
.sym
->attr
.in_common
4137 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
4138 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
4143 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
4144 || lvalue
->symtree
->n
.sym
->attr
.result
4145 || lvalue
->symtree
->n
.sym
->attr
.function
4146 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
4147 && lvalue
->symtree
->n
.sym
->ns
4148 != rvalue
->symtree
->n
.sym
->ns
)
4149 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
4150 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
4152 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
4153 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
4154 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
4155 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
4156 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
4158 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4165 gfc_warning (OPT_Wtarget_lifetime
,
4166 "Pointer at %L in pointer assignment might outlive the "
4167 "pointer target", &lvalue
->where
);
4174 /* Relative of gfc_check_assign() except that the lvalue is a single
4175 symbol. Used for initialization assignments. */
4178 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4182 bool pointer
, proc_pointer
;
4184 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4186 lvalue
.expr_type
= EXPR_VARIABLE
;
4187 lvalue
.ts
= sym
->ts
;
4189 lvalue
.rank
= sym
->as
->rank
;
4190 lvalue
.symtree
= XCNEW (gfc_symtree
);
4191 lvalue
.symtree
->n
.sym
= sym
;
4192 lvalue
.where
= sym
->declared_at
;
4196 lvalue
.ref
= gfc_get_ref ();
4197 lvalue
.ref
->type
= REF_COMPONENT
;
4198 lvalue
.ref
->u
.c
.component
= comp
;
4199 lvalue
.ref
->u
.c
.sym
= sym
;
4200 lvalue
.ts
= comp
->ts
;
4201 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4202 lvalue
.where
= comp
->loc
;
4203 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4204 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4205 proc_pointer
= comp
->attr
.proc_pointer
;
4209 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4210 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4211 proc_pointer
= sym
->attr
.proc_pointer
;
4214 if (pointer
|| proc_pointer
)
4215 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
4218 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4219 into an array constructor, we should check if it can be reduced
4220 as an initialization expression. */
4221 if (rvalue
->expr_type
== EXPR_FUNCTION
4222 && rvalue
->value
.function
.isym
4223 && (rvalue
->value
.function
.isym
->conversion
== 1))
4224 gfc_check_init_expr (rvalue
);
4226 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4229 free (lvalue
.symtree
);
4235 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4237 /* F08:C461. Additional checks for pointer initialization. */
4238 symbol_attribute attr
;
4239 attr
= gfc_expr_attr (rvalue
);
4240 if (attr
.allocatable
)
4242 gfc_error ("Pointer initialization target at %L "
4243 "must not be ALLOCATABLE", &rvalue
->where
);
4246 if (!attr
.target
|| attr
.pointer
)
4248 gfc_error ("Pointer initialization target at %L "
4249 "must have the TARGET attribute", &rvalue
->where
);
4253 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4254 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4255 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4257 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4258 attr
.save
= SAVE_IMPLICIT
;
4263 gfc_error ("Pointer initialization target at %L "
4264 "must have the SAVE attribute", &rvalue
->where
);
4269 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4271 /* F08:C1220. Additional checks for procedure pointer initialization. */
4272 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4273 if (attr
.proc_pointer
)
4275 gfc_error ("Procedure pointer initialization target at %L "
4276 "may not be a procedure pointer", &rvalue
->where
);
4284 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4285 * require that an expression be built. */
4288 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4290 return gfc_build_init_expr (ts
, where
, false);
4293 /* Build an initializer for a local integer, real, complex, logical, or
4294 character variable, based on the command line flags finit-local-zero,
4295 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4296 With force, an initializer is ALWAYS generated. */
4299 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4301 gfc_expr
*init_expr
;
4303 /* Try to build an initializer expression. */
4304 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4306 /* If we want to force generation, make sure we default to zero. */
4307 gfc_init_local_real init_real
= flag_init_real
;
4308 int init_logical
= gfc_option
.flag_init_logical
;
4311 if (init_real
== GFC_INIT_REAL_OFF
)
4312 init_real
= GFC_INIT_REAL_ZERO
;
4313 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4314 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4317 /* We will only initialize integers, reals, complex, logicals, and
4318 characters, and only if the corresponding command-line flags
4319 were set. Otherwise, we free init_expr and return null. */
4323 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4324 mpz_set_si (init_expr
->value
.integer
,
4325 gfc_option
.flag_init_integer_value
);
4328 gfc_free_expr (init_expr
);
4336 case GFC_INIT_REAL_SNAN
:
4337 init_expr
->is_snan
= 1;
4339 case GFC_INIT_REAL_NAN
:
4340 mpfr_set_nan (init_expr
->value
.real
);
4343 case GFC_INIT_REAL_INF
:
4344 mpfr_set_inf (init_expr
->value
.real
, 1);
4347 case GFC_INIT_REAL_NEG_INF
:
4348 mpfr_set_inf (init_expr
->value
.real
, -1);
4351 case GFC_INIT_REAL_ZERO
:
4352 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4356 gfc_free_expr (init_expr
);
4365 case GFC_INIT_REAL_SNAN
:
4366 init_expr
->is_snan
= 1;
4368 case GFC_INIT_REAL_NAN
:
4369 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4370 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4373 case GFC_INIT_REAL_INF
:
4374 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4375 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4378 case GFC_INIT_REAL_NEG_INF
:
4379 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4380 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4383 case GFC_INIT_REAL_ZERO
:
4384 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4388 gfc_free_expr (init_expr
);
4395 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4396 init_expr
->value
.logical
= 0;
4397 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4398 init_expr
->value
.logical
= 1;
4401 gfc_free_expr (init_expr
);
4407 /* For characters, the length must be constant in order to
4408 create a default initializer. */
4409 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4411 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4413 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4414 init_expr
->value
.character
.length
= char_len
;
4415 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4416 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4417 init_expr
->value
.character
.string
[i
]
4418 = (unsigned char) gfc_option
.flag_init_character_value
;
4422 gfc_free_expr (init_expr
);
4426 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4427 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4429 gfc_actual_arglist
*arg
;
4430 init_expr
= gfc_get_expr ();
4431 init_expr
->where
= *where
;
4432 init_expr
->ts
= *ts
;
4433 init_expr
->expr_type
= EXPR_FUNCTION
;
4434 init_expr
->value
.function
.isym
=
4435 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4436 init_expr
->value
.function
.name
= "repeat";
4437 arg
= gfc_get_actual_arglist ();
4438 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4439 arg
->expr
->value
.character
.string
[0] =
4440 gfc_option
.flag_init_character_value
;
4441 arg
->next
= gfc_get_actual_arglist ();
4442 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4443 init_expr
->value
.function
.actual
= arg
;
4448 gfc_free_expr (init_expr
);
4455 /* Apply an initialization expression to a typespec. Can be used for symbols or
4456 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4457 combined with some effort. */
4460 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4462 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4464 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4466 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4467 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4468 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4470 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4472 if (init
->expr_type
== EXPR_CONSTANT
)
4473 gfc_set_constant_character_len (len
, init
, -1);
4475 && init
->ts
.type
== BT_CHARACTER
4476 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4477 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4478 init
->ts
.u
.cl
->length
->value
.integer
))
4480 gfc_constructor
*ctor
;
4481 ctor
= gfc_constructor_first (init
->value
.constructor
);
4485 bool has_ts
= (init
->ts
.u
.cl
4486 && init
->ts
.u
.cl
->length_from_typespec
);
4488 /* Remember the length of the first element for checking
4489 that all elements *in the constructor* have the same
4490 length. This need not be the length of the LHS! */
4491 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4492 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4493 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4495 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4496 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4498 gfc_set_constant_character_len (len
, ctor
->expr
,
4499 has_ts
? -1 : first_len
);
4500 if (!ctor
->expr
->ts
.u
.cl
)
4502 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4504 ctor
->expr
->ts
.u
.cl
->length
4505 = gfc_copy_expr (ts
->u
.cl
->length
);
4513 /* Check whether an expression is a structure constructor and whether it has
4514 other values than NULL. */
4517 is_non_empty_structure_constructor (gfc_expr
* e
)
4519 if (e
->expr_type
!= EXPR_STRUCTURE
)
4522 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4525 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4527 cons
= gfc_constructor_next (cons
);
4533 /* Check for default initializer; sym->value is not enough
4534 as it is also set for EXPR_NULL of allocatables. */
4537 gfc_has_default_initializer (gfc_symbol
*der
)
4541 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4542 for (c
= der
->components
; c
; c
= c
->next
)
4543 if (gfc_bt_struct (c
->ts
.type
))
4545 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4546 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4548 && is_non_empty_structure_constructor (c
->initializer
))
4549 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4551 if (c
->attr
.pointer
&& c
->initializer
)
4565 Generate an initializer expression which initializes the entirety of a union.
4566 A normal structure constructor is insufficient without undue effort, because
4567 components of maps may be oddly aligned/overlapped. (For example if a
4568 character is initialized from one map overtop a real from the other, only one
4569 byte of the real is actually initialized.) Unfortunately we don't know the
4570 size of the union right now, so we can't generate a proper initializer, but
4571 we use a NULL expr as a placeholder and do the right thing later in
4572 gfc_trans_subcomponent_assign.
4575 generate_union_initializer (gfc_component
*un
)
4577 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4580 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4581 placeholder
->ts
= un
->ts
;
4586 /* Get the user-specified initializer for a union, if any. This means the user
4587 has said to initialize component(s) of a map. For simplicity's sake we
4588 only allow the user to initialize the first map. We don't have to worry
4589 about overlapping initializers as they are released early in resolution (see
4590 resolve_fl_struct). */
4593 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4596 gfc_expr
*init
=NULL
;
4598 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4601 for (map
= union_type
->components
; map
; map
= map
->next
)
4603 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4605 init
= gfc_default_initializer (&map
->ts
);
4619 class_allocatable (gfc_component
*comp
)
4621 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4622 && CLASS_DATA (comp
)->attr
.allocatable
;
4626 class_pointer (gfc_component
*comp
)
4628 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4629 && CLASS_DATA (comp
)->attr
.pointer
;
4633 comp_allocatable (gfc_component
*comp
)
4635 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4639 comp_pointer (gfc_component
*comp
)
4641 return comp
->attr
.pointer
4642 || comp
->attr
.pointer
4643 || comp
->attr
.proc_pointer
4644 || comp
->attr
.class_pointer
4645 || class_pointer (comp
);
4648 /* Fetch or generate an initializer for the given component.
4649 Only generate an initializer if generate is true. */
4652 component_initializer (gfc_component
*c
, bool generate
)
4654 gfc_expr
*init
= NULL
;
4656 /* Allocatable components always get EXPR_NULL.
4657 Pointer components are only initialized when generating, and only if they
4658 do not already have an initializer. */
4659 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4661 init
= gfc_get_null_expr (&c
->loc
);
4666 /* See if we can find the initializer immediately. */
4667 if (c
->initializer
|| !generate
)
4668 return c
->initializer
;
4670 /* Recursively handle derived type components. */
4671 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4672 init
= gfc_generate_initializer (&c
->ts
, true);
4674 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4676 gfc_component
*map
= NULL
;
4677 gfc_constructor
*ctor
;
4678 gfc_expr
*user_init
;
4680 /* If we don't have a user initializer and we aren't generating one, this
4681 union has no initializer. */
4682 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4683 if (!user_init
&& !generate
)
4686 /* Otherwise use a structure constructor. */
4687 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4691 /* If we are to generate an initializer for the union, add a constructor
4692 which initializes the whole union first. */
4695 ctor
= gfc_constructor_get ();
4696 ctor
->expr
= generate_union_initializer (c
);
4697 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4700 /* If we found an initializer in one of our maps, apply it. Note this
4701 is applied _after_ the entire-union initializer above if any. */
4704 ctor
= gfc_constructor_get ();
4705 ctor
->expr
= user_init
;
4706 ctor
->n
.component
= map
;
4707 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4711 /* Treat simple components like locals. */
4714 /* We MUST give an initializer, so force generation. */
4715 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4716 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4723 /* Get an expression for a default initializer of a derived type. */
4726 gfc_default_initializer (gfc_typespec
*ts
)
4728 return gfc_generate_initializer (ts
, false);
4731 /* Generate an initializer expression for an iso_c_binding type
4732 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
4735 generate_isocbinding_initializer (gfc_symbol
*derived
)
4737 /* The initializers have already been built into the c_null_[fun]ptr symbols
4738 from gen_special_c_interop_ptr. */
4739 gfc_symtree
*npsym
= NULL
;
4740 if (0 == strcmp (derived
->name
, "c_ptr"))
4741 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
4742 else if (0 == strcmp (derived
->name
, "c_funptr"))
4743 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
4745 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
4746 " type, expected %<c_ptr%> or %<c_funptr%>");
4749 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
4750 init
->symtree
= npsym
;
4751 init
->ts
.is_iso_c
= true;
4758 /* Get or generate an expression for a default initializer of a derived type.
4759 If -finit-derived is specified, generate default initialization expressions
4760 for components that lack them when generate is set. */
4763 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4765 gfc_expr
*init
, *tmp
;
4766 gfc_component
*comp
;
4768 generate
= flag_init_derived
&& generate
;
4770 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
4771 return generate_isocbinding_initializer (ts
->u
.derived
);
4773 /* See if we have a default initializer in this, but not in nested
4774 types (otherwise we could use gfc_has_default_initializer()).
4775 We don't need to check if we are going to generate them. */
4776 comp
= ts
->u
.derived
->components
;
4779 for (; comp
; comp
= comp
->next
)
4780 if (comp
->initializer
|| comp_allocatable (comp
))
4787 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4788 &ts
->u
.derived
->declared_at
);
4791 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4793 gfc_constructor
*ctor
= gfc_constructor_get();
4795 /* Fetch or generate an initializer for the component. */
4796 tmp
= component_initializer (comp
, generate
);
4799 /* Save the component ref for STRUCTUREs and UNIONs. */
4800 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4801 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4802 ctor
->n
.component
= comp
;
4804 /* If the initializer was not generated, we need a copy. */
4805 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4806 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
4807 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4810 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
4816 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4823 /* Given a symbol, create an expression node with that symbol as a
4824 variable. If the symbol is array valued, setup a reference of the
4828 gfc_get_variable_expr (gfc_symtree
*var
)
4832 e
= gfc_get_expr ();
4833 e
->expr_type
= EXPR_VARIABLE
;
4835 e
->ts
= var
->n
.sym
->ts
;
4837 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4838 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4839 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4840 && CLASS_DATA (var
->n
.sym
)->as
)))
4842 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4843 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4844 e
->ref
= gfc_get_ref ();
4845 e
->ref
->type
= REF_ARRAY
;
4846 e
->ref
->u
.ar
.type
= AR_FULL
;
4847 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4848 ? CLASS_DATA (var
->n
.sym
)->as
4856 /* Adds a full array reference to an expression, as needed. */
4859 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4862 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4867 ref
->next
= gfc_get_ref ();
4872 e
->ref
= gfc_get_ref ();
4875 ref
->type
= REF_ARRAY
;
4876 ref
->u
.ar
.type
= AR_FULL
;
4877 ref
->u
.ar
.dimen
= e
->rank
;
4878 ref
->u
.ar
.where
= e
->where
;
4884 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4888 lval
= gfc_get_expr ();
4889 lval
->expr_type
= EXPR_VARIABLE
;
4890 lval
->where
= sym
->declared_at
;
4892 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4894 /* It will always be a full array. */
4895 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4896 lval
->rank
= as
? as
->rank
: 0;
4898 gfc_add_full_array_ref (lval
, as
);
4903 /* Returns the array_spec of a full array expression. A NULL is
4904 returned otherwise. */
4906 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4911 if (expr
->rank
== 0)
4914 /* Follow any component references. */
4915 if (expr
->expr_type
== EXPR_VARIABLE
4916 || expr
->expr_type
== EXPR_CONSTANT
)
4919 as
= expr
->symtree
->n
.sym
->as
;
4923 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4928 as
= ref
->u
.c
.component
->as
;
4937 switch (ref
->u
.ar
.type
)
4960 /* General expression traversal function. */
4963 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4964 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4969 gfc_actual_arglist
*args
;
4976 if ((*func
) (expr
, sym
, &f
))
4979 if (expr
->ts
.type
== BT_CHARACTER
4981 && expr
->ts
.u
.cl
->length
4982 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4983 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4986 switch (expr
->expr_type
)
4991 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4993 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
5001 case EXPR_SUBSTRING
:
5004 case EXPR_STRUCTURE
:
5006 for (c
= gfc_constructor_first (expr
->value
.constructor
);
5007 c
; c
= gfc_constructor_next (c
))
5009 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
5013 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
5015 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
5017 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
5019 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
5026 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
5028 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
5044 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
5046 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
5048 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
5050 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
5056 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
5058 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
5063 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
5064 && ref
->u
.c
.component
->ts
.u
.cl
5065 && ref
->u
.c
.component
->ts
.u
.cl
->length
5066 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
5068 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
5072 if (ref
->u
.c
.component
->as
)
5073 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
5074 + ref
->u
.c
.component
->as
->corank
; i
++)
5076 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
5079 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
5096 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
5099 expr_set_symbols_referenced (gfc_expr
*expr
,
5100 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
5101 int *f ATTRIBUTE_UNUSED
)
5103 if (expr
->expr_type
!= EXPR_VARIABLE
)
5105 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
5110 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
5112 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
5116 /* Determine if an expression is a procedure pointer component and return
5117 the component in that case. Otherwise return NULL. */
5120 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
5124 if (!expr
|| !expr
->ref
)
5131 if (ref
->type
== REF_COMPONENT
5132 && ref
->u
.c
.component
->attr
.proc_pointer
)
5133 return ref
->u
.c
.component
;
5139 /* Determine if an expression is a procedure pointer component. */
5142 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
5144 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
5148 /* Determine if an expression is a function with an allocatable class scalar
5151 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
5153 if (expr
->expr_type
== EXPR_FUNCTION
5154 && expr
->value
.function
.esym
5155 && expr
->value
.function
.esym
->result
5156 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5157 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5158 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
5165 /* Determine if an expression is a function with an allocatable class array
5168 gfc_is_class_array_function (gfc_expr
*expr
)
5170 if (expr
->expr_type
== EXPR_FUNCTION
5171 && expr
->value
.function
.esym
5172 && expr
->value
.function
.esym
->result
5173 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5174 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5175 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5176 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5183 /* Walk an expression tree and check each variable encountered for being typed.
5184 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5185 mode as is a basic arithmetic expression using those; this is for things in
5188 INTEGER :: arr(n), n
5189 INTEGER :: arr(n + 1), n
5191 The namespace is needed for IMPLICIT typing. */
5193 static gfc_namespace
* check_typed_ns
;
5196 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5197 int* f ATTRIBUTE_UNUSED
)
5201 if (e
->expr_type
!= EXPR_VARIABLE
)
5204 gcc_assert (e
->symtree
);
5205 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5212 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5216 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5220 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5221 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5223 if (e
->expr_type
== EXPR_OP
)
5227 gcc_assert (e
->value
.op
.op1
);
5228 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5230 if (t
&& e
->value
.op
.op2
)
5231 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5237 /* Otherwise, walk the expression and do it strictly. */
5238 check_typed_ns
= ns
;
5239 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5241 return error_found
? false : true;
5245 /* This function returns true if it contains any references to PDT KIND
5246 or LEN parameters. */
5249 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5250 int* f ATTRIBUTE_UNUSED
)
5252 if (e
->expr_type
!= EXPR_VARIABLE
)
5255 gcc_assert (e
->symtree
);
5256 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5257 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5265 gfc_derived_parameter_expr (gfc_expr
*e
)
5267 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5271 /* This function returns the overall type of a type parameter spec list.
5272 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5273 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5274 unless derived is not NULL. In this latter case, all the LEN parameters
5275 must be either assumed or deferred for the return argument to be set to
5276 anything other than SPEC_EXPLICIT. */
5279 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5281 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5283 bool seen_assumed
= false;
5284 bool seen_deferred
= false;
5286 if (derived
== NULL
)
5288 for (; param_list
; param_list
= param_list
->next
)
5289 if (param_list
->spec_type
== SPEC_ASSUMED
5290 || param_list
->spec_type
== SPEC_DEFERRED
)
5291 return param_list
->spec_type
;
5295 for (; param_list
; param_list
= param_list
->next
)
5297 c
= gfc_find_component (derived
, param_list
->name
,
5299 gcc_assert (c
!= NULL
);
5300 if (c
->attr
.pdt_kind
)
5302 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5303 return SPEC_EXPLICIT
;
5304 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5305 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5306 if (seen_assumed
&& seen_deferred
)
5307 return SPEC_EXPLICIT
;
5309 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5316 gfc_ref_this_image (gfc_ref
*ref
)
5320 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5322 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5323 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5330 gfc_find_team_co (gfc_expr
*e
)
5334 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5335 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5336 return ref
->u
.ar
.team
;
5338 if (e
->value
.function
.actual
->expr
)
5339 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5341 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5342 return ref
->u
.ar
.team
;
5348 gfc_find_stat_co (gfc_expr
*e
)
5352 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5353 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5354 return ref
->u
.ar
.stat
;
5356 if (e
->value
.function
.actual
->expr
)
5357 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5359 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5360 return ref
->u
.ar
.stat
;
5366 gfc_is_coindexed (gfc_expr
*e
)
5370 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5371 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5372 return !gfc_ref_this_image (ref
);
5378 /* Coarrays are variables with a corank but not being coindexed. However, also
5379 the following is a coarray: A subobject of a coarray is a coarray if it does
5380 not have any cosubscripts, vector subscripts, allocatable component
5381 selection, or pointer component selection. (F2008, 2.4.7) */
5384 gfc_is_coarray (gfc_expr
*e
)
5388 gfc_component
*comp
;
5393 if (e
->expr_type
!= EXPR_VARIABLE
)
5397 sym
= e
->symtree
->n
.sym
;
5399 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5400 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5402 coarray
= sym
->attr
.codimension
;
5404 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5408 comp
= ref
->u
.c
.component
;
5409 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5410 && (CLASS_DATA (comp
)->attr
.class_pointer
5411 || CLASS_DATA (comp
)->attr
.allocatable
))
5414 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5416 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5419 coarray
= comp
->attr
.codimension
;
5427 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5433 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5434 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5446 return coarray
&& !coindexed
;
5451 gfc_get_corank (gfc_expr
*e
)
5456 if (!gfc_is_coarray (e
))
5459 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5460 corank
= e
->ts
.u
.derived
->components
->as
5461 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5463 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5465 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5467 if (ref
->type
== REF_ARRAY
)
5468 corank
= ref
->u
.ar
.as
->corank
;
5469 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5476 /* Check whether the expression has an ultimate allocatable component.
5477 Being itself allocatable does not count. */
5479 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5481 gfc_ref
*ref
, *last
= NULL
;
5483 if (e
->expr_type
!= EXPR_VARIABLE
)
5486 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5487 if (ref
->type
== REF_COMPONENT
)
5490 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5491 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5492 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5493 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5497 if (e
->ts
.type
== BT_CLASS
)
5498 return CLASS_DATA (e
)->attr
.alloc_comp
;
5499 else if (e
->ts
.type
== BT_DERIVED
)
5500 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5506 /* Check whether the expression has an pointer component.
5507 Being itself a pointer does not count. */
5509 gfc_has_ultimate_pointer (gfc_expr
*e
)
5511 gfc_ref
*ref
, *last
= NULL
;
5513 if (e
->expr_type
!= EXPR_VARIABLE
)
5516 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5517 if (ref
->type
== REF_COMPONENT
)
5520 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5521 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5522 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5523 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5527 if (e
->ts
.type
== BT_CLASS
)
5528 return CLASS_DATA (e
)->attr
.pointer_comp
;
5529 else if (e
->ts
.type
== BT_DERIVED
)
5530 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5536 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5537 Note: A scalar is not regarded as "simply contiguous" by the standard.
5538 if bool is not strict, some further checks are done - for instance,
5539 a "(::1)" is accepted. */
5542 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5546 gfc_array_ref
*ar
= NULL
;
5547 gfc_ref
*ref
, *part_ref
= NULL
;
5550 if (expr
->expr_type
== EXPR_FUNCTION
)
5552 if (expr
->value
.function
.esym
)
5553 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5556 /* Type-bound procedures. */
5557 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5558 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5562 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5563 if (r
->type
== REF_COMPONENT
)
5566 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5567 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5570 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5573 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5576 if (!permit_element
&& expr
->rank
== 0)
5579 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5582 return false; /* Array shall be last part-ref. */
5584 if (ref
->type
== REF_COMPONENT
)
5586 else if (ref
->type
== REF_SUBSTRING
)
5588 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5592 sym
= expr
->symtree
->n
.sym
;
5593 if (expr
->ts
.type
!= BT_CLASS
5595 && !part_ref
->u
.c
.component
->attr
.contiguous
5596 && part_ref
->u
.c
.component
->attr
.pointer
)
5598 && !sym
->attr
.contiguous
5599 && (sym
->attr
.pointer
5600 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5601 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5604 if (!ar
|| ar
->type
== AR_FULL
)
5607 gcc_assert (ar
->type
== AR_SECTION
);
5609 /* Check for simply contiguous array */
5611 for (i
= 0; i
< ar
->dimen
; i
++)
5613 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5616 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5622 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5625 /* If the previous section was not contiguous, that's an error,
5626 unless we have effective only one element and checking is not
5628 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5629 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5630 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5631 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5632 ar
->end
[i
]->value
.integer
) != 0))
5635 /* Following the standard, "(::1)" or - if known at compile time -
5636 "(lbound:ubound)" are not simply contiguous; if strict
5637 is false, they are regarded as simply contiguous. */
5638 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5639 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5640 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5644 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5645 || !ar
->as
->lower
[i
]
5646 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5647 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5648 ar
->as
->lower
[i
]->value
.integer
) != 0))
5652 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5653 || !ar
->as
->upper
[i
]
5654 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5655 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5656 ar
->as
->upper
[i
]->value
.integer
) != 0))
5664 /* Build call to an intrinsic procedure. The number of arguments has to be
5665 passed (rather than ending the list with a NULL value) because we may
5666 want to add arguments but with a NULL-expression. */
5669 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5670 locus where
, unsigned numarg
, ...)
5673 gfc_actual_arglist
* atail
;
5674 gfc_intrinsic_sym
* isym
;
5677 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5679 isym
= gfc_intrinsic_function_by_id (id
);
5682 result
= gfc_get_expr ();
5683 result
->expr_type
= EXPR_FUNCTION
;
5684 result
->ts
= isym
->ts
;
5685 result
->where
= where
;
5686 result
->value
.function
.name
= mangled_name
;
5687 result
->value
.function
.isym
= isym
;
5689 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5690 gfc_commit_symbol (result
->symtree
->n
.sym
);
5691 gcc_assert (result
->symtree
5692 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5693 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5694 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5695 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5696 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5697 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5699 va_start (ap
, numarg
);
5701 for (i
= 0; i
< numarg
; ++i
)
5705 atail
->next
= gfc_get_actual_arglist ();
5706 atail
= atail
->next
;
5709 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5711 atail
->expr
= va_arg (ap
, gfc_expr
*);
5719 /* Check if an expression may appear in a variable definition context
5720 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5721 This is called from the various places when resolving
5722 the pieces that make up such a context.
5723 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5724 variables), some checks are not performed.
5726 Optionally, a possible error message can be suppressed if context is NULL
5727 and just the return status (true / false) be requested. */
5730 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5731 bool own_scope
, const char* context
)
5733 gfc_symbol
* sym
= NULL
;
5735 bool check_intentin
;
5737 symbol_attribute attr
;
5741 if (e
->expr_type
== EXPR_VARIABLE
)
5743 gcc_assert (e
->symtree
);
5744 sym
= e
->symtree
->n
.sym
;
5746 else if (e
->expr_type
== EXPR_FUNCTION
)
5748 gcc_assert (e
->symtree
);
5749 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5752 attr
= gfc_expr_attr (e
);
5753 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5755 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5758 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5759 " context (%s) at %L", context
, &e
->where
);
5763 else if (e
->expr_type
!= EXPR_VARIABLE
)
5766 gfc_error ("Non-variable expression in variable definition context (%s)"
5767 " at %L", context
, &e
->where
);
5771 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5774 gfc_error ("Named constant %qs in variable definition context (%s)"
5775 " at %L", sym
->name
, context
, &e
->where
);
5778 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5779 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5780 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5783 gfc_error ("%qs in variable definition context (%s) at %L is not"
5784 " a variable", sym
->name
, context
, &e
->where
);
5788 /* Find out whether the expr is a pointer; this also means following
5789 component references to the last one. */
5790 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5791 if (pointer
&& !is_pointer
)
5794 gfc_error ("Non-POINTER in pointer association context (%s)"
5795 " at %L", context
, &e
->where
);
5799 if (e
->ts
.type
== BT_DERIVED
5800 && e
->ts
.u
.derived
== NULL
)
5803 gfc_error ("Type inaccessible in variable definition context (%s) "
5804 "at %L", context
, &e
->where
);
5811 || (e
->ts
.type
== BT_DERIVED
5812 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5813 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5816 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5817 context
, &e
->where
);
5821 /* TS18508, C702/C203. */
5824 || (e
->ts
.type
== BT_DERIVED
5825 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5826 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5829 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5830 context
, &e
->where
);
5834 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5835 component of sub-component of a pointer; we need to distinguish
5836 assignment to a pointer component from pointer-assignment to a pointer
5837 component. Note that (normal) assignment to procedure pointers is not
5839 check_intentin
= !own_scope
;
5840 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5841 && CLASS_DATA (sym
))
5842 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5843 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5845 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5846 check_intentin
= false;
5847 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5849 ptr_component
= true;
5851 check_intentin
= false;
5854 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5856 if (pointer
&& is_pointer
)
5859 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5860 " association context (%s) at %L",
5861 sym
->name
, context
, &e
->where
);
5864 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5867 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5868 " definition context (%s) at %L",
5869 sym
->name
, context
, &e
->where
);
5874 /* PROTECTED and use-associated. */
5875 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5877 if (pointer
&& is_pointer
)
5880 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5881 " pointer association context (%s) at %L",
5882 sym
->name
, context
, &e
->where
);
5885 if (!pointer
&& !is_pointer
)
5888 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5889 " variable definition context (%s) at %L",
5890 sym
->name
, context
, &e
->where
);
5895 /* Variable not assignable from a PURE procedure but appears in
5896 variable definition context. */
5897 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5900 gfc_error ("Variable %qs can not appear in a variable definition"
5901 " context (%s) at %L in PURE procedure",
5902 sym
->name
, context
, &e
->where
);
5906 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5907 && gfc_impure_variable (sym
))
5912 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5914 sym
= ns
->proc_name
;
5917 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5919 sym
->attr
.implicit_pure
= 0;
5924 /* Check variable definition context for associate-names. */
5925 if (!pointer
&& sym
->assoc
)
5928 gfc_association_list
* assoc
;
5930 gcc_assert (sym
->assoc
->target
);
5932 /* If this is a SELECT TYPE temporary (the association is used internally
5933 for SELECT TYPE), silently go over to the target. */
5934 if (sym
->attr
.select_type_temporary
)
5936 gfc_expr
* t
= sym
->assoc
->target
;
5938 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5939 name
= t
->symtree
->name
;
5941 if (t
->symtree
->n
.sym
->assoc
)
5942 assoc
= t
->symtree
->n
.sym
->assoc
;
5951 gcc_assert (name
&& assoc
);
5953 /* Is association to a valid variable? */
5954 if (!assoc
->variable
)
5958 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5959 gfc_error ("%qs at %L associated to vector-indexed target can"
5960 " not be used in a variable definition context (%s)",
5961 name
, &e
->where
, context
);
5963 gfc_error ("%qs at %L associated to expression can"
5964 " not be used in a variable definition context (%s)",
5965 name
, &e
->where
, context
);
5970 /* Target must be allowed to appear in a variable definition context. */
5971 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5974 gfc_error ("Associate-name %qs can not appear in a variable"
5975 " definition context (%s) at %L because its target"
5976 " at %L can not, either",
5977 name
, context
, &e
->where
,
5978 &assoc
->target
->where
);
5983 /* Check for same value in vector expression subscript. */
5986 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5987 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5988 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5989 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5990 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5992 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5993 if (arr
->expr_type
== EXPR_ARRAY
)
5995 gfc_constructor
*c
, *n
;
5998 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5999 c
!= NULL
; c
= gfc_constructor_next (c
))
6001 if (c
== NULL
|| c
->iterator
!= NULL
)
6006 for (n
= gfc_constructor_next (c
); n
!= NULL
;
6007 n
= gfc_constructor_next (n
))
6009 if (n
->iterator
!= NULL
)
6013 if (gfc_dep_compare_expr (ec
, en
) == 0)
6016 gfc_error_now ("Elements with the same value "
6017 "at %L and %L in vector "
6018 "subscript in a variable "
6019 "definition context (%s)",
6020 &(ec
->where
), &(en
->where
),