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
);
610 /* Graft the *src expression onto the *dest subexpression. */
613 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
621 /* Try to extract an integer constant from the passed expression node.
622 Return true if some error occurred, false on success. If REPORT_ERROR
623 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
624 for negative using gfc_error_now. */
627 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
631 /* A KIND component is a parameter too. The expression for it
632 is stored in the initializer and should be consistent with
634 if (gfc_expr_attr(expr
).pdt_kind
)
636 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
638 if (ref
->u
.c
.component
->attr
.pdt_kind
)
639 expr
= ref
->u
.c
.component
->initializer
;
643 if (expr
->expr_type
!= EXPR_CONSTANT
)
645 if (report_error
> 0)
646 gfc_error ("Constant expression required at %C");
647 else if (report_error
< 0)
648 gfc_error_now ("Constant expression required at %C");
652 if (expr
->ts
.type
!= BT_INTEGER
)
654 if (report_error
> 0)
655 gfc_error ("Integer expression required at %C");
656 else if (report_error
< 0)
657 gfc_error_now ("Integer expression required at %C");
661 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
662 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
664 if (report_error
> 0)
665 gfc_error ("Integer value too large in expression at %C");
666 else if (report_error
< 0)
667 gfc_error_now ("Integer value too large in expression at %C");
671 *result
= (int) mpz_get_si (expr
->value
.integer
);
677 /* Same as gfc_extract_int, but use a HWI. */
680 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
, int report_error
)
684 /* A KIND component is a parameter too. The expression for it is
685 stored in the initializer and should be consistent with the tests
687 if (gfc_expr_attr(expr
).pdt_kind
)
689 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
691 if (ref
->u
.c
.component
->attr
.pdt_kind
)
692 expr
= ref
->u
.c
.component
->initializer
;
696 if (expr
->expr_type
!= EXPR_CONSTANT
)
698 if (report_error
> 0)
699 gfc_error ("Constant expression required at %C");
700 else if (report_error
< 0)
701 gfc_error_now ("Constant expression required at %C");
705 if (expr
->ts
.type
!= BT_INTEGER
)
707 if (report_error
> 0)
708 gfc_error ("Integer expression required at %C");
709 else if (report_error
< 0)
710 gfc_error_now ("Integer expression required at %C");
714 /* Use long_long_integer_type_node to determine when to saturate. */
715 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
716 expr
->value
.integer
, false);
718 if (!wi::fits_shwi_p (val
))
720 if (report_error
> 0)
721 gfc_error ("Integer value too large in expression at %C");
722 else if (report_error
< 0)
723 gfc_error_now ("Integer value too large in expression at %C");
727 *result
= val
.to_shwi ();
733 /* Recursively copy a list of reference structures. */
736 gfc_copy_ref (gfc_ref
*src
)
744 dest
= gfc_get_ref ();
745 dest
->type
= src
->type
;
750 ar
= gfc_copy_array_ref (&src
->u
.ar
);
756 dest
->u
.c
= src
->u
.c
;
760 dest
->u
.ss
= src
->u
.ss
;
761 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
762 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
766 dest
->next
= gfc_copy_ref (src
->next
);
772 /* Detect whether an expression has any vector index array references. */
775 gfc_has_vector_index (gfc_expr
*e
)
779 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
780 if (ref
->type
== REF_ARRAY
)
781 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
782 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
788 /* Copy a shape array. */
791 gfc_copy_shape (mpz_t
*shape
, int rank
)
799 new_shape
= gfc_get_shape (rank
);
801 for (n
= 0; n
< rank
; n
++)
802 mpz_init_set (new_shape
[n
], shape
[n
]);
808 /* Copy a shape array excluding dimension N, where N is an integer
809 constant expression. Dimensions are numbered in Fortran style --
812 So, if the original shape array contains R elements
813 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
814 the result contains R-1 elements:
815 { s1 ... sN-1 sN+1 ... sR-1}
817 If anything goes wrong -- N is not a constant, its value is out
818 of range -- or anything else, just returns NULL. */
821 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
823 mpz_t
*new_shape
, *s
;
829 || dim
->expr_type
!= EXPR_CONSTANT
830 || dim
->ts
.type
!= BT_INTEGER
)
833 n
= mpz_get_si (dim
->value
.integer
);
834 n
--; /* Convert to zero based index. */
835 if (n
< 0 || n
>= rank
)
838 s
= new_shape
= gfc_get_shape (rank
- 1);
840 for (i
= 0; i
< rank
; i
++)
844 mpz_init_set (*s
, shape
[i
]);
852 /* Return the maximum kind of two expressions. In general, higher
853 kind numbers mean more precision for numeric types. */
856 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
858 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
862 /* Returns nonzero if the type is numeric, zero otherwise. */
865 numeric_type (bt type
)
867 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
871 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
874 gfc_numeric_ts (gfc_typespec
*ts
)
876 return numeric_type (ts
->type
);
880 /* Return an expression node with an optional argument list attached.
881 A variable number of gfc_expr pointers are strung together in an
882 argument list with a NULL pointer terminating the list. */
885 gfc_build_conversion (gfc_expr
*e
)
890 p
->expr_type
= EXPR_FUNCTION
;
892 p
->value
.function
.actual
= gfc_get_actual_arglist ();
893 p
->value
.function
.actual
->expr
= e
;
899 /* Given an expression node with some sort of numeric binary
900 expression, insert type conversions required to make the operands
901 have the same type. Conversion warnings are disabled if wconversion
904 The exception is that the operands of an exponential don't have to
905 have the same type. If possible, the base is promoted to the type
906 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
907 1.0**2 stays as it is. */
910 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
914 op1
= e
->value
.op
.op1
;
915 op2
= e
->value
.op
.op2
;
917 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
919 gfc_clear_ts (&e
->ts
);
923 /* Kind conversions of same type. */
924 if (op1
->ts
.type
== op2
->ts
.type
)
926 if (op1
->ts
.kind
== op2
->ts
.kind
)
928 /* No type conversions. */
933 if (op1
->ts
.kind
> op2
->ts
.kind
)
934 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
936 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
942 /* Integer combined with real or complex. */
943 if (op2
->ts
.type
== BT_INTEGER
)
947 /* Special case for ** operator. */
948 if (e
->value
.op
.op
== INTRINSIC_POWER
)
951 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
955 if (op1
->ts
.type
== BT_INTEGER
)
958 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
962 /* Real combined with complex. */
963 e
->ts
.type
= BT_COMPLEX
;
964 if (op1
->ts
.kind
> op2
->ts
.kind
)
965 e
->ts
.kind
= op1
->ts
.kind
;
967 e
->ts
.kind
= op2
->ts
.kind
;
968 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
969 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
970 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
971 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
978 /* Determine if an expression is constant in the sense of F08:7.1.12.
979 * This function expects that the expression has already been simplified. */
982 gfc_is_constant_expr (gfc_expr
*e
)
985 gfc_actual_arglist
*arg
;
990 switch (e
->expr_type
)
993 return (gfc_is_constant_expr (e
->value
.op
.op1
)
994 && (e
->value
.op
.op2
== NULL
995 || gfc_is_constant_expr (e
->value
.op
.op2
)));
998 /* The only context in which this can occur is in a parameterized
999 derived type declaration, so returning true is OK. */
1000 if (e
->symtree
->n
.sym
->attr
.pdt_len
1001 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1008 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1009 || e
->value
.function
.isym
);
1011 /* Call to intrinsic with at least one argument. */
1012 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1014 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1015 if (!gfc_is_constant_expr (arg
->expr
))
1019 if (e
->value
.function
.isym
1020 && (e
->value
.function
.isym
->elemental
1021 || e
->value
.function
.isym
->pure
1022 || e
->value
.function
.isym
->inquiry
1023 || e
->value
.function
.isym
->transformational
))
1032 case EXPR_SUBSTRING
:
1033 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1034 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1037 case EXPR_STRUCTURE
:
1038 c
= gfc_constructor_first (e
->value
.constructor
);
1039 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1040 return gfc_constant_ac (e
);
1042 for (; c
; c
= gfc_constructor_next (c
))
1043 if (!gfc_is_constant_expr (c
->expr
))
1050 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1056 /* Is true if an array reference is followed by a component or substring
1059 is_subref_array (gfc_expr
* e
)
1064 if (e
->expr_type
!= EXPR_VARIABLE
)
1067 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
1070 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1071 && e
->symtree
->n
.sym
->attr
.dummy
1072 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
1073 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
)
1077 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1079 if (ref
->type
== REF_ARRAY
1080 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1084 && ref
->type
!= REF_ARRAY
)
1091 /* Try to collapse intrinsic expressions. */
1094 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1096 gfc_intrinsic_op op
;
1097 gfc_expr
*op1
, *op2
, *result
;
1099 if (p
->value
.op
.op
== INTRINSIC_USER
)
1102 op1
= p
->value
.op
.op1
;
1103 op2
= p
->value
.op
.op2
;
1104 op
= p
->value
.op
.op
;
1106 if (!gfc_simplify_expr (op1
, type
))
1108 if (!gfc_simplify_expr (op2
, type
))
1111 if (!gfc_is_constant_expr (op1
)
1112 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1116 p
->value
.op
.op1
= NULL
;
1117 p
->value
.op
.op2
= NULL
;
1121 case INTRINSIC_PARENTHESES
:
1122 result
= gfc_parentheses (op1
);
1125 case INTRINSIC_UPLUS
:
1126 result
= gfc_uplus (op1
);
1129 case INTRINSIC_UMINUS
:
1130 result
= gfc_uminus (op1
);
1133 case INTRINSIC_PLUS
:
1134 result
= gfc_add (op1
, op2
);
1137 case INTRINSIC_MINUS
:
1138 result
= gfc_subtract (op1
, op2
);
1141 case INTRINSIC_TIMES
:
1142 result
= gfc_multiply (op1
, op2
);
1145 case INTRINSIC_DIVIDE
:
1146 result
= gfc_divide (op1
, op2
);
1149 case INTRINSIC_POWER
:
1150 result
= gfc_power (op1
, op2
);
1153 case INTRINSIC_CONCAT
:
1154 result
= gfc_concat (op1
, op2
);
1158 case INTRINSIC_EQ_OS
:
1159 result
= gfc_eq (op1
, op2
, op
);
1163 case INTRINSIC_NE_OS
:
1164 result
= gfc_ne (op1
, op2
, op
);
1168 case INTRINSIC_GT_OS
:
1169 result
= gfc_gt (op1
, op2
, op
);
1173 case INTRINSIC_GE_OS
:
1174 result
= gfc_ge (op1
, op2
, op
);
1178 case INTRINSIC_LT_OS
:
1179 result
= gfc_lt (op1
, op2
, op
);
1183 case INTRINSIC_LE_OS
:
1184 result
= gfc_le (op1
, op2
, op
);
1188 result
= gfc_not (op1
);
1192 result
= gfc_and (op1
, op2
);
1196 result
= gfc_or (op1
, op2
);
1200 result
= gfc_eqv (op1
, op2
);
1203 case INTRINSIC_NEQV
:
1204 result
= gfc_neqv (op1
, op2
);
1208 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1213 gfc_free_expr (op1
);
1214 gfc_free_expr (op2
);
1218 result
->rank
= p
->rank
;
1219 result
->where
= p
->where
;
1220 gfc_replace_expr (p
, result
);
1226 /* Subroutine to simplify constructor expressions. Mutually recursive
1227 with gfc_simplify_expr(). */
1230 simplify_constructor (gfc_constructor_base base
, int type
)
1235 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1238 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1239 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1240 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1245 /* Try and simplify a copy. Replace the original if successful
1246 but keep going through the constructor at all costs. Not
1247 doing so can make a dog's dinner of complicated things. */
1248 p
= gfc_copy_expr (c
->expr
);
1250 if (!gfc_simplify_expr (p
, type
))
1256 gfc_replace_expr (c
->expr
, p
);
1264 /* Pull a single array element out of an array constructor. */
1267 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1268 gfc_constructor
**rval
)
1270 unsigned long nelemen
;
1276 gfc_constructor
*cons
;
1283 mpz_init_set_ui (offset
, 0);
1286 mpz_init_set_ui (span
, 1);
1287 for (i
= 0; i
< ar
->dimen
; i
++)
1289 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1290 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1298 if (e
->expr_type
!= EXPR_CONSTANT
)
1304 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1305 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1307 /* Check the bounds. */
1308 if ((ar
->as
->upper
[i
]
1309 && mpz_cmp (e
->value
.integer
,
1310 ar
->as
->upper
[i
]->value
.integer
) > 0)
1311 || (mpz_cmp (e
->value
.integer
,
1312 ar
->as
->lower
[i
]->value
.integer
) < 0))
1314 gfc_error ("Index in dimension %d is out of bounds "
1315 "at %L", i
+ 1, &ar
->c_where
[i
]);
1321 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1322 mpz_mul (delta
, delta
, span
);
1323 mpz_add (offset
, offset
, delta
);
1325 mpz_set_ui (tmp
, 1);
1326 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1327 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1328 mpz_mul (span
, span
, tmp
);
1331 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1332 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1351 /* Find a component of a structure constructor. */
1353 static gfc_constructor
*
1354 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1356 gfc_component
*pick
= ref
->u
.c
.component
;
1357 gfc_constructor
*c
= gfc_constructor_first (base
);
1359 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1360 int ext
= dt
->attr
.extension
;
1362 /* For extended types, check if the desired component is in one of the
1364 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1365 pick
->name
, true, true, NULL
))
1367 dt
= dt
->components
->ts
.u
.derived
;
1368 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1372 gfc_component
*comp
= dt
->components
;
1373 while (comp
!= pick
)
1376 c
= gfc_constructor_next (c
);
1383 /* Replace an expression with the contents of a constructor, removing
1384 the subobject reference in the process. */
1387 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1397 e
= gfc_copy_expr (p
);
1398 e
->ref
= p
->ref
->next
;
1399 p
->ref
->next
= NULL
;
1400 gfc_replace_expr (p
, e
);
1404 /* Pull an array section out of an array constructor. */
1407 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1414 long unsigned one
= 1;
1416 mpz_t start
[GFC_MAX_DIMENSIONS
];
1417 mpz_t end
[GFC_MAX_DIMENSIONS
];
1418 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1419 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1420 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1425 gfc_constructor_base base
;
1426 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1436 base
= expr
->value
.constructor
;
1437 expr
->value
.constructor
= NULL
;
1439 rank
= ref
->u
.ar
.as
->rank
;
1441 if (expr
->shape
== NULL
)
1442 expr
->shape
= gfc_get_shape (rank
);
1444 mpz_init_set_ui (delta_mpz
, one
);
1445 mpz_init_set_ui (nelts
, one
);
1448 /* Do the initialization now, so that we can cleanup without
1449 keeping track of where we were. */
1450 for (d
= 0; d
< rank
; d
++)
1452 mpz_init (delta
[d
]);
1453 mpz_init (start
[d
]);
1456 mpz_init (stride
[d
]);
1460 /* Build the counters to clock through the array reference. */
1462 for (d
= 0; d
< rank
; d
++)
1464 /* Make this stretch of code easier on the eye! */
1465 begin
= ref
->u
.ar
.start
[d
];
1466 finish
= ref
->u
.ar
.end
[d
];
1467 step
= ref
->u
.ar
.stride
[d
];
1468 lower
= ref
->u
.ar
.as
->lower
[d
];
1469 upper
= ref
->u
.ar
.as
->upper
[d
];
1471 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1473 gfc_constructor
*ci
;
1476 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1482 gcc_assert (begin
->rank
== 1);
1483 /* Zero-sized arrays have no shape and no elements, stop early. */
1486 mpz_init_set_ui (nelts
, 0);
1490 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1491 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1492 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1493 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1496 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1498 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1499 || mpz_cmp (ci
->expr
->value
.integer
,
1500 lower
->value
.integer
) < 0)
1502 gfc_error ("index in dimension %d is out of bounds "
1503 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1511 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1512 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1513 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1519 /* Obtain the stride. */
1521 mpz_set (stride
[d
], step
->value
.integer
);
1523 mpz_set_ui (stride
[d
], one
);
1525 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1526 mpz_set_ui (stride
[d
], one
);
1528 /* Obtain the start value for the index. */
1530 mpz_set (start
[d
], begin
->value
.integer
);
1532 mpz_set (start
[d
], lower
->value
.integer
);
1534 mpz_set (ctr
[d
], start
[d
]);
1536 /* Obtain the end value for the index. */
1538 mpz_set (end
[d
], finish
->value
.integer
);
1540 mpz_set (end
[d
], upper
->value
.integer
);
1542 /* Separate 'if' because elements sometimes arrive with
1544 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1545 mpz_set (end
[d
], begin
->value
.integer
);
1547 /* Check the bounds. */
1548 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1549 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1550 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1551 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1553 gfc_error ("index in dimension %d is out of bounds "
1554 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1559 /* Calculate the number of elements and the shape. */
1560 mpz_set (tmp_mpz
, stride
[d
]);
1561 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1562 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1563 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1564 mpz_mul (nelts
, nelts
, tmp_mpz
);
1566 /* An element reference reduces the rank of the expression; don't
1567 add anything to the shape array. */
1568 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1569 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1572 /* Calculate the 'stride' (=delta) for conversion of the
1573 counter values into the index along the constructor. */
1574 mpz_set (delta
[d
], delta_mpz
);
1575 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1576 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1577 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1581 cons
= gfc_constructor_first (base
);
1583 /* Now clock through the array reference, calculating the index in
1584 the source constructor and transferring the elements to the new
1586 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1588 mpz_init_set_ui (ptr
, 0);
1591 for (d
= 0; d
< rank
; d
++)
1593 mpz_set (tmp_mpz
, ctr
[d
]);
1594 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1595 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1596 mpz_add (ptr
, ptr
, tmp_mpz
);
1598 if (!incr_ctr
) continue;
1600 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1602 gcc_assert(vecsub
[d
]);
1604 if (!gfc_constructor_next (vecsub
[d
]))
1605 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1608 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1611 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1615 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1617 if (mpz_cmp_ui (stride
[d
], 0) > 0
1618 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1619 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1620 mpz_set (ctr
[d
], start
[d
]);
1626 limit
= mpz_get_ui (ptr
);
1627 if (limit
>= flag_max_array_constructor
)
1629 gfc_error ("The number of elements in the array constructor "
1630 "at %L requires an increase of the allowed %d "
1631 "upper limit. See -fmax-array-constructor "
1632 "option", &expr
->where
, flag_max_array_constructor
);
1636 cons
= gfc_constructor_lookup (base
, limit
);
1638 gfc_constructor_append_expr (&expr
->value
.constructor
,
1639 gfc_copy_expr (cons
->expr
), NULL
);
1646 mpz_clear (delta_mpz
);
1647 mpz_clear (tmp_mpz
);
1649 for (d
= 0; d
< rank
; d
++)
1651 mpz_clear (delta
[d
]);
1652 mpz_clear (start
[d
]);
1655 mpz_clear (stride
[d
]);
1657 gfc_constructor_free (base
);
1661 /* Pull a substring out of an expression. */
1664 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1667 gfc_charlen_t start
;
1668 gfc_charlen_t length
;
1671 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1672 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1675 *newp
= gfc_copy_expr (p
);
1676 free ((*newp
)->value
.character
.string
);
1678 end
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1679 start
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1681 length
= end
- start
+ 1;
1685 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1686 (*newp
)->value
.character
.length
= length
;
1687 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1688 length
* sizeof (gfc_char_t
));
1695 /* Simplify a subobject reference of a constructor. This occurs when
1696 parameter variable values are substituted. */
1699 simplify_const_ref (gfc_expr
*p
)
1701 gfc_constructor
*cons
, *c
;
1707 switch (p
->ref
->type
)
1710 switch (p
->ref
->u
.ar
.type
)
1713 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1714 will generate this. */
1715 if (p
->expr_type
!= EXPR_ARRAY
)
1717 remove_subobject_ref (p
, NULL
);
1720 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1726 remove_subobject_ref (p
, cons
);
1730 if (!find_array_section (p
, p
->ref
))
1732 p
->ref
->u
.ar
.type
= AR_FULL
;
1737 if (p
->ref
->next
!= NULL
1738 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1740 for (c
= gfc_constructor_first (p
->value
.constructor
);
1741 c
; c
= gfc_constructor_next (c
))
1743 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1744 if (!simplify_const_ref (c
->expr
))
1748 if (gfc_bt_struct (p
->ts
.type
)
1750 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1752 /* There may have been component references. */
1753 p
->ts
= c
->expr
->ts
;
1757 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1759 if (p
->ts
.type
== BT_CHARACTER
1760 && last_ref
->type
== REF_SUBSTRING
)
1762 /* If this is a CHARACTER array and we possibly took
1763 a substring out of it, update the type-spec's
1764 character length according to the first element
1765 (as all should have the same length). */
1766 gfc_charlen_t string_len
;
1767 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1769 const gfc_expr
* first
= c
->expr
;
1770 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1771 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1772 string_len
= first
->value
.character
.length
;
1778 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1781 gfc_free_expr (p
->ts
.u
.cl
->length
);
1784 = gfc_get_int_expr (gfc_charlen_int_kind
,
1788 gfc_free_ref_list (p
->ref
);
1799 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1800 remove_subobject_ref (p
, cons
);
1804 if (!find_substring_ref (p
, &newp
))
1807 gfc_replace_expr (p
, newp
);
1808 gfc_free_ref_list (p
->ref
);
1818 /* Simplify a chain of references. */
1821 simplify_ref_chain (gfc_ref
*ref
, int type
)
1825 for (; ref
; ref
= ref
->next
)
1830 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1832 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1834 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1836 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1842 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1844 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1856 /* Try to substitute the value of a parameter variable. */
1859 simplify_parameter_variable (gfc_expr
*p
, int type
)
1864 if (gfc_is_size_zero_array (p
))
1866 if (p
->expr_type
== EXPR_ARRAY
)
1869 e
= gfc_get_expr ();
1870 e
->expr_type
= EXPR_ARRAY
;
1873 e
->value
.constructor
= NULL
;
1874 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
1875 e
->where
= p
->where
;
1876 gfc_replace_expr (p
, e
);
1880 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1886 /* Do not copy subobject refs for constant. */
1887 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1888 e
->ref
= gfc_copy_ref (p
->ref
);
1889 t
= gfc_simplify_expr (e
, type
);
1891 /* Only use the simplification if it eliminated all subobject references. */
1893 gfc_replace_expr (p
, e
);
1902 scalarize_intrinsic_call (gfc_expr
*, bool init_flag
);
1904 /* Given an expression, simplify it by collapsing constant
1905 expressions. Most simplification takes place when the expression
1906 tree is being constructed. If an intrinsic function is simplified
1907 at some point, we get called again to collapse the result against
1910 We work by recursively simplifying expression nodes, simplifying
1911 intrinsic functions where possible, which can lead to further
1912 constant collapsing. If an operator has constant operand(s), we
1913 rip the expression apart, and rebuild it, hoping that it becomes
1916 The expression type is defined for:
1917 0 Basic expression parsing
1918 1 Simplifying array constructors -- will substitute
1920 Returns false on error, true otherwise.
1921 NOTE: Will return true even if the expression can not be simplified. */
1924 gfc_simplify_expr (gfc_expr
*p
, int type
)
1926 gfc_actual_arglist
*ap
;
1927 gfc_intrinsic_sym
* isym
= NULL
;
1933 switch (p
->expr_type
)
1940 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1941 if (!gfc_simplify_expr (ap
->expr
, type
))
1944 if (p
->value
.function
.isym
!= NULL
1945 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1948 if (p
->expr_type
== EXPR_FUNCTION
)
1951 isym
= gfc_find_function (p
->symtree
->n
.sym
->name
);
1952 if (isym
&& isym
->elemental
)
1953 scalarize_intrinsic_call (p
, false);
1958 case EXPR_SUBSTRING
:
1959 if (!simplify_ref_chain (p
->ref
, type
))
1962 if (gfc_is_constant_expr (p
))
1965 HOST_WIDE_INT start
, end
;
1968 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1970 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
1971 start
--; /* Convert from one-based to zero-based. */
1974 end
= p
->value
.character
.length
;
1975 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1976 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
1981 s
= gfc_get_wide_string (end
- start
+ 2);
1982 memcpy (s
, p
->value
.character
.string
+ start
,
1983 (end
- start
) * sizeof (gfc_char_t
));
1984 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1985 free (p
->value
.character
.string
);
1986 p
->value
.character
.string
= s
;
1987 p
->value
.character
.length
= end
- start
;
1988 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1989 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
1991 p
->value
.character
.length
);
1992 gfc_free_ref_list (p
->ref
);
1994 p
->expr_type
= EXPR_CONSTANT
;
1999 if (!simplify_intrinsic_op (p
, type
))
2004 /* Only substitute array parameter variables if we are in an
2005 initialization expression, or we want a subsection. */
2006 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
2007 && (gfc_init_expr_flag
|| p
->ref
2008 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
2010 if (!simplify_parameter_variable (p
, type
))
2017 gfc_simplify_iterator_var (p
);
2020 /* Simplify subcomponent references. */
2021 if (!simplify_ref_chain (p
->ref
, type
))
2026 case EXPR_STRUCTURE
:
2028 if (!simplify_ref_chain (p
->ref
, type
))
2031 if (!simplify_constructor (p
->value
.constructor
, type
))
2034 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2035 && p
->ref
->u
.ar
.type
== AR_FULL
)
2036 gfc_expand_constructor (p
, false);
2038 if (!simplify_const_ref (p
))
2052 /* Returns the type of an expression with the exception that iterator
2053 variables are automatically integers no matter what else they may
2059 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2066 /* Scalarize an expression for an elemental intrinsic call. */
2069 scalarize_intrinsic_call (gfc_expr
*e
, bool init_flag
)
2071 gfc_actual_arglist
*a
, *b
;
2072 gfc_constructor_base ctor
;
2073 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2074 gfc_constructor
*ci
, *new_ctor
;
2075 gfc_expr
*expr
, *old
;
2076 int n
, i
, rank
[5], array_arg
;
2082 a
= e
->value
.function
.actual
;
2083 for (; a
; a
= a
->next
)
2084 if (a
->expr
&& !gfc_is_constant_expr (a
->expr
))
2087 /* Find which, if any, arguments are arrays. Assume that the old
2088 expression carries the type information and that the first arg
2089 that is an array expression carries all the shape information.*/
2091 a
= e
->value
.function
.actual
;
2092 for (; a
; a
= a
->next
)
2095 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2098 expr
= gfc_copy_expr (a
->expr
);
2105 old
= gfc_copy_expr (e
);
2107 gfc_constructor_free (expr
->value
.constructor
);
2108 expr
->value
.constructor
= NULL
;
2110 expr
->where
= old
->where
;
2111 expr
->expr_type
= EXPR_ARRAY
;
2113 /* Copy the array argument constructors into an array, with nulls
2116 a
= old
->value
.function
.actual
;
2117 for (; a
; a
= a
->next
)
2119 /* Check that this is OK for an initialization expression. */
2120 if (a
->expr
&& init_flag
&& !gfc_check_init_expr (a
->expr
))
2124 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2126 rank
[n
] = a
->expr
->rank
;
2127 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2128 args
[n
] = gfc_constructor_first (ctor
);
2130 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2133 rank
[n
] = a
->expr
->rank
;
2136 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2137 args
[n
] = gfc_constructor_first (ctor
);
2145 gfc_get_errors (NULL
, &errors
);
2147 /* Using the array argument as the master, step through the array
2148 calling the function for each element and advancing the array
2149 constructors together. */
2150 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2152 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2153 gfc_copy_expr (old
), NULL
);
2155 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2157 b
= old
->value
.function
.actual
;
2158 for (i
= 0; i
< n
; i
++)
2161 new_ctor
->expr
->value
.function
.actual
2162 = a
= gfc_get_actual_arglist ();
2165 a
->next
= gfc_get_actual_arglist ();
2170 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2172 a
->expr
= gfc_copy_expr (b
->expr
);
2177 /* Simplify the function calls. If the simplification fails, the
2178 error will be flagged up down-stream or the library will deal
2181 gfc_simplify_expr (new_ctor
->expr
, 0);
2183 for (i
= 0; i
< n
; i
++)
2185 args
[i
] = gfc_constructor_next (args
[i
]);
2187 for (i
= 1; i
< n
; i
++)
2188 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2189 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2195 /* Free "expr" but not the pointers it contains. */
2197 gfc_free_expr (old
);
2201 gfc_error_now ("elemental function arguments at %C are not compliant");
2204 gfc_free_expr (expr
);
2205 gfc_free_expr (old
);
2211 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2213 gfc_expr
*op1
= e
->value
.op
.op1
;
2214 gfc_expr
*op2
= e
->value
.op
.op2
;
2216 if (!(*check_function
)(op1
))
2219 switch (e
->value
.op
.op
)
2221 case INTRINSIC_UPLUS
:
2222 case INTRINSIC_UMINUS
:
2223 if (!numeric_type (et0 (op1
)))
2228 case INTRINSIC_EQ_OS
:
2230 case INTRINSIC_NE_OS
:
2232 case INTRINSIC_GT_OS
:
2234 case INTRINSIC_GE_OS
:
2236 case INTRINSIC_LT_OS
:
2238 case INTRINSIC_LE_OS
:
2239 if (!(*check_function
)(op2
))
2242 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2243 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2245 gfc_error ("Numeric or CHARACTER operands are required in "
2246 "expression at %L", &e
->where
);
2251 case INTRINSIC_PLUS
:
2252 case INTRINSIC_MINUS
:
2253 case INTRINSIC_TIMES
:
2254 case INTRINSIC_DIVIDE
:
2255 case INTRINSIC_POWER
:
2256 if (!(*check_function
)(op2
))
2259 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2264 case INTRINSIC_CONCAT
:
2265 if (!(*check_function
)(op2
))
2268 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2270 gfc_error ("Concatenation operator in expression at %L "
2271 "must have two CHARACTER operands", &op1
->where
);
2275 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2277 gfc_error ("Concat operator at %L must concatenate strings of the "
2278 "same kind", &e
->where
);
2285 if (et0 (op1
) != BT_LOGICAL
)
2287 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2288 "operand", &op1
->where
);
2297 case INTRINSIC_NEQV
:
2298 if (!(*check_function
)(op2
))
2301 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2303 gfc_error ("LOGICAL operands are required in expression at %L",
2310 case INTRINSIC_PARENTHESES
:
2314 gfc_error ("Only intrinsic operators can be used in expression at %L",
2322 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2327 /* F2003, 7.1.7 (3): In init expression, allocatable components
2328 must not be data-initialized. */
2330 check_alloc_comp_init (gfc_expr
*e
)
2332 gfc_component
*comp
;
2333 gfc_constructor
*ctor
;
2335 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2336 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2338 for (comp
= e
->ts
.u
.derived
->components
,
2339 ctor
= gfc_constructor_first (e
->value
.constructor
);
2340 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2342 if (comp
->attr
.allocatable
&& ctor
->expr
2343 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2345 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2346 "component %qs in structure constructor at %L",
2347 comp
->name
, &ctor
->expr
->where
);
2356 check_init_expr_arguments (gfc_expr
*e
)
2358 gfc_actual_arglist
*ap
;
2360 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2361 if (!gfc_check_init_expr (ap
->expr
))
2367 static bool check_restricted (gfc_expr
*);
2369 /* F95, 7.1.6.1, Initialization expressions, (7)
2370 F2003, 7.1.7 Initialization expression, (8) */
2373 check_inquiry (gfc_expr
*e
, int not_restricted
)
2376 const char *const *functions
;
2378 static const char *const inquiry_func_f95
[] = {
2379 "lbound", "shape", "size", "ubound",
2380 "bit_size", "len", "kind",
2381 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2382 "precision", "radix", "range", "tiny",
2386 static const char *const inquiry_func_f2003
[] = {
2387 "lbound", "shape", "size", "ubound",
2388 "bit_size", "len", "kind",
2389 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2390 "precision", "radix", "range", "tiny",
2395 gfc_actual_arglist
*ap
;
2397 if (!e
->value
.function
.isym
2398 || !e
->value
.function
.isym
->inquiry
)
2401 /* An undeclared parameter will get us here (PR25018). */
2402 if (e
->symtree
== NULL
)
2405 if (e
->symtree
->n
.sym
->from_intmod
)
2407 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2408 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2409 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2412 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2413 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2418 name
= e
->symtree
->n
.sym
->name
;
2420 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2421 ? inquiry_func_f2003
: inquiry_func_f95
;
2423 for (i
= 0; functions
[i
]; i
++)
2424 if (strcmp (functions
[i
], name
) == 0)
2427 if (functions
[i
] == NULL
)
2431 /* At this point we have an inquiry function with a variable argument. The
2432 type of the variable might be undefined, but we need it now, because the
2433 arguments of these functions are not allowed to be undefined. */
2435 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2440 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2442 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2443 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2446 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2449 /* Assumed character length will not reduce to a constant expression
2450 with LEN, as required by the standard. */
2451 if (i
== 5 && not_restricted
&& ap
->expr
->symtree
2452 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2453 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2454 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2456 gfc_error ("Assumed or deferred character length variable %qs "
2457 "in constant expression at %L",
2458 ap
->expr
->symtree
->n
.sym
->name
,
2462 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2465 if (not_restricted
== 0
2466 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2467 && !check_restricted (ap
->expr
))
2470 if (not_restricted
== 0
2471 && ap
->expr
->expr_type
== EXPR_VARIABLE
2472 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2473 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2481 /* F95, 7.1.6.1, Initialization expressions, (5)
2482 F2003, 7.1.7 Initialization expression, (5) */
2485 check_transformational (gfc_expr
*e
)
2487 static const char * const trans_func_f95
[] = {
2488 "repeat", "reshape", "selected_int_kind",
2489 "selected_real_kind", "transfer", "trim", NULL
2492 static const char * const trans_func_f2003
[] = {
2493 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2494 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2495 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2496 "trim", "unpack", NULL
2501 const char *const *functions
;
2503 if (!e
->value
.function
.isym
2504 || !e
->value
.function
.isym
->transformational
)
2507 name
= e
->symtree
->n
.sym
->name
;
2509 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2510 ? trans_func_f2003
: trans_func_f95
;
2512 /* NULL() is dealt with below. */
2513 if (strcmp ("null", name
) == 0)
2516 for (i
= 0; functions
[i
]; i
++)
2517 if (strcmp (functions
[i
], name
) == 0)
2520 if (functions
[i
] == NULL
)
2522 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2523 "in an initialization expression", name
, &e
->where
);
2527 return check_init_expr_arguments (e
);
2531 /* F95, 7.1.6.1, Initialization expressions, (6)
2532 F2003, 7.1.7 Initialization expression, (6) */
2535 check_null (gfc_expr
*e
)
2537 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2540 return check_init_expr_arguments (e
);
2545 check_elemental (gfc_expr
*e
)
2547 if (!e
->value
.function
.isym
2548 || !e
->value
.function
.isym
->elemental
)
2551 if (e
->ts
.type
!= BT_INTEGER
2552 && e
->ts
.type
!= BT_CHARACTER
2553 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2554 "initialization expression at %L", &e
->where
))
2557 return check_init_expr_arguments (e
);
2562 check_conversion (gfc_expr
*e
)
2564 if (!e
->value
.function
.isym
2565 || !e
->value
.function
.isym
->conversion
)
2568 return check_init_expr_arguments (e
);
2572 /* Verify that an expression is an initialization expression. A side
2573 effect is that the expression tree is reduced to a single constant
2574 node if all goes well. This would normally happen when the
2575 expression is constructed but function references are assumed to be
2576 intrinsics in the context of initialization expressions. If
2577 false is returned an error message has been generated. */
2580 gfc_check_init_expr (gfc_expr
*e
)
2588 switch (e
->expr_type
)
2591 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2593 t
= gfc_simplify_expr (e
, 0);
2602 gfc_intrinsic_sym
* isym
= NULL
;
2603 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2605 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2606 IEEE_EXCEPTIONS modules. */
2607 int mod
= sym
->from_intmod
;
2608 if (mod
== INTMOD_NONE
&& sym
->generic
)
2609 mod
= sym
->generic
->sym
->from_intmod
;
2610 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2612 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2615 gfc_replace_expr (e
, new_expr
);
2621 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2622 into an array constructor, we need to skip the error check here.
2623 Conversion errors are caught below in scalarize_intrinsic_call. */
2624 conversion
= e
->value
.function
.isym
2625 && (e
->value
.function
.isym
->conversion
== 1);
2627 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2628 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2630 gfc_error ("Function %qs in initialization expression at %L "
2631 "must be an intrinsic function",
2632 e
->symtree
->n
.sym
->name
, &e
->where
);
2636 if ((m
= check_conversion (e
)) == MATCH_NO
2637 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2638 && (m
= check_null (e
)) == MATCH_NO
2639 && (m
= check_transformational (e
)) == MATCH_NO
2640 && (m
= check_elemental (e
)) == MATCH_NO
)
2642 gfc_error ("Intrinsic function %qs at %L is not permitted "
2643 "in an initialization expression",
2644 e
->symtree
->n
.sym
->name
, &e
->where
);
2648 if (m
== MATCH_ERROR
)
2651 /* Try to scalarize an elemental intrinsic function that has an
2653 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2654 if (isym
&& isym
->elemental
2655 && (t
= scalarize_intrinsic_call (e
, true)))
2660 t
= gfc_simplify_expr (e
, 0);
2667 /* This occurs when parsing pdt templates. */
2668 if (gfc_expr_attr (e
).pdt_kind
)
2671 if (gfc_check_iter_variable (e
))
2674 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2676 /* A PARAMETER shall not be used to define itself, i.e.
2677 REAL, PARAMETER :: x = transfer(0, x)
2679 if (!e
->symtree
->n
.sym
->value
)
2681 gfc_error ("PARAMETER %qs is used at %L before its definition "
2682 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2686 t
= simplify_parameter_variable (e
, 0);
2691 if (gfc_in_match_data ())
2696 if (e
->symtree
->n
.sym
->as
)
2698 switch (e
->symtree
->n
.sym
->as
->type
)
2700 case AS_ASSUMED_SIZE
:
2701 gfc_error ("Assumed size array %qs at %L is not permitted "
2702 "in an initialization expression",
2703 e
->symtree
->n
.sym
->name
, &e
->where
);
2706 case AS_ASSUMED_SHAPE
:
2707 gfc_error ("Assumed shape array %qs at %L is not permitted "
2708 "in an initialization expression",
2709 e
->symtree
->n
.sym
->name
, &e
->where
);
2713 gfc_error ("Deferred array %qs at %L is not permitted "
2714 "in an initialization expression",
2715 e
->symtree
->n
.sym
->name
, &e
->where
);
2719 gfc_error ("Array %qs at %L is a variable, which does "
2720 "not reduce to a constant expression",
2721 e
->symtree
->n
.sym
->name
, &e
->where
);
2729 gfc_error ("Parameter %qs at %L has not been declared or is "
2730 "a variable, which does not reduce to a constant "
2731 "expression", e
->symtree
->name
, &e
->where
);
2740 case EXPR_SUBSTRING
:
2743 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2747 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2749 t
= gfc_simplify_expr (e
, 0);
2755 case EXPR_STRUCTURE
:
2756 t
= e
->ts
.is_iso_c
? true : false;
2760 t
= check_alloc_comp_init (e
);
2764 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2771 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2775 t
= gfc_expand_constructor (e
, true);
2779 t
= gfc_check_constructor_type (e
);
2783 gfc_internal_error ("check_init_expr(): Unknown expression type");
2789 /* Reduces a general expression to an initialization expression (a constant).
2790 This used to be part of gfc_match_init_expr.
2791 Note that this function doesn't free the given expression on false. */
2794 gfc_reduce_init_expr (gfc_expr
*expr
)
2798 gfc_init_expr_flag
= true;
2799 t
= gfc_resolve_expr (expr
);
2801 t
= gfc_check_init_expr (expr
);
2802 gfc_init_expr_flag
= false;
2807 if (expr
->expr_type
== EXPR_ARRAY
)
2809 if (!gfc_check_constructor_type (expr
))
2811 if (!gfc_expand_constructor (expr
, true))
2819 /* Match an initialization expression. We work by first matching an
2820 expression, then reducing it to a constant. */
2823 gfc_match_init_expr (gfc_expr
**result
)
2831 gfc_init_expr_flag
= true;
2833 m
= gfc_match_expr (&expr
);
2836 gfc_init_expr_flag
= false;
2840 if (gfc_derived_parameter_expr (expr
))
2843 gfc_init_expr_flag
= false;
2847 t
= gfc_reduce_init_expr (expr
);
2850 gfc_free_expr (expr
);
2851 gfc_init_expr_flag
= false;
2856 gfc_init_expr_flag
= false;
2862 /* Given an actual argument list, test to see that each argument is a
2863 restricted expression and optionally if the expression type is
2864 integer or character. */
2867 restricted_args (gfc_actual_arglist
*a
)
2869 for (; a
; a
= a
->next
)
2871 if (!check_restricted (a
->expr
))
2879 /************* Restricted/specification expressions *************/
2882 /* Make sure a non-intrinsic function is a specification function,
2883 * see F08:7.1.11.5. */
2886 external_spec_function (gfc_expr
*e
)
2890 f
= e
->value
.function
.esym
;
2892 /* IEEE functions allowed are "a reference to a transformational function
2893 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2894 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2895 IEEE_EXCEPTIONS". */
2896 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2897 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2899 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2900 || !strcmp (f
->name
, "ieee_support_rounding")
2901 || !strcmp (f
->name
, "ieee_support_flag")
2902 || !strcmp (f
->name
, "ieee_support_halting")
2903 || !strcmp (f
->name
, "ieee_support_datatype")
2904 || !strcmp (f
->name
, "ieee_support_denormal")
2905 || !strcmp (f
->name
, "ieee_support_divide")
2906 || !strcmp (f
->name
, "ieee_support_inf")
2907 || !strcmp (f
->name
, "ieee_support_io")
2908 || !strcmp (f
->name
, "ieee_support_nan")
2909 || !strcmp (f
->name
, "ieee_support_sqrt")
2910 || !strcmp (f
->name
, "ieee_support_standard")
2911 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2912 goto function_allowed
;
2915 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2917 gfc_error ("Specification function %qs at %L cannot be a statement "
2918 "function", f
->name
, &e
->where
);
2922 if (f
->attr
.proc
== PROC_INTERNAL
)
2924 gfc_error ("Specification function %qs at %L cannot be an internal "
2925 "function", f
->name
, &e
->where
);
2929 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2931 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2937 if (f
->attr
.recursive
2938 && !gfc_notify_std (GFC_STD_F2003
,
2939 "Specification function %qs "
2940 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2944 return restricted_args (e
->value
.function
.actual
);
2948 /* Check to see that a function reference to an intrinsic is a
2949 restricted expression. */
2952 restricted_intrinsic (gfc_expr
*e
)
2954 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2955 if (check_inquiry (e
, 0) == MATCH_YES
)
2958 return restricted_args (e
->value
.function
.actual
);
2962 /* Check the expressions of an actual arglist. Used by check_restricted. */
2965 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2967 for (; arg
; arg
= arg
->next
)
2968 if (!checker (arg
->expr
))
2975 /* Check the subscription expressions of a reference chain with a checking
2976 function; used by check_restricted. */
2979 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2989 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2991 if (!checker (ref
->u
.ar
.start
[dim
]))
2993 if (!checker (ref
->u
.ar
.end
[dim
]))
2995 if (!checker (ref
->u
.ar
.stride
[dim
]))
3001 /* Nothing needed, just proceed to next reference. */
3005 if (!checker (ref
->u
.ss
.start
))
3007 if (!checker (ref
->u
.ss
.end
))
3016 return check_references (ref
->next
, checker
);
3019 /* Return true if ns is a parent of the current ns. */
3022 is_parent_of_current_ns (gfc_namespace
*ns
)
3025 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3032 /* Verify that an expression is a restricted expression. Like its
3033 cousin check_init_expr(), an error message is generated if we
3037 check_restricted (gfc_expr
*e
)
3045 switch (e
->expr_type
)
3048 t
= check_intrinsic_op (e
, check_restricted
);
3050 t
= gfc_simplify_expr (e
, 0);
3055 if (e
->value
.function
.esym
)
3057 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3059 t
= external_spec_function (e
);
3063 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3066 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3069 t
= restricted_intrinsic (e
);
3074 sym
= e
->symtree
->n
.sym
;
3077 /* If a dummy argument appears in a context that is valid for a
3078 restricted expression in an elemental procedure, it will have
3079 already been simplified away once we get here. Therefore we
3080 don't need to jump through hoops to distinguish valid from
3082 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3083 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3085 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3086 sym
->name
, &e
->where
);
3090 if (sym
->attr
.optional
)
3092 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3093 sym
->name
, &e
->where
);
3097 if (sym
->attr
.intent
== INTENT_OUT
)
3099 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3100 sym
->name
, &e
->where
);
3104 /* Check reference chain if any. */
3105 if (!check_references (e
->ref
, &check_restricted
))
3108 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3109 processed in resolve.c(resolve_formal_arglist). This is done so
3110 that host associated dummy array indices are accepted (PR23446).
3111 This mechanism also does the same for the specification expressions
3112 of array-valued functions. */
3114 || sym
->attr
.in_common
3115 || sym
->attr
.use_assoc
3117 || sym
->attr
.implied_index
3118 || sym
->attr
.flavor
== FL_PARAMETER
3119 || is_parent_of_current_ns (sym
->ns
)
3120 || (sym
->ns
->proc_name
!= NULL
3121 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3122 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3128 gfc_error ("Variable %qs cannot appear in the expression at %L",
3129 sym
->name
, &e
->where
);
3130 /* Prevent a repetition of the error. */
3139 case EXPR_SUBSTRING
:
3140 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3144 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3146 t
= gfc_simplify_expr (e
, 0);
3150 case EXPR_STRUCTURE
:
3151 t
= gfc_check_constructor (e
, check_restricted
);
3155 t
= gfc_check_constructor (e
, check_restricted
);
3159 gfc_internal_error ("check_restricted(): Unknown expression type");
3166 /* Check to see that an expression is a specification expression. If
3167 we return false, an error has been generated. */
3170 gfc_specification_expr (gfc_expr
*e
)
3172 gfc_component
*comp
;
3177 if (e
->ts
.type
!= BT_INTEGER
)
3179 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3180 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3184 comp
= gfc_get_proc_ptr_comp (e
);
3185 if (e
->expr_type
== EXPR_FUNCTION
3186 && !e
->value
.function
.isym
3187 && !e
->value
.function
.esym
3188 && !gfc_pure (e
->symtree
->n
.sym
)
3189 && (!comp
|| !comp
->attr
.pure
))
3191 gfc_error ("Function %qs at %L must be PURE",
3192 e
->symtree
->n
.sym
->name
, &e
->where
);
3193 /* Prevent repeat error messages. */
3194 e
->symtree
->n
.sym
->attr
.pure
= 1;
3200 gfc_error ("Expression at %L must be scalar", &e
->where
);
3204 if (!gfc_simplify_expr (e
, 0))
3207 return check_restricted (e
);
3211 /************** Expression conformance checks. *************/
3213 /* Given two expressions, make sure that the arrays are conformable. */
3216 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3218 int op1_flag
, op2_flag
, d
;
3219 mpz_t op1_size
, op2_size
;
3225 if (op1
->rank
== 0 || op2
->rank
== 0)
3228 va_start (argp
, optype_msgid
);
3229 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3232 if (op1
->rank
!= op2
->rank
)
3234 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3235 op1
->rank
, op2
->rank
, &op1
->where
);
3241 for (d
= 0; d
< op1
->rank
; d
++)
3243 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3244 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3246 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3248 gfc_error ("Different shape for %s at %L on dimension %d "
3249 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3250 (int) mpz_get_si (op1_size
),
3251 (int) mpz_get_si (op2_size
));
3257 mpz_clear (op1_size
);
3259 mpz_clear (op2_size
);
3269 /* Given an assignable expression and an arbitrary expression, make
3270 sure that the assignment can take place. Only add a call to the intrinsic
3271 conversion routines, when allow_convert is set. When this assign is a
3272 coarray call, then the convert is done by the coarray routine implictly and
3273 adding the intrinsic conversion would do harm in most cases. */
3276 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3283 sym
= lvalue
->symtree
->n
.sym
;
3285 /* See if this is the component or subcomponent of a pointer. */
3286 has_pointer
= sym
->attr
.pointer
;
3287 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3288 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3294 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3295 variable local to a function subprogram. Its existence begins when
3296 execution of the function is initiated and ends when execution of the
3297 function is terminated...
3298 Therefore, the left hand side is no longer a variable, when it is: */
3299 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3300 && !sym
->attr
.external
)
3305 /* (i) Use associated; */
3306 if (sym
->attr
.use_assoc
)
3309 /* (ii) The assignment is in the main program; or */
3310 if (gfc_current_ns
->proc_name
3311 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3314 /* (iii) A module or internal procedure... */
3315 if (gfc_current_ns
->proc_name
3316 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3317 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3318 && gfc_current_ns
->parent
3319 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3320 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3321 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3323 /* ... that is not a function... */
3324 if (gfc_current_ns
->proc_name
3325 && !gfc_current_ns
->proc_name
->attr
.function
)
3328 /* ... or is not an entry and has a different name. */
3329 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3333 /* (iv) Host associated and not the function symbol or the
3334 parent result. This picks up sibling references, which
3335 cannot be entries. */
3336 if (!sym
->attr
.entry
3337 && sym
->ns
== gfc_current_ns
->parent
3338 && sym
!= gfc_current_ns
->proc_name
3339 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3344 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3349 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3351 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3352 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3356 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3358 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3363 if (rvalue
->expr_type
== EXPR_NULL
)
3365 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3366 && lvalue
->symtree
->n
.sym
->attr
.data
)
3370 gfc_error ("NULL appears on right-hand side in assignment at %L",
3376 /* This is possibly a typo: x = f() instead of x => f(). */
3378 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3379 gfc_warning (OPT_Wsurprising
,
3380 "POINTER-valued function appears on right-hand side of "
3381 "assignment at %L", &rvalue
->where
);
3383 /* Check size of array assignments. */
3384 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3385 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3388 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3389 && lvalue
->symtree
->n
.sym
->attr
.data
3390 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3391 "initialize non-integer variable %qs",
3392 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3394 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3395 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3396 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3400 /* Handle the case of a BOZ literal on the RHS. */
3401 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3404 if (warn_surprising
)
3405 gfc_warning (OPT_Wsurprising
,
3406 "BOZ literal at %L is bitwise transferred "
3407 "non-integer symbol %qs", &rvalue
->where
,
3408 lvalue
->symtree
->n
.sym
->name
);
3409 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3411 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3413 if (rc
== ARITH_UNDERFLOW
)
3414 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3415 ". This check can be disabled with the option "
3416 "%<-fno-range-check%>", &rvalue
->where
);
3417 else if (rc
== ARITH_OVERFLOW
)
3418 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3419 ". This check can be disabled with the option "
3420 "%<-fno-range-check%>", &rvalue
->where
);
3421 else if (rc
== ARITH_NAN
)
3422 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3423 ". This check can be disabled with the option "
3424 "%<-fno-range-check%>", &rvalue
->where
);
3429 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3431 gfc_error ("The assignment to a KIND or LEN component of a "
3432 "parameterized type at %L is not allowed",
3437 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3440 /* Only DATA Statements come here. */
3445 /* Numeric can be converted to any other numeric. And Hollerith can be
3446 converted to any other type. */
3447 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3448 || rvalue
->ts
.type
== BT_HOLLERITH
)
3451 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3454 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3455 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3456 "conversion of %s to %s", where
,
3457 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3462 /* Assignment is the only case where character variables of different
3463 kind values can be converted into one another. */
3464 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3466 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3467 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3475 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3479 /* Check that a pointer assignment is OK. We first check lvalue, and
3480 we only check rvalue if it's not an assignment to NULL() or a
3481 NULLIFY statement. */
3484 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3486 symbol_attribute attr
, lhs_attr
;
3488 bool is_pure
, is_implicit_pure
, rank_remap
;
3491 lhs_attr
= gfc_expr_attr (lvalue
);
3492 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3494 gfc_error ("Pointer assignment target is not a POINTER at %L",
3499 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3500 && !lhs_attr
.proc_pointer
)
3502 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3503 "l-value since it is a procedure",
3504 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3508 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3511 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3513 if (ref
->type
== REF_COMPONENT
)
3514 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3516 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3520 if (ref
->u
.ar
.type
== AR_FULL
)
3523 if (ref
->u
.ar
.type
!= AR_SECTION
)
3525 gfc_error ("Expected bounds specification for %qs at %L",
3526 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3530 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3531 "for %qs in pointer assignment at %L",
3532 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3535 /* When bounds are given, all lbounds are necessary and either all
3536 or none of the upper bounds; no strides are allowed. If the
3537 upper bounds are present, we may do rank remapping. */
3538 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3540 if (!ref
->u
.ar
.start
[dim
]
3541 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3543 gfc_error ("Lower bound has to be present at %L",
3547 if (ref
->u
.ar
.stride
[dim
])
3549 gfc_error ("Stride must not be present at %L",
3555 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3558 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3559 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3561 gfc_error ("Either all or none of the upper bounds"
3562 " must be specified at %L", &lvalue
->where
);
3570 is_pure
= gfc_pure (NULL
);
3571 is_implicit_pure
= gfc_implicit_pure (NULL
);
3573 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3574 kind, etc for lvalue and rvalue must match, and rvalue must be a
3575 pure variable if we're in a pure function. */
3576 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3579 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3580 if (lvalue
->expr_type
== EXPR_VARIABLE
3581 && gfc_is_coindexed (lvalue
))
3584 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3585 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3587 gfc_error ("Pointer object at %L shall not have a coindex",
3593 /* Checks on rvalue for procedure pointer assignments. */
3598 gfc_component
*comp1
, *comp2
;
3601 attr
= gfc_expr_attr (rvalue
);
3602 if (!((rvalue
->expr_type
== EXPR_NULL
)
3603 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3604 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3605 || (rvalue
->expr_type
== EXPR_VARIABLE
3606 && attr
.flavor
== FL_PROCEDURE
)))
3608 gfc_error ("Invalid procedure pointer assignment at %L",
3612 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3614 /* Check for intrinsics. */
3615 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3616 if (!sym
->attr
.intrinsic
3617 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3618 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3620 sym
->attr
.intrinsic
= 1;
3621 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3622 attr
= gfc_expr_attr (rvalue
);
3624 /* Check for result of embracing function. */
3625 if (sym
->attr
.function
&& sym
->result
== sym
)
3629 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3630 if (sym
== ns
->proc_name
)
3632 gfc_error ("Function result %qs is invalid as proc-target "
3633 "in procedure pointer assignment at %L",
3634 sym
->name
, &rvalue
->where
);
3641 gfc_error ("Abstract interface %qs is invalid "
3642 "in procedure pointer assignment at %L",
3643 rvalue
->symtree
->name
, &rvalue
->where
);
3646 /* Check for F08:C729. */
3647 if (attr
.flavor
== FL_PROCEDURE
)
3649 if (attr
.proc
== PROC_ST_FUNCTION
)
3651 gfc_error ("Statement function %qs is invalid "
3652 "in procedure pointer assignment at %L",
3653 rvalue
->symtree
->name
, &rvalue
->where
);
3656 if (attr
.proc
== PROC_INTERNAL
&&
3657 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3658 "is invalid in procedure pointer assignment "
3659 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3661 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3662 attr
.subroutine
) == 0)
3664 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3665 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3669 /* Check for F08:C730. */
3670 if (attr
.elemental
&& !attr
.intrinsic
)
3672 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3673 "in procedure pointer assignment at %L",
3674 rvalue
->symtree
->name
, &rvalue
->where
);
3678 /* Ensure that the calling convention is the same. As other attributes
3679 such as DLLEXPORT may differ, one explicitly only tests for the
3680 calling conventions. */
3681 if (rvalue
->expr_type
== EXPR_VARIABLE
3682 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3683 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3685 symbol_attribute calls
;
3688 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3689 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3690 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3692 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3693 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3695 gfc_error ("Mismatch in the procedure pointer assignment "
3696 "at %L: mismatch in the calling convention",
3702 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3704 s1
= comp1
->ts
.interface
;
3707 s1
= lvalue
->symtree
->n
.sym
;
3708 if (s1
->ts
.interface
)
3709 s1
= s1
->ts
.interface
;
3712 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3715 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3717 s2
= comp2
->ts
.interface
->result
;
3722 s2
= comp2
->ts
.interface
;
3726 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3728 if (rvalue
->value
.function
.esym
)
3729 s2
= rvalue
->value
.function
.esym
->result
;
3731 s2
= rvalue
->symtree
->n
.sym
->result
;
3737 s2
= rvalue
->symtree
->n
.sym
;
3741 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3742 s2
= s2
->ts
.interface
;
3744 /* Special check for the case of absent interface on the lvalue.
3745 * All other interface checks are done below. */
3746 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3748 gfc_error ("Interface mismatch in procedure pointer assignment "
3749 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
3753 /* F08:7.2.2.4 (4) */
3754 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3758 gfc_error ("Explicit interface required for component %qs at %L: %s",
3759 comp1
->name
, &lvalue
->where
, err
);
3762 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
3764 gfc_error ("Explicit interface required for %qs at %L: %s",
3765 s1
->name
, &lvalue
->where
, err
);
3769 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3773 gfc_error ("Explicit interface required for component %qs at %L: %s",
3774 comp2
->name
, &rvalue
->where
, err
);
3777 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
3779 gfc_error ("Explicit interface required for %qs at %L: %s",
3780 s2
->name
, &rvalue
->where
, err
);
3785 if (s1
== s2
|| !s1
|| !s2
)
3788 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3789 err
, sizeof(err
), NULL
, NULL
))
3791 gfc_error ("Interface mismatch in procedure pointer assignment "
3792 "at %L: %s", &rvalue
->where
, err
);
3796 /* Check F2008Cor2, C729. */
3797 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3798 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3800 gfc_error ("Procedure pointer target %qs at %L must be either an "
3801 "intrinsic, host or use associated, referenced or have "
3802 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3809 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3811 /* Check for F03:C717. */
3812 if (UNLIMITED_POLY (rvalue
)
3813 && !(UNLIMITED_POLY (lvalue
)
3814 || (lvalue
->ts
.type
== BT_DERIVED
3815 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3816 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3817 gfc_error ("Data-pointer-object at %L must be unlimited "
3818 "polymorphic, or of a type with the BIND or SEQUENCE "
3819 "attribute, to be compatible with an unlimited "
3820 "polymorphic target", &lvalue
->where
);
3822 gfc_error ("Different types in pointer assignment at %L; "
3823 "attempted assignment of %s to %s", &lvalue
->where
,
3824 gfc_typename (&rvalue
->ts
),
3825 gfc_typename (&lvalue
->ts
));
3829 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3831 gfc_error ("Different kind type parameters in pointer "
3832 "assignment at %L", &lvalue
->where
);
3836 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3838 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3842 /* Make sure the vtab is present. */
3843 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3844 gfc_find_vtab (&rvalue
->ts
);
3846 /* Check rank remapping. */
3851 /* If this can be determined, check that the target must be at least as
3852 large as the pointer assigned to it is. */
3853 if (gfc_array_size (lvalue
, &lsize
)
3854 && gfc_array_size (rvalue
, &rsize
)
3855 && mpz_cmp (rsize
, lsize
) < 0)
3857 gfc_error ("Rank remapping target is smaller than size of the"
3858 " pointer (%ld < %ld) at %L",
3859 mpz_get_si (rsize
), mpz_get_si (lsize
),
3864 /* The target must be either rank one or it must be simply contiguous
3865 and F2008 must be allowed. */
3866 if (rvalue
->rank
!= 1)
3868 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3870 gfc_error ("Rank remapping target must be rank 1 or"
3871 " simply contiguous at %L", &rvalue
->where
);
3874 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3875 "rank 1 at %L", &rvalue
->where
))
3880 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3881 if (rvalue
->expr_type
== EXPR_NULL
)
3884 if (lvalue
->ts
.type
== BT_CHARACTER
)
3886 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3891 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3892 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3894 attr
= gfc_expr_attr (rvalue
);
3896 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3898 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
3899 to caf_get. Map this to the same error message as below when it is
3900 still a variable expression. */
3901 if (rvalue
->value
.function
.isym
3902 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3903 /* The test above might need to be extend when F08, Note 5.4 has to be
3904 interpreted in the way that target and pointer with the same coindex
3906 gfc_error ("Data target at %L shall not have a coindex",
3909 gfc_error ("Target expression in pointer assignment "
3910 "at %L must deliver a pointer result",
3915 if (!attr
.target
&& !attr
.pointer
)
3917 gfc_error ("Pointer assignment target is neither TARGET "
3918 "nor POINTER at %L", &rvalue
->where
);
3922 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3924 gfc_error ("Bad target in pointer assignment in PURE "
3925 "procedure at %L", &rvalue
->where
);
3928 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3929 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3931 if (gfc_has_vector_index (rvalue
))
3933 gfc_error ("Pointer assignment with vector subscript "
3934 "on rhs at %L", &rvalue
->where
);
3938 if (attr
.is_protected
&& attr
.use_assoc
3939 && !(attr
.pointer
|| attr
.proc_pointer
))
3941 gfc_error ("Pointer assignment target has PROTECTED "
3942 "attribute at %L", &rvalue
->where
);
3946 /* F2008, C725. For PURE also C1283. */
3947 if (rvalue
->expr_type
== EXPR_VARIABLE
3948 && gfc_is_coindexed (rvalue
))
3951 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3952 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3954 gfc_error ("Data target at %L shall not have a coindex",
3960 /* Warn for assignments of contiguous pointers to targets which is not
3961 contiguous. Be lenient in the definition of what counts as
3964 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
3965 gfc_warning (OPT_Wextra
, "Assignment to contiguous pointer from "
3966 "non-contiguous target at %L", &rvalue
->where
);
3968 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3969 if (warn_target_lifetime
3970 && rvalue
->expr_type
== EXPR_VARIABLE
3971 && !rvalue
->symtree
->n
.sym
->attr
.save
3972 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
3973 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3974 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3975 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3976 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3981 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3982 || lvalue
->symtree
->n
.sym
->attr
.result
3983 || lvalue
->symtree
->n
.sym
->attr
.function
3984 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3985 && lvalue
->symtree
->n
.sym
->ns
3986 != rvalue
->symtree
->n
.sym
->ns
)
3987 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3988 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3990 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3991 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3992 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3993 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3994 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3996 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
4003 gfc_warning (OPT_Wtarget_lifetime
,
4004 "Pointer at %L in pointer assignment might outlive the "
4005 "pointer target", &lvalue
->where
);
4012 /* Relative of gfc_check_assign() except that the lvalue is a single
4013 symbol. Used for initialization assignments. */
4016 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
4020 bool pointer
, proc_pointer
;
4022 memset (&lvalue
, '\0', sizeof (gfc_expr
));
4024 lvalue
.expr_type
= EXPR_VARIABLE
;
4025 lvalue
.ts
= sym
->ts
;
4027 lvalue
.rank
= sym
->as
->rank
;
4028 lvalue
.symtree
= XCNEW (gfc_symtree
);
4029 lvalue
.symtree
->n
.sym
= sym
;
4030 lvalue
.where
= sym
->declared_at
;
4034 lvalue
.ref
= gfc_get_ref ();
4035 lvalue
.ref
->type
= REF_COMPONENT
;
4036 lvalue
.ref
->u
.c
.component
= comp
;
4037 lvalue
.ref
->u
.c
.sym
= sym
;
4038 lvalue
.ts
= comp
->ts
;
4039 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4040 lvalue
.where
= comp
->loc
;
4041 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4042 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4043 proc_pointer
= comp
->attr
.proc_pointer
;
4047 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4048 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4049 proc_pointer
= sym
->attr
.proc_pointer
;
4052 if (pointer
|| proc_pointer
)
4053 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
4056 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4057 into an array constructor, we should check if it can be reduced
4058 as an initialization expression. */
4059 if (rvalue
->expr_type
== EXPR_FUNCTION
4060 && rvalue
->value
.function
.isym
4061 && (rvalue
->value
.function
.isym
->conversion
== 1))
4062 gfc_check_init_expr (rvalue
);
4064 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4067 free (lvalue
.symtree
);
4073 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4075 /* F08:C461. Additional checks for pointer initialization. */
4076 symbol_attribute attr
;
4077 attr
= gfc_expr_attr (rvalue
);
4078 if (attr
.allocatable
)
4080 gfc_error ("Pointer initialization target at %L "
4081 "must not be ALLOCATABLE", &rvalue
->where
);
4084 if (!attr
.target
|| attr
.pointer
)
4086 gfc_error ("Pointer initialization target at %L "
4087 "must have the TARGET attribute", &rvalue
->where
);
4091 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4092 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4093 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4095 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4096 attr
.save
= SAVE_IMPLICIT
;
4101 gfc_error ("Pointer initialization target at %L "
4102 "must have the SAVE attribute", &rvalue
->where
);
4107 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4109 /* F08:C1220. Additional checks for procedure pointer initialization. */
4110 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4111 if (attr
.proc_pointer
)
4113 gfc_error ("Procedure pointer initialization target at %L "
4114 "may not be a procedure pointer", &rvalue
->where
);
4122 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4123 * require that an expression be built. */
4126 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4128 return gfc_build_init_expr (ts
, where
, false);
4131 /* Build an initializer for a local integer, real, complex, logical, or
4132 character variable, based on the command line flags finit-local-zero,
4133 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4134 With force, an initializer is ALWAYS generated. */
4137 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4139 gfc_expr
*init_expr
;
4141 /* Try to build an initializer expression. */
4142 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4144 /* If we want to force generation, make sure we default to zero. */
4145 gfc_init_local_real init_real
= flag_init_real
;
4146 int init_logical
= gfc_option
.flag_init_logical
;
4149 if (init_real
== GFC_INIT_REAL_OFF
)
4150 init_real
= GFC_INIT_REAL_ZERO
;
4151 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4152 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4155 /* We will only initialize integers, reals, complex, logicals, and
4156 characters, and only if the corresponding command-line flags
4157 were set. Otherwise, we free init_expr and return null. */
4161 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4162 mpz_set_si (init_expr
->value
.integer
,
4163 gfc_option
.flag_init_integer_value
);
4166 gfc_free_expr (init_expr
);
4174 case GFC_INIT_REAL_SNAN
:
4175 init_expr
->is_snan
= 1;
4177 case GFC_INIT_REAL_NAN
:
4178 mpfr_set_nan (init_expr
->value
.real
);
4181 case GFC_INIT_REAL_INF
:
4182 mpfr_set_inf (init_expr
->value
.real
, 1);
4185 case GFC_INIT_REAL_NEG_INF
:
4186 mpfr_set_inf (init_expr
->value
.real
, -1);
4189 case GFC_INIT_REAL_ZERO
:
4190 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4194 gfc_free_expr (init_expr
);
4203 case GFC_INIT_REAL_SNAN
:
4204 init_expr
->is_snan
= 1;
4206 case GFC_INIT_REAL_NAN
:
4207 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4208 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4211 case GFC_INIT_REAL_INF
:
4212 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4213 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4216 case GFC_INIT_REAL_NEG_INF
:
4217 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4218 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4221 case GFC_INIT_REAL_ZERO
:
4222 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4226 gfc_free_expr (init_expr
);
4233 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4234 init_expr
->value
.logical
= 0;
4235 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4236 init_expr
->value
.logical
= 1;
4239 gfc_free_expr (init_expr
);
4245 /* For characters, the length must be constant in order to
4246 create a default initializer. */
4247 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4249 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4251 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4252 init_expr
->value
.character
.length
= char_len
;
4253 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4254 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4255 init_expr
->value
.character
.string
[i
]
4256 = (unsigned char) gfc_option
.flag_init_character_value
;
4260 gfc_free_expr (init_expr
);
4264 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4265 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4267 gfc_actual_arglist
*arg
;
4268 init_expr
= gfc_get_expr ();
4269 init_expr
->where
= *where
;
4270 init_expr
->ts
= *ts
;
4271 init_expr
->expr_type
= EXPR_FUNCTION
;
4272 init_expr
->value
.function
.isym
=
4273 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4274 init_expr
->value
.function
.name
= "repeat";
4275 arg
= gfc_get_actual_arglist ();
4276 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4277 arg
->expr
->value
.character
.string
[0] =
4278 gfc_option
.flag_init_character_value
;
4279 arg
->next
= gfc_get_actual_arglist ();
4280 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4281 init_expr
->value
.function
.actual
= arg
;
4286 gfc_free_expr (init_expr
);
4293 /* Apply an initialization expression to a typespec. Can be used for symbols or
4294 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4295 combined with some effort. */
4298 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4300 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4302 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4304 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4305 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4306 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4308 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4310 if (init
->expr_type
== EXPR_CONSTANT
)
4311 gfc_set_constant_character_len (len
, init
, -1);
4313 && init
->ts
.type
== BT_CHARACTER
4314 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4315 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4316 init
->ts
.u
.cl
->length
->value
.integer
))
4318 gfc_constructor
*ctor
;
4319 ctor
= gfc_constructor_first (init
->value
.constructor
);
4323 bool has_ts
= (init
->ts
.u
.cl
4324 && init
->ts
.u
.cl
->length_from_typespec
);
4326 /* Remember the length of the first element for checking
4327 that all elements *in the constructor* have the same
4328 length. This need not be the length of the LHS! */
4329 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4330 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4331 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4333 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4334 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4336 gfc_set_constant_character_len (len
, ctor
->expr
,
4337 has_ts
? -1 : first_len
);
4338 if (!ctor
->expr
->ts
.u
.cl
)
4340 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4342 ctor
->expr
->ts
.u
.cl
->length
4343 = gfc_copy_expr (ts
->u
.cl
->length
);
4351 /* Check whether an expression is a structure constructor and whether it has
4352 other values than NULL. */
4355 is_non_empty_structure_constructor (gfc_expr
* e
)
4357 if (e
->expr_type
!= EXPR_STRUCTURE
)
4360 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4363 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4365 cons
= gfc_constructor_next (cons
);
4371 /* Check for default initializer; sym->value is not enough
4372 as it is also set for EXPR_NULL of allocatables. */
4375 gfc_has_default_initializer (gfc_symbol
*der
)
4379 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4380 for (c
= der
->components
; c
; c
= c
->next
)
4381 if (gfc_bt_struct (c
->ts
.type
))
4383 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4384 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4386 && is_non_empty_structure_constructor (c
->initializer
))
4387 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4389 if (c
->attr
.pointer
&& c
->initializer
)
4403 Generate an initializer expression which initializes the entirety of a union.
4404 A normal structure constructor is insufficient without undue effort, because
4405 components of maps may be oddly aligned/overlapped. (For example if a
4406 character is initialized from one map overtop a real from the other, only one
4407 byte of the real is actually initialized.) Unfortunately we don't know the
4408 size of the union right now, so we can't generate a proper initializer, but
4409 we use a NULL expr as a placeholder and do the right thing later in
4410 gfc_trans_subcomponent_assign.
4413 generate_union_initializer (gfc_component
*un
)
4415 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4418 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4419 placeholder
->ts
= un
->ts
;
4424 /* Get the user-specified initializer for a union, if any. This means the user
4425 has said to initialize component(s) of a map. For simplicity's sake we
4426 only allow the user to initialize the first map. We don't have to worry
4427 about overlapping initializers as they are released early in resolution (see
4428 resolve_fl_struct). */
4431 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4434 gfc_expr
*init
=NULL
;
4436 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4439 for (map
= union_type
->components
; map
; map
= map
->next
)
4441 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4443 init
= gfc_default_initializer (&map
->ts
);
4457 class_allocatable (gfc_component
*comp
)
4459 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4460 && CLASS_DATA (comp
)->attr
.allocatable
;
4464 class_pointer (gfc_component
*comp
)
4466 return comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4467 && CLASS_DATA (comp
)->attr
.pointer
;
4471 comp_allocatable (gfc_component
*comp
)
4473 return comp
->attr
.allocatable
|| class_allocatable (comp
);
4477 comp_pointer (gfc_component
*comp
)
4479 return comp
->attr
.pointer
4480 || comp
->attr
.pointer
4481 || comp
->attr
.proc_pointer
4482 || comp
->attr
.class_pointer
4483 || class_pointer (comp
);
4486 /* Fetch or generate an initializer for the given component.
4487 Only generate an initializer if generate is true. */
4490 component_initializer (gfc_component
*c
, bool generate
)
4492 gfc_expr
*init
= NULL
;
4494 /* Allocatable components always get EXPR_NULL.
4495 Pointer components are only initialized when generating, and only if they
4496 do not already have an initializer. */
4497 if (comp_allocatable (c
) || (generate
&& comp_pointer (c
) && !c
->initializer
))
4499 init
= gfc_get_null_expr (&c
->loc
);
4504 /* See if we can find the initializer immediately. */
4505 if (c
->initializer
|| !generate
)
4506 return c
->initializer
;
4508 /* Recursively handle derived type components. */
4509 else if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4510 init
= gfc_generate_initializer (&c
->ts
, true);
4512 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4514 gfc_component
*map
= NULL
;
4515 gfc_constructor
*ctor
;
4516 gfc_expr
*user_init
;
4518 /* If we don't have a user initializer and we aren't generating one, this
4519 union has no initializer. */
4520 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4521 if (!user_init
&& !generate
)
4524 /* Otherwise use a structure constructor. */
4525 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4529 /* If we are to generate an initializer for the union, add a constructor
4530 which initializes the whole union first. */
4533 ctor
= gfc_constructor_get ();
4534 ctor
->expr
= generate_union_initializer (c
);
4535 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4538 /* If we found an initializer in one of our maps, apply it. Note this
4539 is applied _after_ the entire-union initializer above if any. */
4542 ctor
= gfc_constructor_get ();
4543 ctor
->expr
= user_init
;
4544 ctor
->n
.component
= map
;
4545 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4549 /* Treat simple components like locals. */
4552 /* We MUST give an initializer, so force generation. */
4553 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4554 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4561 /* Get an expression for a default initializer of a derived type. */
4564 gfc_default_initializer (gfc_typespec
*ts
)
4566 return gfc_generate_initializer (ts
, false);
4569 /* Generate an initializer expression for an iso_c_binding type
4570 such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */
4573 generate_isocbinding_initializer (gfc_symbol
*derived
)
4575 /* The initializers have already been built into the c_null_[fun]ptr symbols
4576 from gen_special_c_interop_ptr. */
4577 gfc_symtree
*npsym
= NULL
;
4578 if (0 == strcmp (derived
->name
, "c_ptr"))
4579 gfc_find_sym_tree ("c_null_ptr", gfc_current_ns
, true, &npsym
);
4580 else if (0 == strcmp (derived
->name
, "c_funptr"))
4581 gfc_find_sym_tree ("c_null_funptr", gfc_current_ns
, true, &npsym
);
4583 gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
4584 " type, expected %<c_ptr%> or %<c_funptr%>");
4587 gfc_expr
*init
= gfc_copy_expr (npsym
->n
.sym
->value
);
4588 init
->symtree
= npsym
;
4589 init
->ts
.is_iso_c
= true;
4596 /* Get or generate an expression for a default initializer of a derived type.
4597 If -finit-derived is specified, generate default initialization expressions
4598 for components that lack them when generate is set. */
4601 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4603 gfc_expr
*init
, *tmp
;
4604 gfc_component
*comp
;
4606 generate
= flag_init_derived
&& generate
;
4608 if (ts
->u
.derived
->ts
.is_iso_c
&& generate
)
4609 return generate_isocbinding_initializer (ts
->u
.derived
);
4611 /* See if we have a default initializer in this, but not in nested
4612 types (otherwise we could use gfc_has_default_initializer()).
4613 We don't need to check if we are going to generate them. */
4614 comp
= ts
->u
.derived
->components
;
4617 for (; comp
; comp
= comp
->next
)
4618 if (comp
->initializer
|| comp_allocatable (comp
))
4625 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4626 &ts
->u
.derived
->declared_at
);
4629 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4631 gfc_constructor
*ctor
= gfc_constructor_get();
4633 /* Fetch or generate an initializer for the component. */
4634 tmp
= component_initializer (comp
, generate
);
4637 /* Save the component ref for STRUCTUREs and UNIONs. */
4638 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4639 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4640 ctor
->n
.component
= comp
;
4642 /* If the initializer was not generated, we need a copy. */
4643 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4644 if ((comp
->ts
.type
!= tmp
->ts
.type
|| comp
->ts
.kind
!= tmp
->ts
.kind
)
4645 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4648 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
4654 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4661 /* Given a symbol, create an expression node with that symbol as a
4662 variable. If the symbol is array valued, setup a reference of the
4666 gfc_get_variable_expr (gfc_symtree
*var
)
4670 e
= gfc_get_expr ();
4671 e
->expr_type
= EXPR_VARIABLE
;
4673 e
->ts
= var
->n
.sym
->ts
;
4675 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4676 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4677 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4678 && CLASS_DATA (var
->n
.sym
)->as
)))
4680 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4681 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4682 e
->ref
= gfc_get_ref ();
4683 e
->ref
->type
= REF_ARRAY
;
4684 e
->ref
->u
.ar
.type
= AR_FULL
;
4685 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4686 ? CLASS_DATA (var
->n
.sym
)->as
4694 /* Adds a full array reference to an expression, as needed. */
4697 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4700 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4705 ref
->next
= gfc_get_ref ();
4710 e
->ref
= gfc_get_ref ();
4713 ref
->type
= REF_ARRAY
;
4714 ref
->u
.ar
.type
= AR_FULL
;
4715 ref
->u
.ar
.dimen
= e
->rank
;
4716 ref
->u
.ar
.where
= e
->where
;
4722 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4726 lval
= gfc_get_expr ();
4727 lval
->expr_type
= EXPR_VARIABLE
;
4728 lval
->where
= sym
->declared_at
;
4730 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4732 /* It will always be a full array. */
4733 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4734 lval
->rank
= as
? as
->rank
: 0;
4736 gfc_add_full_array_ref (lval
, as
);
4741 /* Returns the array_spec of a full array expression. A NULL is
4742 returned otherwise. */
4744 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4749 if (expr
->rank
== 0)
4752 /* Follow any component references. */
4753 if (expr
->expr_type
== EXPR_VARIABLE
4754 || expr
->expr_type
== EXPR_CONSTANT
)
4757 as
= expr
->symtree
->n
.sym
->as
;
4761 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4766 as
= ref
->u
.c
.component
->as
;
4774 switch (ref
->u
.ar
.type
)
4797 /* General expression traversal function. */
4800 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4801 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4806 gfc_actual_arglist
*args
;
4813 if ((*func
) (expr
, sym
, &f
))
4816 if (expr
->ts
.type
== BT_CHARACTER
4818 && expr
->ts
.u
.cl
->length
4819 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4820 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4823 switch (expr
->expr_type
)
4828 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4830 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4838 case EXPR_SUBSTRING
:
4841 case EXPR_STRUCTURE
:
4843 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4844 c
; c
= gfc_constructor_next (c
))
4846 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4850 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4852 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4854 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4856 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4863 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4865 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4881 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4883 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4885 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4887 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4893 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4895 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4900 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4901 && ref
->u
.c
.component
->ts
.u
.cl
4902 && ref
->u
.c
.component
->ts
.u
.cl
->length
4903 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4905 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4909 if (ref
->u
.c
.component
->as
)
4910 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4911 + ref
->u
.c
.component
->as
->corank
; i
++)
4913 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4916 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4930 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4933 expr_set_symbols_referenced (gfc_expr
*expr
,
4934 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4935 int *f ATTRIBUTE_UNUSED
)
4937 if (expr
->expr_type
!= EXPR_VARIABLE
)
4939 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4944 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4946 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4950 /* Determine if an expression is a procedure pointer component and return
4951 the component in that case. Otherwise return NULL. */
4954 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4958 if (!expr
|| !expr
->ref
)
4965 if (ref
->type
== REF_COMPONENT
4966 && ref
->u
.c
.component
->attr
.proc_pointer
)
4967 return ref
->u
.c
.component
;
4973 /* Determine if an expression is a procedure pointer component. */
4976 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4978 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4982 /* Determine if an expression is a function with an allocatable class scalar
4985 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4987 if (expr
->expr_type
== EXPR_FUNCTION
4988 && expr
->value
.function
.esym
4989 && expr
->value
.function
.esym
->result
4990 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4991 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4992 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4999 /* Determine if an expression is a function with an allocatable class array
5002 gfc_is_class_array_function (gfc_expr
*expr
)
5004 if (expr
->expr_type
== EXPR_FUNCTION
5005 && expr
->value
.function
.esym
5006 && expr
->value
.function
.esym
->result
5007 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
5008 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
5009 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
5010 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
5017 /* Walk an expression tree and check each variable encountered for being typed.
5018 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
5019 mode as is a basic arithmetic expression using those; this is for things in
5022 INTEGER :: arr(n), n
5023 INTEGER :: arr(n + 1), n
5025 The namespace is needed for IMPLICIT typing. */
5027 static gfc_namespace
* check_typed_ns
;
5030 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5031 int* f ATTRIBUTE_UNUSED
)
5035 if (e
->expr_type
!= EXPR_VARIABLE
)
5038 gcc_assert (e
->symtree
);
5039 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
5046 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
5050 /* If this is a top-level variable or EXPR_OP, do the check with strict given
5054 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
5055 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
5057 if (e
->expr_type
== EXPR_OP
)
5061 gcc_assert (e
->value
.op
.op1
);
5062 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
5064 if (t
&& e
->value
.op
.op2
)
5065 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
5071 /* Otherwise, walk the expression and do it strictly. */
5072 check_typed_ns
= ns
;
5073 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
5075 return error_found
? false : true;
5079 /* This function returns true if it contains any references to PDT KIND
5080 or LEN parameters. */
5083 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5084 int* f ATTRIBUTE_UNUSED
)
5086 if (e
->expr_type
!= EXPR_VARIABLE
)
5089 gcc_assert (e
->symtree
);
5090 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5091 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5099 gfc_derived_parameter_expr (gfc_expr
*e
)
5101 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5105 /* This function returns the overall type of a type parameter spec list.
5106 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5107 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5108 unless derived is not NULL. In this latter case, all the LEN parameters
5109 must be either assumed or deferred for the return argument to be set to
5110 anything other than SPEC_EXPLICIT. */
5113 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5115 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5117 bool seen_assumed
= false;
5118 bool seen_deferred
= false;
5120 if (derived
== NULL
)
5122 for (; param_list
; param_list
= param_list
->next
)
5123 if (param_list
->spec_type
== SPEC_ASSUMED
5124 || param_list
->spec_type
== SPEC_DEFERRED
)
5125 return param_list
->spec_type
;
5129 for (; param_list
; param_list
= param_list
->next
)
5131 c
= gfc_find_component (derived
, param_list
->name
,
5133 gcc_assert (c
!= NULL
);
5134 if (c
->attr
.pdt_kind
)
5136 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5137 return SPEC_EXPLICIT
;
5138 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5139 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5140 if (seen_assumed
&& seen_deferred
)
5141 return SPEC_EXPLICIT
;
5143 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5150 gfc_ref_this_image (gfc_ref
*ref
)
5154 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5156 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5157 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5164 gfc_find_team_co (gfc_expr
*e
)
5168 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5169 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5170 return ref
->u
.ar
.team
;
5172 if (e
->value
.function
.actual
->expr
)
5173 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5175 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5176 return ref
->u
.ar
.team
;
5182 gfc_find_stat_co (gfc_expr
*e
)
5186 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5187 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5188 return ref
->u
.ar
.stat
;
5190 if (e
->value
.function
.actual
->expr
)
5191 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5193 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5194 return ref
->u
.ar
.stat
;
5200 gfc_is_coindexed (gfc_expr
*e
)
5204 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5205 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5206 return !gfc_ref_this_image (ref
);
5212 /* Coarrays are variables with a corank but not being coindexed. However, also
5213 the following is a coarray: A subobject of a coarray is a coarray if it does
5214 not have any cosubscripts, vector subscripts, allocatable component
5215 selection, or pointer component selection. (F2008, 2.4.7) */
5218 gfc_is_coarray (gfc_expr
*e
)
5222 gfc_component
*comp
;
5227 if (e
->expr_type
!= EXPR_VARIABLE
)
5231 sym
= e
->symtree
->n
.sym
;
5233 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5234 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5236 coarray
= sym
->attr
.codimension
;
5238 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5242 comp
= ref
->u
.c
.component
;
5243 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5244 && (CLASS_DATA (comp
)->attr
.class_pointer
5245 || CLASS_DATA (comp
)->attr
.allocatable
))
5248 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5250 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5253 coarray
= comp
->attr
.codimension
;
5261 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5267 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5268 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5279 return coarray
&& !coindexed
;
5284 gfc_get_corank (gfc_expr
*e
)
5289 if (!gfc_is_coarray (e
))
5292 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5293 corank
= e
->ts
.u
.derived
->components
->as
5294 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5296 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5298 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5300 if (ref
->type
== REF_ARRAY
)
5301 corank
= ref
->u
.ar
.as
->corank
;
5302 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5309 /* Check whether the expression has an ultimate allocatable component.
5310 Being itself allocatable does not count. */
5312 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5314 gfc_ref
*ref
, *last
= NULL
;
5316 if (e
->expr_type
!= EXPR_VARIABLE
)
5319 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5320 if (ref
->type
== REF_COMPONENT
)
5323 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5324 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5325 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5326 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5330 if (e
->ts
.type
== BT_CLASS
)
5331 return CLASS_DATA (e
)->attr
.alloc_comp
;
5332 else if (e
->ts
.type
== BT_DERIVED
)
5333 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5339 /* Check whether the expression has an pointer component.
5340 Being itself a pointer does not count. */
5342 gfc_has_ultimate_pointer (gfc_expr
*e
)
5344 gfc_ref
*ref
, *last
= NULL
;
5346 if (e
->expr_type
!= EXPR_VARIABLE
)
5349 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5350 if (ref
->type
== REF_COMPONENT
)
5353 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5354 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5355 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5356 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5360 if (e
->ts
.type
== BT_CLASS
)
5361 return CLASS_DATA (e
)->attr
.pointer_comp
;
5362 else if (e
->ts
.type
== BT_DERIVED
)
5363 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5369 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5370 Note: A scalar is not regarded as "simply contiguous" by the standard.
5371 if bool is not strict, some further checks are done - for instance,
5372 a "(::1)" is accepted. */
5375 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5379 gfc_array_ref
*ar
= NULL
;
5380 gfc_ref
*ref
, *part_ref
= NULL
;
5383 if (expr
->expr_type
== EXPR_FUNCTION
)
5385 if (expr
->value
.function
.esym
)
5386 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5389 /* Type-bound procedures. */
5390 gfc_symbol
*s
= expr
->symtree
->n
.sym
;
5391 if (s
->ts
.type
!= BT_CLASS
&& s
->ts
.type
!= BT_DERIVED
)
5395 for (gfc_ref
*r
= expr
->ref
; r
; r
= r
->next
)
5396 if (r
->type
== REF_COMPONENT
)
5399 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5400 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5403 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5406 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5409 if (!permit_element
&& expr
->rank
== 0)
5412 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5415 return false; /* Array shall be last part-ref. */
5417 if (ref
->type
== REF_COMPONENT
)
5419 else if (ref
->type
== REF_SUBSTRING
)
5421 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5425 sym
= expr
->symtree
->n
.sym
;
5426 if (expr
->ts
.type
!= BT_CLASS
5428 && !part_ref
->u
.c
.component
->attr
.contiguous
5429 && part_ref
->u
.c
.component
->attr
.pointer
)
5431 && !sym
->attr
.contiguous
5432 && (sym
->attr
.pointer
5433 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5434 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5437 if (!ar
|| ar
->type
== AR_FULL
)
5440 gcc_assert (ar
->type
== AR_SECTION
);
5442 /* Check for simply contiguous array */
5444 for (i
= 0; i
< ar
->dimen
; i
++)
5446 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5449 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5455 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5458 /* If the previous section was not contiguous, that's an error,
5459 unless we have effective only one element and checking is not
5461 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5462 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5463 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5464 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5465 ar
->end
[i
]->value
.integer
) != 0))
5468 /* Following the standard, "(::1)" or - if known at compile time -
5469 "(lbound:ubound)" are not simply contiguous; if strict
5470 is false, they are regarded as simply contiguous. */
5471 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5472 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5473 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5477 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5478 || !ar
->as
->lower
[i
]
5479 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5480 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5481 ar
->as
->lower
[i
]->value
.integer
) != 0))
5485 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5486 || !ar
->as
->upper
[i
]
5487 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5488 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5489 ar
->as
->upper
[i
]->value
.integer
) != 0))
5497 /* Build call to an intrinsic procedure. The number of arguments has to be
5498 passed (rather than ending the list with a NULL value) because we may
5499 want to add arguments but with a NULL-expression. */
5502 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5503 locus where
, unsigned numarg
, ...)
5506 gfc_actual_arglist
* atail
;
5507 gfc_intrinsic_sym
* isym
;
5510 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5512 isym
= gfc_intrinsic_function_by_id (id
);
5515 result
= gfc_get_expr ();
5516 result
->expr_type
= EXPR_FUNCTION
;
5517 result
->ts
= isym
->ts
;
5518 result
->where
= where
;
5519 result
->value
.function
.name
= mangled_name
;
5520 result
->value
.function
.isym
= isym
;
5522 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5523 gfc_commit_symbol (result
->symtree
->n
.sym
);
5524 gcc_assert (result
->symtree
5525 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5526 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5527 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5528 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5529 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5530 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5532 va_start (ap
, numarg
);
5534 for (i
= 0; i
< numarg
; ++i
)
5538 atail
->next
= gfc_get_actual_arglist ();
5539 atail
= atail
->next
;
5542 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5544 atail
->expr
= va_arg (ap
, gfc_expr
*);
5552 /* Check if an expression may appear in a variable definition context
5553 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5554 This is called from the various places when resolving
5555 the pieces that make up such a context.
5556 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5557 variables), some checks are not performed.
5559 Optionally, a possible error message can be suppressed if context is NULL
5560 and just the return status (true / false) be requested. */
5563 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5564 bool own_scope
, const char* context
)
5566 gfc_symbol
* sym
= NULL
;
5568 bool check_intentin
;
5570 symbol_attribute attr
;
5574 if (e
->expr_type
== EXPR_VARIABLE
)
5576 gcc_assert (e
->symtree
);
5577 sym
= e
->symtree
->n
.sym
;
5579 else if (e
->expr_type
== EXPR_FUNCTION
)
5581 gcc_assert (e
->symtree
);
5582 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5585 attr
= gfc_expr_attr (e
);
5586 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5588 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5591 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5592 " context (%s) at %L", context
, &e
->where
);
5596 else if (e
->expr_type
!= EXPR_VARIABLE
)
5599 gfc_error ("Non-variable expression in variable definition context (%s)"
5600 " at %L", context
, &e
->where
);
5604 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5607 gfc_error ("Named constant %qs in variable definition context (%s)"
5608 " at %L", sym
->name
, context
, &e
->where
);
5611 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5612 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5613 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5616 gfc_error ("%qs in variable definition context (%s) at %L is not"
5617 " a variable", sym
->name
, context
, &e
->where
);
5621 /* Find out whether the expr is a pointer; this also means following
5622 component references to the last one. */
5623 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5624 if (pointer
&& !is_pointer
)
5627 gfc_error ("Non-POINTER in pointer association context (%s)"
5628 " at %L", context
, &e
->where
);
5632 if (e
->ts
.type
== BT_DERIVED
5633 && e
->ts
.u
.derived
== NULL
)
5636 gfc_error ("Type inaccessible in variable definition context (%s) "
5637 "at %L", context
, &e
->where
);
5644 || (e
->ts
.type
== BT_DERIVED
5645 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5646 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5649 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5650 context
, &e
->where
);
5654 /* TS18508, C702/C203. */
5657 || (e
->ts
.type
== BT_DERIVED
5658 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5659 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5662 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5663 context
, &e
->where
);
5667 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5668 component of sub-component of a pointer; we need to distinguish
5669 assignment to a pointer component from pointer-assignment to a pointer
5670 component. Note that (normal) assignment to procedure pointers is not
5672 check_intentin
= !own_scope
;
5673 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5674 && CLASS_DATA (sym
))
5675 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5676 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5678 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5679 check_intentin
= false;
5680 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5682 ptr_component
= true;
5684 check_intentin
= false;
5687 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5689 if (pointer
&& is_pointer
)
5692 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5693 " association context (%s) at %L",
5694 sym
->name
, context
, &e
->where
);
5697 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5700 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5701 " definition context (%s) at %L",
5702 sym
->name
, context
, &e
->where
);
5707 /* PROTECTED and use-associated. */
5708 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5710 if (pointer
&& is_pointer
)
5713 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5714 " pointer association context (%s) at %L",
5715 sym
->name
, context
, &e
->where
);
5718 if (!pointer
&& !is_pointer
)
5721 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5722 " variable definition context (%s) at %L",
5723 sym
->name
, context
, &e
->where
);
5728 /* Variable not assignable from a PURE procedure but appears in
5729 variable definition context. */
5730 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5733 gfc_error ("Variable %qs can not appear in a variable definition"
5734 " context (%s) at %L in PURE procedure",
5735 sym
->name
, context
, &e
->where
);
5739 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5740 && gfc_impure_variable (sym
))
5745 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5747 sym
= ns
->proc_name
;
5750 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5752 sym
->attr
.implicit_pure
= 0;
5757 /* Check variable definition context for associate-names. */
5758 if (!pointer
&& sym
->assoc
)
5761 gfc_association_list
* assoc
;
5763 gcc_assert (sym
->assoc
->target
);
5765 /* If this is a SELECT TYPE temporary (the association is used internally
5766 for SELECT TYPE), silently go over to the target. */
5767 if (sym
->attr
.select_type_temporary
)
5769 gfc_expr
* t
= sym
->assoc
->target
;
5771 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5772 name
= t
->symtree
->name
;
5774 if (t
->symtree
->n
.sym
->assoc
)
5775 assoc
= t
->symtree
->n
.sym
->assoc
;
5784 gcc_assert (name
&& assoc
);
5786 /* Is association to a valid variable? */
5787 if (!assoc
->variable
)
5791 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5792 gfc_error ("%qs at %L associated to vector-indexed target can"
5793 " not be used in a variable definition context (%s)",
5794 name
, &e
->where
, context
);
5796 gfc_error ("%qs at %L associated to expression can"
5797 " not be used in a variable definition context (%s)",
5798 name
, &e
->where
, context
);
5803 /* Target must be allowed to appear in a variable definition context. */
5804 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5807 gfc_error ("Associate-name %qs can not appear in a variable"
5808 " definition context (%s) at %L because its target"
5809 " at %L can not, either",
5810 name
, context
, &e
->where
,
5811 &assoc
->target
->where
);
5816 /* Check for same value in vector expression subscript. */
5819 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5820 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5821 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5822 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5823 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5825 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5826 if (arr
->expr_type
== EXPR_ARRAY
)
5828 gfc_constructor
*c
, *n
;
5831 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5832 c
!= NULL
; c
= gfc_constructor_next (c
))
5834 if (c
== NULL
|| c
->iterator
!= NULL
)
5839 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5840 n
= gfc_constructor_next (n
))
5842 if (n
->iterator
!= NULL
)
5846 if (gfc_dep_compare_expr (ec
, en
) == 0)
5849 gfc_error_now ("Elements with the same value "
5850 "at %L and %L in vector "
5851 "subscript in a variable "
5852 "definition context (%s)",
5853 &(ec
->where
), &(en
->where
),