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
.class_pointer
)
1076 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1078 if (ref
->type
== REF_ARRAY
1079 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1083 && ref
->type
!= REF_ARRAY
)
1090 /* Try to collapse intrinsic expressions. */
1093 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1095 gfc_intrinsic_op op
;
1096 gfc_expr
*op1
, *op2
, *result
;
1098 if (p
->value
.op
.op
== INTRINSIC_USER
)
1101 op1
= p
->value
.op
.op1
;
1102 op2
= p
->value
.op
.op2
;
1103 op
= p
->value
.op
.op
;
1105 if (!gfc_simplify_expr (op1
, type
))
1107 if (!gfc_simplify_expr (op2
, type
))
1110 if (!gfc_is_constant_expr (op1
)
1111 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1115 p
->value
.op
.op1
= NULL
;
1116 p
->value
.op
.op2
= NULL
;
1120 case INTRINSIC_PARENTHESES
:
1121 result
= gfc_parentheses (op1
);
1124 case INTRINSIC_UPLUS
:
1125 result
= gfc_uplus (op1
);
1128 case INTRINSIC_UMINUS
:
1129 result
= gfc_uminus (op1
);
1132 case INTRINSIC_PLUS
:
1133 result
= gfc_add (op1
, op2
);
1136 case INTRINSIC_MINUS
:
1137 result
= gfc_subtract (op1
, op2
);
1140 case INTRINSIC_TIMES
:
1141 result
= gfc_multiply (op1
, op2
);
1144 case INTRINSIC_DIVIDE
:
1145 result
= gfc_divide (op1
, op2
);
1148 case INTRINSIC_POWER
:
1149 result
= gfc_power (op1
, op2
);
1152 case INTRINSIC_CONCAT
:
1153 result
= gfc_concat (op1
, op2
);
1157 case INTRINSIC_EQ_OS
:
1158 result
= gfc_eq (op1
, op2
, op
);
1162 case INTRINSIC_NE_OS
:
1163 result
= gfc_ne (op1
, op2
, op
);
1167 case INTRINSIC_GT_OS
:
1168 result
= gfc_gt (op1
, op2
, op
);
1172 case INTRINSIC_GE_OS
:
1173 result
= gfc_ge (op1
, op2
, op
);
1177 case INTRINSIC_LT_OS
:
1178 result
= gfc_lt (op1
, op2
, op
);
1182 case INTRINSIC_LE_OS
:
1183 result
= gfc_le (op1
, op2
, op
);
1187 result
= gfc_not (op1
);
1191 result
= gfc_and (op1
, op2
);
1195 result
= gfc_or (op1
, op2
);
1199 result
= gfc_eqv (op1
, op2
);
1202 case INTRINSIC_NEQV
:
1203 result
= gfc_neqv (op1
, op2
);
1207 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1212 gfc_free_expr (op1
);
1213 gfc_free_expr (op2
);
1217 result
->rank
= p
->rank
;
1218 result
->where
= p
->where
;
1219 gfc_replace_expr (p
, result
);
1225 /* Subroutine to simplify constructor expressions. Mutually recursive
1226 with gfc_simplify_expr(). */
1229 simplify_constructor (gfc_constructor_base base
, int type
)
1234 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1237 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1238 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1239 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1244 /* Try and simplify a copy. Replace the original if successful
1245 but keep going through the constructor at all costs. Not
1246 doing so can make a dog's dinner of complicated things. */
1247 p
= gfc_copy_expr (c
->expr
);
1249 if (!gfc_simplify_expr (p
, type
))
1255 gfc_replace_expr (c
->expr
, p
);
1263 /* Pull a single array element out of an array constructor. */
1266 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1267 gfc_constructor
**rval
)
1269 unsigned long nelemen
;
1275 gfc_constructor
*cons
;
1282 mpz_init_set_ui (offset
, 0);
1285 mpz_init_set_ui (span
, 1);
1286 for (i
= 0; i
< ar
->dimen
; i
++)
1288 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1289 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1297 if (e
->expr_type
!= EXPR_CONSTANT
)
1303 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1304 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1306 /* Check the bounds. */
1307 if ((ar
->as
->upper
[i
]
1308 && mpz_cmp (e
->value
.integer
,
1309 ar
->as
->upper
[i
]->value
.integer
) > 0)
1310 || (mpz_cmp (e
->value
.integer
,
1311 ar
->as
->lower
[i
]->value
.integer
) < 0))
1313 gfc_error ("Index in dimension %d is out of bounds "
1314 "at %L", i
+ 1, &ar
->c_where
[i
]);
1320 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1321 mpz_mul (delta
, delta
, span
);
1322 mpz_add (offset
, offset
, delta
);
1324 mpz_set_ui (tmp
, 1);
1325 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1326 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1327 mpz_mul (span
, span
, tmp
);
1330 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1331 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1350 /* Find a component of a structure constructor. */
1352 static gfc_constructor
*
1353 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1355 gfc_component
*pick
= ref
->u
.c
.component
;
1356 gfc_constructor
*c
= gfc_constructor_first (base
);
1358 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1359 int ext
= dt
->attr
.extension
;
1361 /* For extended types, check if the desired component is in one of the
1363 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1364 pick
->name
, true, true, NULL
))
1366 dt
= dt
->components
->ts
.u
.derived
;
1367 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1371 gfc_component
*comp
= dt
->components
;
1372 while (comp
!= pick
)
1375 c
= gfc_constructor_next (c
);
1382 /* Replace an expression with the contents of a constructor, removing
1383 the subobject reference in the process. */
1386 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1396 e
= gfc_copy_expr (p
);
1397 e
->ref
= p
->ref
->next
;
1398 p
->ref
->next
= NULL
;
1399 gfc_replace_expr (p
, e
);
1403 /* Pull an array section out of an array constructor. */
1406 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1413 long unsigned one
= 1;
1415 mpz_t start
[GFC_MAX_DIMENSIONS
];
1416 mpz_t end
[GFC_MAX_DIMENSIONS
];
1417 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1418 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1419 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1424 gfc_constructor_base base
;
1425 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1435 base
= expr
->value
.constructor
;
1436 expr
->value
.constructor
= NULL
;
1438 rank
= ref
->u
.ar
.as
->rank
;
1440 if (expr
->shape
== NULL
)
1441 expr
->shape
= gfc_get_shape (rank
);
1443 mpz_init_set_ui (delta_mpz
, one
);
1444 mpz_init_set_ui (nelts
, one
);
1447 /* Do the initialization now, so that we can cleanup without
1448 keeping track of where we were. */
1449 for (d
= 0; d
< rank
; d
++)
1451 mpz_init (delta
[d
]);
1452 mpz_init (start
[d
]);
1455 mpz_init (stride
[d
]);
1459 /* Build the counters to clock through the array reference. */
1461 for (d
= 0; d
< rank
; d
++)
1463 /* Make this stretch of code easier on the eye! */
1464 begin
= ref
->u
.ar
.start
[d
];
1465 finish
= ref
->u
.ar
.end
[d
];
1466 step
= ref
->u
.ar
.stride
[d
];
1467 lower
= ref
->u
.ar
.as
->lower
[d
];
1468 upper
= ref
->u
.ar
.as
->upper
[d
];
1470 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1472 gfc_constructor
*ci
;
1475 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1481 gcc_assert (begin
->rank
== 1);
1482 /* Zero-sized arrays have no shape and no elements, stop early. */
1485 mpz_init_set_ui (nelts
, 0);
1489 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1490 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1491 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1492 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1495 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1497 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1498 || mpz_cmp (ci
->expr
->value
.integer
,
1499 lower
->value
.integer
) < 0)
1501 gfc_error ("index in dimension %d is out of bounds "
1502 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1510 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1511 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1512 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1518 /* Obtain the stride. */
1520 mpz_set (stride
[d
], step
->value
.integer
);
1522 mpz_set_ui (stride
[d
], one
);
1524 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1525 mpz_set_ui (stride
[d
], one
);
1527 /* Obtain the start value for the index. */
1529 mpz_set (start
[d
], begin
->value
.integer
);
1531 mpz_set (start
[d
], lower
->value
.integer
);
1533 mpz_set (ctr
[d
], start
[d
]);
1535 /* Obtain the end value for the index. */
1537 mpz_set (end
[d
], finish
->value
.integer
);
1539 mpz_set (end
[d
], upper
->value
.integer
);
1541 /* Separate 'if' because elements sometimes arrive with
1543 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1544 mpz_set (end
[d
], begin
->value
.integer
);
1546 /* Check the bounds. */
1547 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1548 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1549 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1550 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1552 gfc_error ("index in dimension %d is out of bounds "
1553 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1558 /* Calculate the number of elements and the shape. */
1559 mpz_set (tmp_mpz
, stride
[d
]);
1560 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1561 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1562 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1563 mpz_mul (nelts
, nelts
, tmp_mpz
);
1565 /* An element reference reduces the rank of the expression; don't
1566 add anything to the shape array. */
1567 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1568 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1571 /* Calculate the 'stride' (=delta) for conversion of the
1572 counter values into the index along the constructor. */
1573 mpz_set (delta
[d
], delta_mpz
);
1574 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1575 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1576 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1580 cons
= gfc_constructor_first (base
);
1582 /* Now clock through the array reference, calculating the index in
1583 the source constructor and transferring the elements to the new
1585 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1587 mpz_init_set_ui (ptr
, 0);
1590 for (d
= 0; d
< rank
; d
++)
1592 mpz_set (tmp_mpz
, ctr
[d
]);
1593 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1594 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1595 mpz_add (ptr
, ptr
, tmp_mpz
);
1597 if (!incr_ctr
) continue;
1599 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1601 gcc_assert(vecsub
[d
]);
1603 if (!gfc_constructor_next (vecsub
[d
]))
1604 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1607 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1610 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1614 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1616 if (mpz_cmp_ui (stride
[d
], 0) > 0
1617 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1618 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1619 mpz_set (ctr
[d
], start
[d
]);
1625 limit
= mpz_get_ui (ptr
);
1626 if (limit
>= flag_max_array_constructor
)
1628 gfc_error ("The number of elements in the array constructor "
1629 "at %L requires an increase of the allowed %d "
1630 "upper limit. See -fmax-array-constructor "
1631 "option", &expr
->where
, flag_max_array_constructor
);
1635 cons
= gfc_constructor_lookup (base
, limit
);
1637 gfc_constructor_append_expr (&expr
->value
.constructor
,
1638 gfc_copy_expr (cons
->expr
), NULL
);
1645 mpz_clear (delta_mpz
);
1646 mpz_clear (tmp_mpz
);
1648 for (d
= 0; d
< rank
; d
++)
1650 mpz_clear (delta
[d
]);
1651 mpz_clear (start
[d
]);
1654 mpz_clear (stride
[d
]);
1656 gfc_constructor_free (base
);
1660 /* Pull a substring out of an expression. */
1663 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1666 gfc_charlen_t start
;
1667 gfc_charlen_t length
;
1670 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1671 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1674 *newp
= gfc_copy_expr (p
);
1675 free ((*newp
)->value
.character
.string
);
1677 end
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1678 start
= (gfc_charlen_t
) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1680 length
= end
- start
+ 1;
1684 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1685 (*newp
)->value
.character
.length
= length
;
1686 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1687 length
* sizeof (gfc_char_t
));
1694 /* Simplify a subobject reference of a constructor. This occurs when
1695 parameter variable values are substituted. */
1698 simplify_const_ref (gfc_expr
*p
)
1700 gfc_constructor
*cons
, *c
;
1706 switch (p
->ref
->type
)
1709 switch (p
->ref
->u
.ar
.type
)
1712 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1713 will generate this. */
1714 if (p
->expr_type
!= EXPR_ARRAY
)
1716 remove_subobject_ref (p
, NULL
);
1719 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1725 remove_subobject_ref (p
, cons
);
1729 if (!find_array_section (p
, p
->ref
))
1731 p
->ref
->u
.ar
.type
= AR_FULL
;
1736 if (p
->ref
->next
!= NULL
1737 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1739 for (c
= gfc_constructor_first (p
->value
.constructor
);
1740 c
; c
= gfc_constructor_next (c
))
1742 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1743 if (!simplify_const_ref (c
->expr
))
1747 if (gfc_bt_struct (p
->ts
.type
)
1749 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1751 /* There may have been component references. */
1752 p
->ts
= c
->expr
->ts
;
1756 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1758 if (p
->ts
.type
== BT_CHARACTER
1759 && last_ref
->type
== REF_SUBSTRING
)
1761 /* If this is a CHARACTER array and we possibly took
1762 a substring out of it, update the type-spec's
1763 character length according to the first element
1764 (as all should have the same length). */
1765 gfc_charlen_t string_len
;
1766 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1768 const gfc_expr
* first
= c
->expr
;
1769 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1770 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1771 string_len
= first
->value
.character
.length
;
1777 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1780 gfc_free_expr (p
->ts
.u
.cl
->length
);
1783 = gfc_get_int_expr (gfc_charlen_int_kind
,
1787 gfc_free_ref_list (p
->ref
);
1798 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1799 remove_subobject_ref (p
, cons
);
1803 if (!find_substring_ref (p
, &newp
))
1806 gfc_replace_expr (p
, newp
);
1807 gfc_free_ref_list (p
->ref
);
1817 /* Simplify a chain of references. */
1820 simplify_ref_chain (gfc_ref
*ref
, int type
)
1824 for (; ref
; ref
= ref
->next
)
1829 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1831 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1833 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1835 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1841 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1843 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1855 /* Try to substitute the value of a parameter variable. */
1858 simplify_parameter_variable (gfc_expr
*p
, int type
)
1863 if (gfc_is_size_zero_array (p
))
1865 if (p
->expr_type
== EXPR_ARRAY
)
1868 e
= gfc_get_expr ();
1869 e
->expr_type
= EXPR_ARRAY
;
1872 e
->value
.constructor
= NULL
;
1873 e
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
1874 e
->where
= p
->where
;
1875 gfc_replace_expr (p
, e
);
1879 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1885 /* Do not copy subobject refs for constant. */
1886 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1887 e
->ref
= gfc_copy_ref (p
->ref
);
1888 t
= gfc_simplify_expr (e
, type
);
1890 /* Only use the simplification if it eliminated all subobject references. */
1892 gfc_replace_expr (p
, e
);
1899 /* Given an expression, simplify it by collapsing constant
1900 expressions. Most simplification takes place when the expression
1901 tree is being constructed. If an intrinsic function is simplified
1902 at some point, we get called again to collapse the result against
1905 We work by recursively simplifying expression nodes, simplifying
1906 intrinsic functions where possible, which can lead to further
1907 constant collapsing. If an operator has constant operand(s), we
1908 rip the expression apart, and rebuild it, hoping that it becomes
1911 The expression type is defined for:
1912 0 Basic expression parsing
1913 1 Simplifying array constructors -- will substitute
1915 Returns false on error, true otherwise.
1916 NOTE: Will return true even if the expression can not be simplified. */
1919 gfc_simplify_expr (gfc_expr
*p
, int type
)
1921 gfc_actual_arglist
*ap
;
1926 switch (p
->expr_type
)
1933 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1934 if (!gfc_simplify_expr (ap
->expr
, type
))
1937 if (p
->value
.function
.isym
!= NULL
1938 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1943 case EXPR_SUBSTRING
:
1944 if (!simplify_ref_chain (p
->ref
, type
))
1947 if (gfc_is_constant_expr (p
))
1950 HOST_WIDE_INT start
, end
;
1953 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1955 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
1956 start
--; /* Convert from one-based to zero-based. */
1959 end
= p
->value
.character
.length
;
1960 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1961 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
1966 s
= gfc_get_wide_string (end
- start
+ 2);
1967 memcpy (s
, p
->value
.character
.string
+ start
,
1968 (end
- start
) * sizeof (gfc_char_t
));
1969 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1970 free (p
->value
.character
.string
);
1971 p
->value
.character
.string
= s
;
1972 p
->value
.character
.length
= end
- start
;
1973 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1974 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
1976 p
->value
.character
.length
);
1977 gfc_free_ref_list (p
->ref
);
1979 p
->expr_type
= EXPR_CONSTANT
;
1984 if (!simplify_intrinsic_op (p
, type
))
1989 /* Only substitute array parameter variables if we are in an
1990 initialization expression, or we want a subsection. */
1991 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1992 && (gfc_init_expr_flag
|| p
->ref
1993 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1995 if (!simplify_parameter_variable (p
, type
))
2002 gfc_simplify_iterator_var (p
);
2005 /* Simplify subcomponent references. */
2006 if (!simplify_ref_chain (p
->ref
, type
))
2011 case EXPR_STRUCTURE
:
2013 if (!simplify_ref_chain (p
->ref
, type
))
2016 if (!simplify_constructor (p
->value
.constructor
, type
))
2019 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2020 && p
->ref
->u
.ar
.type
== AR_FULL
)
2021 gfc_expand_constructor (p
, false);
2023 if (!simplify_const_ref (p
))
2037 /* Returns the type of an expression with the exception that iterator
2038 variables are automatically integers no matter what else they may
2044 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2051 /* Scalarize an expression for an elemental intrinsic call. */
2054 scalarize_intrinsic_call (gfc_expr
*e
)
2056 gfc_actual_arglist
*a
, *b
;
2057 gfc_constructor_base ctor
;
2058 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2059 gfc_constructor
*ci
, *new_ctor
;
2060 gfc_expr
*expr
, *old
;
2061 int n
, i
, rank
[5], array_arg
;
2063 /* Find which, if any, arguments are arrays. Assume that the old
2064 expression carries the type information and that the first arg
2065 that is an array expression carries all the shape information.*/
2067 a
= e
->value
.function
.actual
;
2068 for (; a
; a
= a
->next
)
2071 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2074 expr
= gfc_copy_expr (a
->expr
);
2081 old
= gfc_copy_expr (e
);
2083 gfc_constructor_free (expr
->value
.constructor
);
2084 expr
->value
.constructor
= NULL
;
2086 expr
->where
= old
->where
;
2087 expr
->expr_type
= EXPR_ARRAY
;
2089 /* Copy the array argument constructors into an array, with nulls
2092 a
= old
->value
.function
.actual
;
2093 for (; a
; a
= a
->next
)
2095 /* Check that this is OK for an initialization expression. */
2096 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
2100 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2102 rank
[n
] = a
->expr
->rank
;
2103 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2104 args
[n
] = gfc_constructor_first (ctor
);
2106 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2109 rank
[n
] = a
->expr
->rank
;
2112 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2113 args
[n
] = gfc_constructor_first (ctor
);
2122 /* Using the array argument as the master, step through the array
2123 calling the function for each element and advancing the array
2124 constructors together. */
2125 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2127 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2128 gfc_copy_expr (old
), NULL
);
2130 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2132 b
= old
->value
.function
.actual
;
2133 for (i
= 0; i
< n
; i
++)
2136 new_ctor
->expr
->value
.function
.actual
2137 = a
= gfc_get_actual_arglist ();
2140 a
->next
= gfc_get_actual_arglist ();
2145 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2147 a
->expr
= gfc_copy_expr (b
->expr
);
2152 /* Simplify the function calls. If the simplification fails, the
2153 error will be flagged up down-stream or the library will deal
2155 gfc_simplify_expr (new_ctor
->expr
, 0);
2157 for (i
= 0; i
< n
; i
++)
2159 args
[i
] = gfc_constructor_next (args
[i
]);
2161 for (i
= 1; i
< n
; i
++)
2162 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2163 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2169 /* Free "expr" but not the pointers it contains. */
2171 gfc_free_expr (old
);
2175 gfc_error_now ("elemental function arguments at %C are not compliant");
2178 gfc_free_expr (expr
);
2179 gfc_free_expr (old
);
2185 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2187 gfc_expr
*op1
= e
->value
.op
.op1
;
2188 gfc_expr
*op2
= e
->value
.op
.op2
;
2190 if (!(*check_function
)(op1
))
2193 switch (e
->value
.op
.op
)
2195 case INTRINSIC_UPLUS
:
2196 case INTRINSIC_UMINUS
:
2197 if (!numeric_type (et0 (op1
)))
2202 case INTRINSIC_EQ_OS
:
2204 case INTRINSIC_NE_OS
:
2206 case INTRINSIC_GT_OS
:
2208 case INTRINSIC_GE_OS
:
2210 case INTRINSIC_LT_OS
:
2212 case INTRINSIC_LE_OS
:
2213 if (!(*check_function
)(op2
))
2216 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2217 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2219 gfc_error ("Numeric or CHARACTER operands are required in "
2220 "expression at %L", &e
->where
);
2225 case INTRINSIC_PLUS
:
2226 case INTRINSIC_MINUS
:
2227 case INTRINSIC_TIMES
:
2228 case INTRINSIC_DIVIDE
:
2229 case INTRINSIC_POWER
:
2230 if (!(*check_function
)(op2
))
2233 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2238 case INTRINSIC_CONCAT
:
2239 if (!(*check_function
)(op2
))
2242 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2244 gfc_error ("Concatenation operator in expression at %L "
2245 "must have two CHARACTER operands", &op1
->where
);
2249 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2251 gfc_error ("Concat operator at %L must concatenate strings of the "
2252 "same kind", &e
->where
);
2259 if (et0 (op1
) != BT_LOGICAL
)
2261 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2262 "operand", &op1
->where
);
2271 case INTRINSIC_NEQV
:
2272 if (!(*check_function
)(op2
))
2275 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2277 gfc_error ("LOGICAL operands are required in expression at %L",
2284 case INTRINSIC_PARENTHESES
:
2288 gfc_error ("Only intrinsic operators can be used in expression at %L",
2296 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2301 /* F2003, 7.1.7 (3): In init expression, allocatable components
2302 must not be data-initialized. */
2304 check_alloc_comp_init (gfc_expr
*e
)
2306 gfc_component
*comp
;
2307 gfc_constructor
*ctor
;
2309 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2310 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2312 for (comp
= e
->ts
.u
.derived
->components
,
2313 ctor
= gfc_constructor_first (e
->value
.constructor
);
2314 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2316 if (comp
->attr
.allocatable
&& ctor
->expr
2317 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2319 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2320 "component %qs in structure constructor at %L",
2321 comp
->name
, &ctor
->expr
->where
);
2330 check_init_expr_arguments (gfc_expr
*e
)
2332 gfc_actual_arglist
*ap
;
2334 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2335 if (!gfc_check_init_expr (ap
->expr
))
2341 static bool check_restricted (gfc_expr
*);
2343 /* F95, 7.1.6.1, Initialization expressions, (7)
2344 F2003, 7.1.7 Initialization expression, (8) */
2347 check_inquiry (gfc_expr
*e
, int not_restricted
)
2350 const char *const *functions
;
2352 static const char *const inquiry_func_f95
[] = {
2353 "lbound", "shape", "size", "ubound",
2354 "bit_size", "len", "kind",
2355 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2356 "precision", "radix", "range", "tiny",
2360 static const char *const inquiry_func_f2003
[] = {
2361 "lbound", "shape", "size", "ubound",
2362 "bit_size", "len", "kind",
2363 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2364 "precision", "radix", "range", "tiny",
2369 gfc_actual_arglist
*ap
;
2371 if (!e
->value
.function
.isym
2372 || !e
->value
.function
.isym
->inquiry
)
2375 /* An undeclared parameter will get us here (PR25018). */
2376 if (e
->symtree
== NULL
)
2379 if (e
->symtree
->n
.sym
->from_intmod
)
2381 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2382 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2383 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2386 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2387 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2392 name
= e
->symtree
->n
.sym
->name
;
2394 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2395 ? inquiry_func_f2003
: inquiry_func_f95
;
2397 for (i
= 0; functions
[i
]; i
++)
2398 if (strcmp (functions
[i
], name
) == 0)
2401 if (functions
[i
] == NULL
)
2405 /* At this point we have an inquiry function with a variable argument. The
2406 type of the variable might be undefined, but we need it now, because the
2407 arguments of these functions are not allowed to be undefined. */
2409 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2414 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2416 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2417 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2420 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2423 /* Assumed character length will not reduce to a constant expression
2424 with LEN, as required by the standard. */
2425 if (i
== 5 && not_restricted
&& ap
->expr
->symtree
2426 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2427 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2428 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2430 gfc_error ("Assumed or deferred character length variable %qs "
2431 "in constant expression at %L",
2432 ap
->expr
->symtree
->n
.sym
->name
,
2436 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2439 if (not_restricted
== 0
2440 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2441 && !check_restricted (ap
->expr
))
2444 if (not_restricted
== 0
2445 && ap
->expr
->expr_type
== EXPR_VARIABLE
2446 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2447 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2455 /* F95, 7.1.6.1, Initialization expressions, (5)
2456 F2003, 7.1.7 Initialization expression, (5) */
2459 check_transformational (gfc_expr
*e
)
2461 static const char * const trans_func_f95
[] = {
2462 "repeat", "reshape", "selected_int_kind",
2463 "selected_real_kind", "transfer", "trim", NULL
2466 static const char * const trans_func_f2003
[] = {
2467 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2468 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2469 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2470 "trim", "unpack", NULL
2475 const char *const *functions
;
2477 if (!e
->value
.function
.isym
2478 || !e
->value
.function
.isym
->transformational
)
2481 name
= e
->symtree
->n
.sym
->name
;
2483 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2484 ? trans_func_f2003
: trans_func_f95
;
2486 /* NULL() is dealt with below. */
2487 if (strcmp ("null", name
) == 0)
2490 for (i
= 0; functions
[i
]; i
++)
2491 if (strcmp (functions
[i
], name
) == 0)
2494 if (functions
[i
] == NULL
)
2496 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2497 "in an initialization expression", name
, &e
->where
);
2501 return check_init_expr_arguments (e
);
2505 /* F95, 7.1.6.1, Initialization expressions, (6)
2506 F2003, 7.1.7 Initialization expression, (6) */
2509 check_null (gfc_expr
*e
)
2511 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2514 return check_init_expr_arguments (e
);
2519 check_elemental (gfc_expr
*e
)
2521 if (!e
->value
.function
.isym
2522 || !e
->value
.function
.isym
->elemental
)
2525 if (e
->ts
.type
!= BT_INTEGER
2526 && e
->ts
.type
!= BT_CHARACTER
2527 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2528 "initialization expression at %L", &e
->where
))
2531 return check_init_expr_arguments (e
);
2536 check_conversion (gfc_expr
*e
)
2538 if (!e
->value
.function
.isym
2539 || !e
->value
.function
.isym
->conversion
)
2542 return check_init_expr_arguments (e
);
2546 /* Verify that an expression is an initialization expression. A side
2547 effect is that the expression tree is reduced to a single constant
2548 node if all goes well. This would normally happen when the
2549 expression is constructed but function references are assumed to be
2550 intrinsics in the context of initialization expressions. If
2551 false is returned an error message has been generated. */
2554 gfc_check_init_expr (gfc_expr
*e
)
2562 switch (e
->expr_type
)
2565 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2567 t
= gfc_simplify_expr (e
, 0);
2576 gfc_intrinsic_sym
* isym
= NULL
;
2577 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2579 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2580 IEEE_EXCEPTIONS modules. */
2581 int mod
= sym
->from_intmod
;
2582 if (mod
== INTMOD_NONE
&& sym
->generic
)
2583 mod
= sym
->generic
->sym
->from_intmod
;
2584 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2586 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2589 gfc_replace_expr (e
, new_expr
);
2595 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2596 into an array constructor, we need to skip the error check here.
2597 Conversion errors are caught below in scalarize_intrinsic_call. */
2598 conversion
= e
->value
.function
.isym
2599 && (e
->value
.function
.isym
->conversion
== 1);
2601 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2602 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2604 gfc_error ("Function %qs in initialization expression at %L "
2605 "must be an intrinsic function",
2606 e
->symtree
->n
.sym
->name
, &e
->where
);
2610 if ((m
= check_conversion (e
)) == MATCH_NO
2611 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2612 && (m
= check_null (e
)) == MATCH_NO
2613 && (m
= check_transformational (e
)) == MATCH_NO
2614 && (m
= check_elemental (e
)) == MATCH_NO
)
2616 gfc_error ("Intrinsic function %qs at %L is not permitted "
2617 "in an initialization expression",
2618 e
->symtree
->n
.sym
->name
, &e
->where
);
2622 if (m
== MATCH_ERROR
)
2625 /* Try to scalarize an elemental intrinsic function that has an
2627 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2628 if (isym
&& isym
->elemental
2629 && (t
= scalarize_intrinsic_call (e
)))
2634 t
= gfc_simplify_expr (e
, 0);
2641 /* This occurs when parsing pdt templates. */
2642 if (gfc_expr_attr (e
).pdt_kind
)
2645 if (gfc_check_iter_variable (e
))
2648 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2650 /* A PARAMETER shall not be used to define itself, i.e.
2651 REAL, PARAMETER :: x = transfer(0, x)
2653 if (!e
->symtree
->n
.sym
->value
)
2655 gfc_error ("PARAMETER %qs is used at %L before its definition "
2656 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2660 t
= simplify_parameter_variable (e
, 0);
2665 if (gfc_in_match_data ())
2670 if (e
->symtree
->n
.sym
->as
)
2672 switch (e
->symtree
->n
.sym
->as
->type
)
2674 case AS_ASSUMED_SIZE
:
2675 gfc_error ("Assumed size array %qs at %L is not permitted "
2676 "in an initialization expression",
2677 e
->symtree
->n
.sym
->name
, &e
->where
);
2680 case AS_ASSUMED_SHAPE
:
2681 gfc_error ("Assumed shape array %qs at %L is not permitted "
2682 "in an initialization expression",
2683 e
->symtree
->n
.sym
->name
, &e
->where
);
2687 gfc_error ("Deferred array %qs at %L is not permitted "
2688 "in an initialization expression",
2689 e
->symtree
->n
.sym
->name
, &e
->where
);
2693 gfc_error ("Array %qs at %L is a variable, which does "
2694 "not reduce to a constant expression",
2695 e
->symtree
->n
.sym
->name
, &e
->where
);
2703 gfc_error ("Parameter %qs at %L has not been declared or is "
2704 "a variable, which does not reduce to a constant "
2705 "expression", e
->symtree
->name
, &e
->where
);
2714 case EXPR_SUBSTRING
:
2717 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2721 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2723 t
= gfc_simplify_expr (e
, 0);
2729 case EXPR_STRUCTURE
:
2730 t
= e
->ts
.is_iso_c
? true : false;
2734 t
= check_alloc_comp_init (e
);
2738 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2745 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2749 t
= gfc_expand_constructor (e
, true);
2753 t
= gfc_check_constructor_type (e
);
2757 gfc_internal_error ("check_init_expr(): Unknown expression type");
2763 /* Reduces a general expression to an initialization expression (a constant).
2764 This used to be part of gfc_match_init_expr.
2765 Note that this function doesn't free the given expression on false. */
2768 gfc_reduce_init_expr (gfc_expr
*expr
)
2772 gfc_init_expr_flag
= true;
2773 t
= gfc_resolve_expr (expr
);
2775 t
= gfc_check_init_expr (expr
);
2776 gfc_init_expr_flag
= false;
2781 if (expr
->expr_type
== EXPR_ARRAY
)
2783 if (!gfc_check_constructor_type (expr
))
2785 if (!gfc_expand_constructor (expr
, true))
2793 /* Match an initialization expression. We work by first matching an
2794 expression, then reducing it to a constant. */
2797 gfc_match_init_expr (gfc_expr
**result
)
2805 gfc_init_expr_flag
= true;
2807 m
= gfc_match_expr (&expr
);
2810 gfc_init_expr_flag
= false;
2814 if (gfc_derived_parameter_expr (expr
))
2817 gfc_init_expr_flag
= false;
2821 t
= gfc_reduce_init_expr (expr
);
2824 gfc_free_expr (expr
);
2825 gfc_init_expr_flag
= false;
2830 gfc_init_expr_flag
= false;
2836 /* Given an actual argument list, test to see that each argument is a
2837 restricted expression and optionally if the expression type is
2838 integer or character. */
2841 restricted_args (gfc_actual_arglist
*a
)
2843 for (; a
; a
= a
->next
)
2845 if (!check_restricted (a
->expr
))
2853 /************* Restricted/specification expressions *************/
2856 /* Make sure a non-intrinsic function is a specification function,
2857 * see F08:7.1.11.5. */
2860 external_spec_function (gfc_expr
*e
)
2864 f
= e
->value
.function
.esym
;
2866 /* IEEE functions allowed are "a reference to a transformational function
2867 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2868 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2869 IEEE_EXCEPTIONS". */
2870 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2871 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2873 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2874 || !strcmp (f
->name
, "ieee_support_rounding")
2875 || !strcmp (f
->name
, "ieee_support_flag")
2876 || !strcmp (f
->name
, "ieee_support_halting")
2877 || !strcmp (f
->name
, "ieee_support_datatype")
2878 || !strcmp (f
->name
, "ieee_support_denormal")
2879 || !strcmp (f
->name
, "ieee_support_divide")
2880 || !strcmp (f
->name
, "ieee_support_inf")
2881 || !strcmp (f
->name
, "ieee_support_io")
2882 || !strcmp (f
->name
, "ieee_support_nan")
2883 || !strcmp (f
->name
, "ieee_support_sqrt")
2884 || !strcmp (f
->name
, "ieee_support_standard")
2885 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2886 goto function_allowed
;
2889 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2891 gfc_error ("Specification function %qs at %L cannot be a statement "
2892 "function", f
->name
, &e
->where
);
2896 if (f
->attr
.proc
== PROC_INTERNAL
)
2898 gfc_error ("Specification function %qs at %L cannot be an internal "
2899 "function", f
->name
, &e
->where
);
2903 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2905 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2911 if (f
->attr
.recursive
2912 && !gfc_notify_std (GFC_STD_F2003
,
2913 "Specification function %qs "
2914 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2918 return restricted_args (e
->value
.function
.actual
);
2922 /* Check to see that a function reference to an intrinsic is a
2923 restricted expression. */
2926 restricted_intrinsic (gfc_expr
*e
)
2928 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2929 if (check_inquiry (e
, 0) == MATCH_YES
)
2932 return restricted_args (e
->value
.function
.actual
);
2936 /* Check the expressions of an actual arglist. Used by check_restricted. */
2939 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2941 for (; arg
; arg
= arg
->next
)
2942 if (!checker (arg
->expr
))
2949 /* Check the subscription expressions of a reference chain with a checking
2950 function; used by check_restricted. */
2953 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2963 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2965 if (!checker (ref
->u
.ar
.start
[dim
]))
2967 if (!checker (ref
->u
.ar
.end
[dim
]))
2969 if (!checker (ref
->u
.ar
.stride
[dim
]))
2975 /* Nothing needed, just proceed to next reference. */
2979 if (!checker (ref
->u
.ss
.start
))
2981 if (!checker (ref
->u
.ss
.end
))
2990 return check_references (ref
->next
, checker
);
2993 /* Return true if ns is a parent of the current ns. */
2996 is_parent_of_current_ns (gfc_namespace
*ns
)
2999 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
3006 /* Verify that an expression is a restricted expression. Like its
3007 cousin check_init_expr(), an error message is generated if we
3011 check_restricted (gfc_expr
*e
)
3019 switch (e
->expr_type
)
3022 t
= check_intrinsic_op (e
, check_restricted
);
3024 t
= gfc_simplify_expr (e
, 0);
3029 if (e
->value
.function
.esym
)
3031 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3033 t
= external_spec_function (e
);
3037 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3040 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3043 t
= restricted_intrinsic (e
);
3048 sym
= e
->symtree
->n
.sym
;
3051 /* If a dummy argument appears in a context that is valid for a
3052 restricted expression in an elemental procedure, it will have
3053 already been simplified away once we get here. Therefore we
3054 don't need to jump through hoops to distinguish valid from
3056 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3057 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3059 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3060 sym
->name
, &e
->where
);
3064 if (sym
->attr
.optional
)
3066 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3067 sym
->name
, &e
->where
);
3071 if (sym
->attr
.intent
== INTENT_OUT
)
3073 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3074 sym
->name
, &e
->where
);
3078 /* Check reference chain if any. */
3079 if (!check_references (e
->ref
, &check_restricted
))
3082 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3083 processed in resolve.c(resolve_formal_arglist). This is done so
3084 that host associated dummy array indices are accepted (PR23446).
3085 This mechanism also does the same for the specification expressions
3086 of array-valued functions. */
3088 || sym
->attr
.in_common
3089 || sym
->attr
.use_assoc
3091 || sym
->attr
.implied_index
3092 || sym
->attr
.flavor
== FL_PARAMETER
3093 || is_parent_of_current_ns (sym
->ns
)
3094 || (sym
->ns
->proc_name
!= NULL
3095 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3096 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3102 gfc_error ("Variable %qs cannot appear in the expression at %L",
3103 sym
->name
, &e
->where
);
3104 /* Prevent a repetition of the error. */
3113 case EXPR_SUBSTRING
:
3114 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3118 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3120 t
= gfc_simplify_expr (e
, 0);
3124 case EXPR_STRUCTURE
:
3125 t
= gfc_check_constructor (e
, check_restricted
);
3129 t
= gfc_check_constructor (e
, check_restricted
);
3133 gfc_internal_error ("check_restricted(): Unknown expression type");
3140 /* Check to see that an expression is a specification expression. If
3141 we return false, an error has been generated. */
3144 gfc_specification_expr (gfc_expr
*e
)
3146 gfc_component
*comp
;
3151 if (e
->ts
.type
!= BT_INTEGER
)
3153 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3154 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3158 comp
= gfc_get_proc_ptr_comp (e
);
3159 if (e
->expr_type
== EXPR_FUNCTION
3160 && !e
->value
.function
.isym
3161 && !e
->value
.function
.esym
3162 && !gfc_pure (e
->symtree
->n
.sym
)
3163 && (!comp
|| !comp
->attr
.pure
))
3165 gfc_error ("Function %qs at %L must be PURE",
3166 e
->symtree
->n
.sym
->name
, &e
->where
);
3167 /* Prevent repeat error messages. */
3168 e
->symtree
->n
.sym
->attr
.pure
= 1;
3174 gfc_error ("Expression at %L must be scalar", &e
->where
);
3178 if (!gfc_simplify_expr (e
, 0))
3181 return check_restricted (e
);
3185 /************** Expression conformance checks. *************/
3187 /* Given two expressions, make sure that the arrays are conformable. */
3190 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3192 int op1_flag
, op2_flag
, d
;
3193 mpz_t op1_size
, op2_size
;
3199 if (op1
->rank
== 0 || op2
->rank
== 0)
3202 va_start (argp
, optype_msgid
);
3203 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3206 if (op1
->rank
!= op2
->rank
)
3208 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3209 op1
->rank
, op2
->rank
, &op1
->where
);
3215 for (d
= 0; d
< op1
->rank
; d
++)
3217 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3218 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3220 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3222 gfc_error ("Different shape for %s at %L on dimension %d "
3223 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3224 (int) mpz_get_si (op1_size
),
3225 (int) mpz_get_si (op2_size
));
3231 mpz_clear (op1_size
);
3233 mpz_clear (op2_size
);
3243 /* Given an assignable expression and an arbitrary expression, make
3244 sure that the assignment can take place. Only add a call to the intrinsic
3245 conversion routines, when allow_convert is set. When this assign is a
3246 coarray call, then the convert is done by the coarray routine implictly and
3247 adding the intrinsic conversion would do harm in most cases. */
3250 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3257 sym
= lvalue
->symtree
->n
.sym
;
3259 /* See if this is the component or subcomponent of a pointer. */
3260 has_pointer
= sym
->attr
.pointer
;
3261 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3262 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3268 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3269 variable local to a function subprogram. Its existence begins when
3270 execution of the function is initiated and ends when execution of the
3271 function is terminated...
3272 Therefore, the left hand side is no longer a variable, when it is: */
3273 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3274 && !sym
->attr
.external
)
3279 /* (i) Use associated; */
3280 if (sym
->attr
.use_assoc
)
3283 /* (ii) The assignment is in the main program; or */
3284 if (gfc_current_ns
->proc_name
3285 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3288 /* (iii) A module or internal procedure... */
3289 if (gfc_current_ns
->proc_name
3290 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3291 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3292 && gfc_current_ns
->parent
3293 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3294 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3295 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3297 /* ... that is not a function... */
3298 if (gfc_current_ns
->proc_name
3299 && !gfc_current_ns
->proc_name
->attr
.function
)
3302 /* ... or is not an entry and has a different name. */
3303 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3307 /* (iv) Host associated and not the function symbol or the
3308 parent result. This picks up sibling references, which
3309 cannot be entries. */
3310 if (!sym
->attr
.entry
3311 && sym
->ns
== gfc_current_ns
->parent
3312 && sym
!= gfc_current_ns
->proc_name
3313 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3318 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3323 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3325 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3326 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3330 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3332 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3337 if (rvalue
->expr_type
== EXPR_NULL
)
3339 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3340 && lvalue
->symtree
->n
.sym
->attr
.data
)
3344 gfc_error ("NULL appears on right-hand side in assignment at %L",
3350 /* This is possibly a typo: x = f() instead of x => f(). */
3352 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3353 gfc_warning (OPT_Wsurprising
,
3354 "POINTER-valued function appears on right-hand side of "
3355 "assignment at %L", &rvalue
->where
);
3357 /* Check size of array assignments. */
3358 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3359 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3362 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3363 && lvalue
->symtree
->n
.sym
->attr
.data
3364 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3365 "initialize non-integer variable %qs",
3366 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3368 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3369 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3370 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3374 /* Handle the case of a BOZ literal on the RHS. */
3375 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3378 if (warn_surprising
)
3379 gfc_warning (OPT_Wsurprising
,
3380 "BOZ literal at %L is bitwise transferred "
3381 "non-integer symbol %qs", &rvalue
->where
,
3382 lvalue
->symtree
->n
.sym
->name
);
3383 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3385 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3387 if (rc
== ARITH_UNDERFLOW
)
3388 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3389 ". This check can be disabled with the option "
3390 "%<-fno-range-check%>", &rvalue
->where
);
3391 else if (rc
== ARITH_OVERFLOW
)
3392 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3393 ". This check can be disabled with the option "
3394 "%<-fno-range-check%>", &rvalue
->where
);
3395 else if (rc
== ARITH_NAN
)
3396 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3397 ". This check can be disabled with the option "
3398 "%<-fno-range-check%>", &rvalue
->where
);
3403 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3405 gfc_error ("The assignment to a KIND or LEN component of a "
3406 "parameterized type at %L is not allowed",
3411 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3414 /* Only DATA Statements come here. */
3419 /* Numeric can be converted to any other numeric. And Hollerith can be
3420 converted to any other type. */
3421 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3422 || rvalue
->ts
.type
== BT_HOLLERITH
)
3425 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3428 where
= lvalue
->where
.lb
? &lvalue
->where
: &rvalue
->where
;
3429 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3430 "conversion of %s to %s", where
,
3431 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3436 /* Assignment is the only case where character variables of different
3437 kind values can be converted into one another. */
3438 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3440 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3441 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3449 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3453 /* Check that a pointer assignment is OK. We first check lvalue, and
3454 we only check rvalue if it's not an assignment to NULL() or a
3455 NULLIFY statement. */
3458 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3460 symbol_attribute attr
, lhs_attr
;
3462 bool is_pure
, is_implicit_pure
, rank_remap
;
3465 lhs_attr
= gfc_expr_attr (lvalue
);
3466 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3468 gfc_error ("Pointer assignment target is not a POINTER at %L",
3473 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3474 && !lhs_attr
.proc_pointer
)
3476 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3477 "l-value since it is a procedure",
3478 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3482 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3485 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3487 if (ref
->type
== REF_COMPONENT
)
3488 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3490 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3494 if (ref
->u
.ar
.type
== AR_FULL
)
3497 if (ref
->u
.ar
.type
!= AR_SECTION
)
3499 gfc_error ("Expected bounds specification for %qs at %L",
3500 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3504 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3505 "for %qs in pointer assignment at %L",
3506 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3509 /* When bounds are given, all lbounds are necessary and either all
3510 or none of the upper bounds; no strides are allowed. If the
3511 upper bounds are present, we may do rank remapping. */
3512 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3514 if (!ref
->u
.ar
.start
[dim
]
3515 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3517 gfc_error ("Lower bound has to be present at %L",
3521 if (ref
->u
.ar
.stride
[dim
])
3523 gfc_error ("Stride must not be present at %L",
3529 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3532 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3533 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3535 gfc_error ("Either all or none of the upper bounds"
3536 " must be specified at %L", &lvalue
->where
);
3544 is_pure
= gfc_pure (NULL
);
3545 is_implicit_pure
= gfc_implicit_pure (NULL
);
3547 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3548 kind, etc for lvalue and rvalue must match, and rvalue must be a
3549 pure variable if we're in a pure function. */
3550 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3553 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3554 if (lvalue
->expr_type
== EXPR_VARIABLE
3555 && gfc_is_coindexed (lvalue
))
3558 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3559 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3561 gfc_error ("Pointer object at %L shall not have a coindex",
3567 /* Checks on rvalue for procedure pointer assignments. */
3572 gfc_component
*comp1
, *comp2
;
3575 attr
= gfc_expr_attr (rvalue
);
3576 if (!((rvalue
->expr_type
== EXPR_NULL
)
3577 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3578 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3579 || (rvalue
->expr_type
== EXPR_VARIABLE
3580 && attr
.flavor
== FL_PROCEDURE
)))
3582 gfc_error ("Invalid procedure pointer assignment at %L",
3586 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3588 /* Check for intrinsics. */
3589 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3590 if (!sym
->attr
.intrinsic
3591 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3592 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3594 sym
->attr
.intrinsic
= 1;
3595 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3596 attr
= gfc_expr_attr (rvalue
);
3598 /* Check for result of embracing function. */
3599 if (sym
->attr
.function
&& sym
->result
== sym
)
3603 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3604 if (sym
== ns
->proc_name
)
3606 gfc_error ("Function result %qs is invalid as proc-target "
3607 "in procedure pointer assignment at %L",
3608 sym
->name
, &rvalue
->where
);
3615 gfc_error ("Abstract interface %qs is invalid "
3616 "in procedure pointer assignment at %L",
3617 rvalue
->symtree
->name
, &rvalue
->where
);
3620 /* Check for F08:C729. */
3621 if (attr
.flavor
== FL_PROCEDURE
)
3623 if (attr
.proc
== PROC_ST_FUNCTION
)
3625 gfc_error ("Statement function %qs is invalid "
3626 "in procedure pointer assignment at %L",
3627 rvalue
->symtree
->name
, &rvalue
->where
);
3630 if (attr
.proc
== PROC_INTERNAL
&&
3631 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3632 "is invalid in procedure pointer assignment "
3633 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3635 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3636 attr
.subroutine
) == 0)
3638 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3639 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3643 /* Check for F08:C730. */
3644 if (attr
.elemental
&& !attr
.intrinsic
)
3646 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3647 "in procedure pointer assignment at %L",
3648 rvalue
->symtree
->name
, &rvalue
->where
);
3652 /* Ensure that the calling convention is the same. As other attributes
3653 such as DLLEXPORT may differ, one explicitly only tests for the
3654 calling conventions. */
3655 if (rvalue
->expr_type
== EXPR_VARIABLE
3656 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3657 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3659 symbol_attribute calls
;
3662 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3663 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3664 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3666 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3667 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3669 gfc_error ("Mismatch in the procedure pointer assignment "
3670 "at %L: mismatch in the calling convention",
3676 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3678 s1
= comp1
->ts
.interface
;
3681 s1
= lvalue
->symtree
->n
.sym
;
3682 if (s1
->ts
.interface
)
3683 s1
= s1
->ts
.interface
;
3686 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3689 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3691 s2
= comp2
->ts
.interface
->result
;
3696 s2
= comp2
->ts
.interface
;
3700 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3702 if (rvalue
->value
.function
.esym
)
3703 s2
= rvalue
->value
.function
.esym
->result
;
3705 s2
= rvalue
->symtree
->n
.sym
->result
;
3711 s2
= rvalue
->symtree
->n
.sym
;
3715 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3716 s2
= s2
->ts
.interface
;
3718 /* Special check for the case of absent interface on the lvalue.
3719 * All other interface checks are done below. */
3720 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3722 gfc_error ("Interface mismatch in procedure pointer assignment "
3723 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
3727 /* F08:7.2.2.4 (4) */
3728 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3732 gfc_error ("Explicit interface required for component %qs at %L: %s",
3733 comp1
->name
, &lvalue
->where
, err
);
3736 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
3738 gfc_error ("Explicit interface required for %qs at %L: %s",
3739 s1
->name
, &lvalue
->where
, err
);
3743 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3747 gfc_error ("Explicit interface required for component %qs at %L: %s",
3748 comp2
->name
, &rvalue
->where
, err
);
3751 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
3753 gfc_error ("Explicit interface required for %qs at %L: %s",
3754 s2
->name
, &rvalue
->where
, err
);
3759 if (s1
== s2
|| !s1
|| !s2
)
3762 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3763 err
, sizeof(err
), NULL
, NULL
))
3765 gfc_error ("Interface mismatch in procedure pointer assignment "
3766 "at %L: %s", &rvalue
->where
, err
);
3770 /* Check F2008Cor2, C729. */
3771 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3772 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3774 gfc_error ("Procedure pointer target %qs at %L must be either an "
3775 "intrinsic, host or use associated, referenced or have "
3776 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3783 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3785 /* Check for F03:C717. */
3786 if (UNLIMITED_POLY (rvalue
)
3787 && !(UNLIMITED_POLY (lvalue
)
3788 || (lvalue
->ts
.type
== BT_DERIVED
3789 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3790 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3791 gfc_error ("Data-pointer-object at %L must be unlimited "
3792 "polymorphic, or of a type with the BIND or SEQUENCE "
3793 "attribute, to be compatible with an unlimited "
3794 "polymorphic target", &lvalue
->where
);
3796 gfc_error ("Different types in pointer assignment at %L; "
3797 "attempted assignment of %s to %s", &lvalue
->where
,
3798 gfc_typename (&rvalue
->ts
),
3799 gfc_typename (&lvalue
->ts
));
3803 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3805 gfc_error ("Different kind type parameters in pointer "
3806 "assignment at %L", &lvalue
->where
);
3810 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3812 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3816 /* Make sure the vtab is present. */
3817 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3818 gfc_find_vtab (&rvalue
->ts
);
3820 /* Check rank remapping. */
3825 /* If this can be determined, check that the target must be at least as
3826 large as the pointer assigned to it is. */
3827 if (gfc_array_size (lvalue
, &lsize
)
3828 && gfc_array_size (rvalue
, &rsize
)
3829 && mpz_cmp (rsize
, lsize
) < 0)
3831 gfc_error ("Rank remapping target is smaller than size of the"
3832 " pointer (%ld < %ld) at %L",
3833 mpz_get_si (rsize
), mpz_get_si (lsize
),
3838 /* The target must be either rank one or it must be simply contiguous
3839 and F2008 must be allowed. */
3840 if (rvalue
->rank
!= 1)
3842 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3844 gfc_error ("Rank remapping target must be rank 1 or"
3845 " simply contiguous at %L", &rvalue
->where
);
3848 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3849 "rank 1 at %L", &rvalue
->where
))
3854 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3855 if (rvalue
->expr_type
== EXPR_NULL
)
3858 if (lvalue
->ts
.type
== BT_CHARACTER
)
3860 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3865 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3866 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3868 attr
= gfc_expr_attr (rvalue
);
3870 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3872 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
3873 to caf_get. Map this to the same error message as below when it is
3874 still a variable expression. */
3875 if (rvalue
->value
.function
.isym
3876 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3877 /* The test above might need to be extend when F08, Note 5.4 has to be
3878 interpreted in the way that target and pointer with the same coindex
3880 gfc_error ("Data target at %L shall not have a coindex",
3883 gfc_error ("Target expression in pointer assignment "
3884 "at %L must deliver a pointer result",
3889 if (!attr
.target
&& !attr
.pointer
)
3891 gfc_error ("Pointer assignment target is neither TARGET "
3892 "nor POINTER at %L", &rvalue
->where
);
3896 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3898 gfc_error ("Bad target in pointer assignment in PURE "
3899 "procedure at %L", &rvalue
->where
);
3902 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3903 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3905 if (gfc_has_vector_index (rvalue
))
3907 gfc_error ("Pointer assignment with vector subscript "
3908 "on rhs at %L", &rvalue
->where
);
3912 if (attr
.is_protected
&& attr
.use_assoc
3913 && !(attr
.pointer
|| attr
.proc_pointer
))
3915 gfc_error ("Pointer assignment target has PROTECTED "
3916 "attribute at %L", &rvalue
->where
);
3920 /* F2008, C725. For PURE also C1283. */
3921 if (rvalue
->expr_type
== EXPR_VARIABLE
3922 && gfc_is_coindexed (rvalue
))
3925 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3926 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3928 gfc_error ("Data target at %L shall not have a coindex",
3934 /* Error for assignments of contiguous pointers to targets which is not
3935 contiguous. Be lenient in the definition of what counts as
3938 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
3939 gfc_error ("Assignment to contiguous pointer from non-contiguous "
3940 "target at %L", &rvalue
->where
);
3942 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3943 if (warn_target_lifetime
3944 && rvalue
->expr_type
== EXPR_VARIABLE
3945 && !rvalue
->symtree
->n
.sym
->attr
.save
3946 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
3947 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3948 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3949 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3950 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3955 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3956 || lvalue
->symtree
->n
.sym
->attr
.result
3957 || lvalue
->symtree
->n
.sym
->attr
.function
3958 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3959 && lvalue
->symtree
->n
.sym
->ns
3960 != rvalue
->symtree
->n
.sym
->ns
)
3961 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3962 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3964 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3965 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3966 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3967 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3968 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3970 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3977 gfc_warning (OPT_Wtarget_lifetime
,
3978 "Pointer at %L in pointer assignment might outlive the "
3979 "pointer target", &lvalue
->where
);
3986 /* Relative of gfc_check_assign() except that the lvalue is a single
3987 symbol. Used for initialization assignments. */
3990 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3994 bool pointer
, proc_pointer
;
3996 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3998 lvalue
.expr_type
= EXPR_VARIABLE
;
3999 lvalue
.ts
= sym
->ts
;
4001 lvalue
.rank
= sym
->as
->rank
;
4002 lvalue
.symtree
= XCNEW (gfc_symtree
);
4003 lvalue
.symtree
->n
.sym
= sym
;
4004 lvalue
.where
= sym
->declared_at
;
4008 lvalue
.ref
= gfc_get_ref ();
4009 lvalue
.ref
->type
= REF_COMPONENT
;
4010 lvalue
.ref
->u
.c
.component
= comp
;
4011 lvalue
.ref
->u
.c
.sym
= sym
;
4012 lvalue
.ts
= comp
->ts
;
4013 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
4014 lvalue
.where
= comp
->loc
;
4015 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4016 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
4017 proc_pointer
= comp
->attr
.proc_pointer
;
4021 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4022 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4023 proc_pointer
= sym
->attr
.proc_pointer
;
4026 if (pointer
|| proc_pointer
)
4027 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
4030 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4031 into an array constructor, we should check if it can be reduced
4032 as an initialization expression. */
4033 if (rvalue
->expr_type
== EXPR_FUNCTION
4034 && rvalue
->value
.function
.isym
4035 && (rvalue
->value
.function
.isym
->conversion
== 1))
4036 gfc_check_init_expr (rvalue
);
4038 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4041 free (lvalue
.symtree
);
4047 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4049 /* F08:C461. Additional checks for pointer initialization. */
4050 symbol_attribute attr
;
4051 attr
= gfc_expr_attr (rvalue
);
4052 if (attr
.allocatable
)
4054 gfc_error ("Pointer initialization target at %L "
4055 "must not be ALLOCATABLE", &rvalue
->where
);
4058 if (!attr
.target
|| attr
.pointer
)
4060 gfc_error ("Pointer initialization target at %L "
4061 "must have the TARGET attribute", &rvalue
->where
);
4065 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4066 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4067 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4069 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4070 attr
.save
= SAVE_IMPLICIT
;
4075 gfc_error ("Pointer initialization target at %L "
4076 "must have the SAVE attribute", &rvalue
->where
);
4081 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4083 /* F08:C1220. Additional checks for procedure pointer initialization. */
4084 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4085 if (attr
.proc_pointer
)
4087 gfc_error ("Procedure pointer initialization target at %L "
4088 "may not be a procedure pointer", &rvalue
->where
);
4096 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4097 * require that an expression be built. */
4100 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4102 return gfc_build_init_expr (ts
, where
, false);
4105 /* Build an initializer for a local integer, real, complex, logical, or
4106 character variable, based on the command line flags finit-local-zero,
4107 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4108 With force, an initializer is ALWAYS generated. */
4111 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4113 gfc_expr
*init_expr
;
4115 /* Try to build an initializer expression. */
4116 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4118 /* If we want to force generation, make sure we default to zero. */
4119 gfc_init_local_real init_real
= flag_init_real
;
4120 int init_logical
= gfc_option
.flag_init_logical
;
4123 if (init_real
== GFC_INIT_REAL_OFF
)
4124 init_real
= GFC_INIT_REAL_ZERO
;
4125 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4126 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4129 /* We will only initialize integers, reals, complex, logicals, and
4130 characters, and only if the corresponding command-line flags
4131 were set. Otherwise, we free init_expr and return null. */
4135 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4136 mpz_set_si (init_expr
->value
.integer
,
4137 gfc_option
.flag_init_integer_value
);
4140 gfc_free_expr (init_expr
);
4148 case GFC_INIT_REAL_SNAN
:
4149 init_expr
->is_snan
= 1;
4151 case GFC_INIT_REAL_NAN
:
4152 mpfr_set_nan (init_expr
->value
.real
);
4155 case GFC_INIT_REAL_INF
:
4156 mpfr_set_inf (init_expr
->value
.real
, 1);
4159 case GFC_INIT_REAL_NEG_INF
:
4160 mpfr_set_inf (init_expr
->value
.real
, -1);
4163 case GFC_INIT_REAL_ZERO
:
4164 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4168 gfc_free_expr (init_expr
);
4177 case GFC_INIT_REAL_SNAN
:
4178 init_expr
->is_snan
= 1;
4180 case GFC_INIT_REAL_NAN
:
4181 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4182 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4185 case GFC_INIT_REAL_INF
:
4186 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4187 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4190 case GFC_INIT_REAL_NEG_INF
:
4191 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4192 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4195 case GFC_INIT_REAL_ZERO
:
4196 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4200 gfc_free_expr (init_expr
);
4207 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4208 init_expr
->value
.logical
= 0;
4209 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4210 init_expr
->value
.logical
= 1;
4213 gfc_free_expr (init_expr
);
4219 /* For characters, the length must be constant in order to
4220 create a default initializer. */
4221 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4223 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4225 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4226 init_expr
->value
.character
.length
= char_len
;
4227 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4228 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4229 init_expr
->value
.character
.string
[i
]
4230 = (unsigned char) gfc_option
.flag_init_character_value
;
4234 gfc_free_expr (init_expr
);
4238 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4239 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4241 gfc_actual_arglist
*arg
;
4242 init_expr
= gfc_get_expr ();
4243 init_expr
->where
= *where
;
4244 init_expr
->ts
= *ts
;
4245 init_expr
->expr_type
= EXPR_FUNCTION
;
4246 init_expr
->value
.function
.isym
=
4247 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4248 init_expr
->value
.function
.name
= "repeat";
4249 arg
= gfc_get_actual_arglist ();
4250 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4251 arg
->expr
->value
.character
.string
[0] =
4252 gfc_option
.flag_init_character_value
;
4253 arg
->next
= gfc_get_actual_arglist ();
4254 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4255 init_expr
->value
.function
.actual
= arg
;
4260 gfc_free_expr (init_expr
);
4267 /* Apply an initialization expression to a typespec. Can be used for symbols or
4268 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4269 combined with some effort. */
4272 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4274 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4276 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4278 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4279 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4280 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4282 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4284 if (init
->expr_type
== EXPR_CONSTANT
)
4285 gfc_set_constant_character_len (len
, init
, -1);
4287 && init
->ts
.type
== BT_CHARACTER
4288 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4289 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4290 init
->ts
.u
.cl
->length
->value
.integer
))
4292 gfc_constructor
*ctor
;
4293 ctor
= gfc_constructor_first (init
->value
.constructor
);
4297 bool has_ts
= (init
->ts
.u
.cl
4298 && init
->ts
.u
.cl
->length_from_typespec
);
4300 /* Remember the length of the first element for checking
4301 that all elements *in the constructor* have the same
4302 length. This need not be the length of the LHS! */
4303 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4304 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4305 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4307 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4308 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4310 gfc_set_constant_character_len (len
, ctor
->expr
,
4311 has_ts
? -1 : first_len
);
4312 if (!ctor
->expr
->ts
.u
.cl
)
4314 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4316 ctor
->expr
->ts
.u
.cl
->length
4317 = gfc_copy_expr (ts
->u
.cl
->length
);
4325 /* Check whether an expression is a structure constructor and whether it has
4326 other values than NULL. */
4329 is_non_empty_structure_constructor (gfc_expr
* e
)
4331 if (e
->expr_type
!= EXPR_STRUCTURE
)
4334 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4337 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4339 cons
= gfc_constructor_next (cons
);
4345 /* Check for default initializer; sym->value is not enough
4346 as it is also set for EXPR_NULL of allocatables. */
4349 gfc_has_default_initializer (gfc_symbol
*der
)
4353 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4354 for (c
= der
->components
; c
; c
= c
->next
)
4355 if (gfc_bt_struct (c
->ts
.type
))
4357 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4358 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4360 && is_non_empty_structure_constructor (c
->initializer
))
4361 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4363 if (c
->attr
.pointer
&& c
->initializer
)
4377 Generate an initializer expression which initializes the entirety of a union.
4378 A normal structure constructor is insufficient without undue effort, because
4379 components of maps may be oddly aligned/overlapped. (For example if a
4380 character is initialized from one map overtop a real from the other, only one
4381 byte of the real is actually initialized.) Unfortunately we don't know the
4382 size of the union right now, so we can't generate a proper initializer, but
4383 we use a NULL expr as a placeholder and do the right thing later in
4384 gfc_trans_subcomponent_assign.
4387 generate_union_initializer (gfc_component
*un
)
4389 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4392 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4393 placeholder
->ts
= un
->ts
;
4398 /* Get the user-specified initializer for a union, if any. This means the user
4399 has said to initialize component(s) of a map. For simplicity's sake we
4400 only allow the user to initialize the first map. We don't have to worry
4401 about overlapping initializers as they are released early in resolution (see
4402 resolve_fl_struct). */
4405 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4408 gfc_expr
*init
=NULL
;
4410 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4413 for (map
= union_type
->components
; map
; map
= map
->next
)
4415 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4417 init
= gfc_default_initializer (&map
->ts
);
4430 /* Fetch or generate an initializer for the given component.
4431 Only generate an initializer if generate is true. */
4434 component_initializer (gfc_typespec
*ts
, gfc_component
*c
, bool generate
)
4436 gfc_expr
*init
= NULL
;
4438 /* See if we can find the initializer immediately.
4439 Some components should never get initializers. */
4440 if (c
->initializer
|| !generate
4441 || (ts
->type
== BT_CLASS
&& !c
->attr
.allocatable
)
4443 || c
->attr
.class_pointer
4444 || c
->attr
.proc_pointer
)
4445 return c
->initializer
;
4447 /* Recursively handle derived type components. */
4448 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4449 init
= gfc_generate_initializer (&c
->ts
, true);
4451 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4453 gfc_component
*map
= NULL
;
4454 gfc_constructor
*ctor
;
4455 gfc_expr
*user_init
;
4457 /* If we don't have a user initializer and we aren't generating one, this
4458 union has no initializer. */
4459 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4460 if (!user_init
&& !generate
)
4463 /* Otherwise use a structure constructor. */
4464 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4468 /* If we are to generate an initializer for the union, add a constructor
4469 which initializes the whole union first. */
4472 ctor
= gfc_constructor_get ();
4473 ctor
->expr
= generate_union_initializer (c
);
4474 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4477 /* If we found an initializer in one of our maps, apply it. Note this
4478 is applied _after_ the entire-union initializer above if any. */
4481 ctor
= gfc_constructor_get ();
4482 ctor
->expr
= user_init
;
4483 ctor
->n
.component
= map
;
4484 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4488 /* Treat simple components like locals. */
4491 /* We MUST give an initializer, so force generation. */
4492 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4493 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4500 /* Get an expression for a default initializer of a derived type. */
4503 gfc_default_initializer (gfc_typespec
*ts
)
4505 return gfc_generate_initializer (ts
, false);
4509 /* Get or generate an expression for a default initializer of a derived type.
4510 If -finit-derived is specified, generate default initialization expressions
4511 for components that lack them when generate is set. */
4514 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4516 gfc_expr
*init
, *tmp
;
4517 gfc_component
*comp
;
4518 generate
= flag_init_derived
&& generate
;
4520 /* See if we have a default initializer in this, but not in nested
4521 types (otherwise we could use gfc_has_default_initializer()).
4522 We don't need to check if we are going to generate them. */
4523 comp
= ts
->u
.derived
->components
;
4526 for (; comp
; comp
= comp
->next
)
4527 if (comp
->initializer
|| comp
->attr
.allocatable
4528 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4529 && CLASS_DATA (comp
)->attr
.allocatable
))
4536 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4537 &ts
->u
.derived
->declared_at
);
4540 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4542 gfc_constructor
*ctor
= gfc_constructor_get();
4544 /* Fetch or generate an initializer for the component. */
4545 tmp
= component_initializer (ts
, comp
, generate
);
4548 /* Save the component ref for STRUCTUREs and UNIONs. */
4549 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4550 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4551 ctor
->n
.component
= comp
;
4553 /* If the initializer was not generated, we need a copy. */
4554 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4555 if ((comp
->ts
.type
!= tmp
->ts
.type
4556 || comp
->ts
.kind
!= tmp
->ts
.kind
)
4557 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4560 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
4566 if (comp
->attr
.allocatable
4567 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
4569 ctor
->expr
= gfc_get_expr ();
4570 ctor
->expr
->expr_type
= EXPR_NULL
;
4571 ctor
->expr
->where
= init
->where
;
4572 ctor
->expr
->ts
= comp
->ts
;
4575 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4582 /* Given a symbol, create an expression node with that symbol as a
4583 variable. If the symbol is array valued, setup a reference of the
4587 gfc_get_variable_expr (gfc_symtree
*var
)
4591 e
= gfc_get_expr ();
4592 e
->expr_type
= EXPR_VARIABLE
;
4594 e
->ts
= var
->n
.sym
->ts
;
4596 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4597 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4598 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4599 && CLASS_DATA (var
->n
.sym
)->as
)))
4601 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4602 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4603 e
->ref
= gfc_get_ref ();
4604 e
->ref
->type
= REF_ARRAY
;
4605 e
->ref
->u
.ar
.type
= AR_FULL
;
4606 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4607 ? CLASS_DATA (var
->n
.sym
)->as
4615 /* Adds a full array reference to an expression, as needed. */
4618 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4621 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4626 ref
->next
= gfc_get_ref ();
4631 e
->ref
= gfc_get_ref ();
4634 ref
->type
= REF_ARRAY
;
4635 ref
->u
.ar
.type
= AR_FULL
;
4636 ref
->u
.ar
.dimen
= e
->rank
;
4637 ref
->u
.ar
.where
= e
->where
;
4643 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4647 lval
= gfc_get_expr ();
4648 lval
->expr_type
= EXPR_VARIABLE
;
4649 lval
->where
= sym
->declared_at
;
4651 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4653 /* It will always be a full array. */
4654 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4655 lval
->rank
= as
? as
->rank
: 0;
4657 gfc_add_full_array_ref (lval
, as
);
4662 /* Returns the array_spec of a full array expression. A NULL is
4663 returned otherwise. */
4665 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4670 if (expr
->rank
== 0)
4673 /* Follow any component references. */
4674 if (expr
->expr_type
== EXPR_VARIABLE
4675 || expr
->expr_type
== EXPR_CONSTANT
)
4678 as
= expr
->symtree
->n
.sym
->as
;
4682 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4687 as
= ref
->u
.c
.component
->as
;
4695 switch (ref
->u
.ar
.type
)
4718 /* General expression traversal function. */
4721 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4722 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4727 gfc_actual_arglist
*args
;
4734 if ((*func
) (expr
, sym
, &f
))
4737 if (expr
->ts
.type
== BT_CHARACTER
4739 && expr
->ts
.u
.cl
->length
4740 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4741 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4744 switch (expr
->expr_type
)
4749 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4751 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4759 case EXPR_SUBSTRING
:
4762 case EXPR_STRUCTURE
:
4764 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4765 c
; c
= gfc_constructor_next (c
))
4767 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4771 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4773 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4775 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4777 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4784 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4786 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4802 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4804 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4806 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4808 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4814 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4816 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4821 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4822 && ref
->u
.c
.component
->ts
.u
.cl
4823 && ref
->u
.c
.component
->ts
.u
.cl
->length
4824 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4826 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4830 if (ref
->u
.c
.component
->as
)
4831 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4832 + ref
->u
.c
.component
->as
->corank
; i
++)
4834 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4837 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4851 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4854 expr_set_symbols_referenced (gfc_expr
*expr
,
4855 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4856 int *f ATTRIBUTE_UNUSED
)
4858 if (expr
->expr_type
!= EXPR_VARIABLE
)
4860 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4865 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4867 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4871 /* Determine if an expression is a procedure pointer component and return
4872 the component in that case. Otherwise return NULL. */
4875 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4879 if (!expr
|| !expr
->ref
)
4886 if (ref
->type
== REF_COMPONENT
4887 && ref
->u
.c
.component
->attr
.proc_pointer
)
4888 return ref
->u
.c
.component
;
4894 /* Determine if an expression is a procedure pointer component. */
4897 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4899 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4903 /* Determine if an expression is a function with an allocatable class scalar
4906 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4908 if (expr
->expr_type
== EXPR_FUNCTION
4909 && expr
->value
.function
.esym
4910 && expr
->value
.function
.esym
->result
4911 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4912 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4913 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4920 /* Determine if an expression is a function with an allocatable class array
4923 gfc_is_class_array_function (gfc_expr
*expr
)
4925 if (expr
->expr_type
== EXPR_FUNCTION
4926 && expr
->value
.function
.esym
4927 && expr
->value
.function
.esym
->result
4928 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4929 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4930 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
4931 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
4938 /* Walk an expression tree and check each variable encountered for being typed.
4939 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4940 mode as is a basic arithmetic expression using those; this is for things in
4943 INTEGER :: arr(n), n
4944 INTEGER :: arr(n + 1), n
4946 The namespace is needed for IMPLICIT typing. */
4948 static gfc_namespace
* check_typed_ns
;
4951 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4952 int* f ATTRIBUTE_UNUSED
)
4956 if (e
->expr_type
!= EXPR_VARIABLE
)
4959 gcc_assert (e
->symtree
);
4960 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4967 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4971 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4975 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4976 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4978 if (e
->expr_type
== EXPR_OP
)
4982 gcc_assert (e
->value
.op
.op1
);
4983 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4985 if (t
&& e
->value
.op
.op2
)
4986 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4992 /* Otherwise, walk the expression and do it strictly. */
4993 check_typed_ns
= ns
;
4994 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4996 return error_found
? false : true;
5000 /* This function returns true if it contains any references to PDT KIND
5001 or LEN parameters. */
5004 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
5005 int* f ATTRIBUTE_UNUSED
)
5007 if (e
->expr_type
!= EXPR_VARIABLE
)
5010 gcc_assert (e
->symtree
);
5011 if (e
->symtree
->n
.sym
->attr
.pdt_kind
5012 || e
->symtree
->n
.sym
->attr
.pdt_len
)
5020 gfc_derived_parameter_expr (gfc_expr
*e
)
5022 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5026 /* This function returns the overall type of a type parameter spec list.
5027 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5028 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5029 unless derived is not NULL. In this latter case, all the LEN parameters
5030 must be either assumed or deferred for the return argument to be set to
5031 anything other than SPEC_EXPLICIT. */
5034 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5036 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5038 bool seen_assumed
= false;
5039 bool seen_deferred
= false;
5041 if (derived
== NULL
)
5043 for (; param_list
; param_list
= param_list
->next
)
5044 if (param_list
->spec_type
== SPEC_ASSUMED
5045 || param_list
->spec_type
== SPEC_DEFERRED
)
5046 return param_list
->spec_type
;
5050 for (; param_list
; param_list
= param_list
->next
)
5052 c
= gfc_find_component (derived
, param_list
->name
,
5054 gcc_assert (c
!= NULL
);
5055 if (c
->attr
.pdt_kind
)
5057 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5058 return SPEC_EXPLICIT
;
5059 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5060 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5061 if (seen_assumed
&& seen_deferred
)
5062 return SPEC_EXPLICIT
;
5064 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5071 gfc_ref_this_image (gfc_ref
*ref
)
5075 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5077 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5078 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5085 gfc_find_team_co (gfc_expr
*e
)
5089 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5090 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5091 return ref
->u
.ar
.team
;
5093 if (e
->value
.function
.actual
->expr
)
5094 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5096 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5097 return ref
->u
.ar
.team
;
5103 gfc_find_stat_co (gfc_expr
*e
)
5107 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5108 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5109 return ref
->u
.ar
.stat
;
5111 if (e
->value
.function
.actual
->expr
)
5112 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5114 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5115 return ref
->u
.ar
.stat
;
5121 gfc_is_coindexed (gfc_expr
*e
)
5125 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5126 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5127 return !gfc_ref_this_image (ref
);
5133 /* Coarrays are variables with a corank but not being coindexed. However, also
5134 the following is a coarray: A subobject of a coarray is a coarray if it does
5135 not have any cosubscripts, vector subscripts, allocatable component
5136 selection, or pointer component selection. (F2008, 2.4.7) */
5139 gfc_is_coarray (gfc_expr
*e
)
5143 gfc_component
*comp
;
5148 if (e
->expr_type
!= EXPR_VARIABLE
)
5152 sym
= e
->symtree
->n
.sym
;
5154 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5155 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5157 coarray
= sym
->attr
.codimension
;
5159 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5163 comp
= ref
->u
.c
.component
;
5164 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5165 && (CLASS_DATA (comp
)->attr
.class_pointer
5166 || CLASS_DATA (comp
)->attr
.allocatable
))
5169 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5171 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5174 coarray
= comp
->attr
.codimension
;
5182 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5188 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5189 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5200 return coarray
&& !coindexed
;
5205 gfc_get_corank (gfc_expr
*e
)
5210 if (!gfc_is_coarray (e
))
5213 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5214 corank
= e
->ts
.u
.derived
->components
->as
5215 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5217 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5219 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5221 if (ref
->type
== REF_ARRAY
)
5222 corank
= ref
->u
.ar
.as
->corank
;
5223 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5230 /* Check whether the expression has an ultimate allocatable component.
5231 Being itself allocatable does not count. */
5233 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5235 gfc_ref
*ref
, *last
= NULL
;
5237 if (e
->expr_type
!= EXPR_VARIABLE
)
5240 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5241 if (ref
->type
== REF_COMPONENT
)
5244 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5245 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5246 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5247 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5251 if (e
->ts
.type
== BT_CLASS
)
5252 return CLASS_DATA (e
)->attr
.alloc_comp
;
5253 else if (e
->ts
.type
== BT_DERIVED
)
5254 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5260 /* Check whether the expression has an pointer component.
5261 Being itself a pointer does not count. */
5263 gfc_has_ultimate_pointer (gfc_expr
*e
)
5265 gfc_ref
*ref
, *last
= NULL
;
5267 if (e
->expr_type
!= EXPR_VARIABLE
)
5270 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5271 if (ref
->type
== REF_COMPONENT
)
5274 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5275 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5276 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5277 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5281 if (e
->ts
.type
== BT_CLASS
)
5282 return CLASS_DATA (e
)->attr
.pointer_comp
;
5283 else if (e
->ts
.type
== BT_DERIVED
)
5284 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5290 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5291 Note: A scalar is not regarded as "simply contiguous" by the standard.
5292 if bool is not strict, some further checks are done - for instance,
5293 a "(::1)" is accepted. */
5296 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5300 gfc_array_ref
*ar
= NULL
;
5301 gfc_ref
*ref
, *part_ref
= NULL
;
5304 if (expr
->expr_type
== EXPR_FUNCTION
)
5306 if (expr
->value
.function
.esym
)
5307 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5310 /* We have to jump through some hoops if this is a vtab entry. */
5314 s
= expr
->symtree
->n
.sym
;
5315 if (s
->ts
.type
!= BT_CLASS
)
5319 for (r
= expr
->ref
; r
; r
= r
->next
)
5320 if (r
->type
== REF_COMPONENT
)
5323 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5324 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5327 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5330 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5333 if (!permit_element
&& expr
->rank
== 0)
5336 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5339 return false; /* Array shall be last part-ref. */
5341 if (ref
->type
== REF_COMPONENT
)
5343 else if (ref
->type
== REF_SUBSTRING
)
5345 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5349 sym
= expr
->symtree
->n
.sym
;
5350 if (expr
->ts
.type
!= BT_CLASS
5352 && !part_ref
->u
.c
.component
->attr
.contiguous
5353 && part_ref
->u
.c
.component
->attr
.pointer
)
5355 && !sym
->attr
.contiguous
5356 && (sym
->attr
.pointer
5357 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5358 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5361 if (!ar
|| ar
->type
== AR_FULL
)
5364 gcc_assert (ar
->type
== AR_SECTION
);
5366 /* Check for simply contiguous array */
5368 for (i
= 0; i
< ar
->dimen
; i
++)
5370 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5373 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5379 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5382 /* If the previous section was not contiguous, that's an error,
5383 unless we have effective only one element and checking is not
5385 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5386 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5387 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5388 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5389 ar
->end
[i
]->value
.integer
) != 0))
5392 /* Following the standard, "(::1)" or - if known at compile time -
5393 "(lbound:ubound)" are not simply contiguous; if strict
5394 is false, they are regarded as simply contiguous. */
5395 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5396 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5397 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5401 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5402 || !ar
->as
->lower
[i
]
5403 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5404 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5405 ar
->as
->lower
[i
]->value
.integer
) != 0))
5409 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5410 || !ar
->as
->upper
[i
]
5411 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5412 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5413 ar
->as
->upper
[i
]->value
.integer
) != 0))
5421 /* Build call to an intrinsic procedure. The number of arguments has to be
5422 passed (rather than ending the list with a NULL value) because we may
5423 want to add arguments but with a NULL-expression. */
5426 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5427 locus where
, unsigned numarg
, ...)
5430 gfc_actual_arglist
* atail
;
5431 gfc_intrinsic_sym
* isym
;
5434 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5436 isym
= gfc_intrinsic_function_by_id (id
);
5439 result
= gfc_get_expr ();
5440 result
->expr_type
= EXPR_FUNCTION
;
5441 result
->ts
= isym
->ts
;
5442 result
->where
= where
;
5443 result
->value
.function
.name
= mangled_name
;
5444 result
->value
.function
.isym
= isym
;
5446 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5447 gfc_commit_symbol (result
->symtree
->n
.sym
);
5448 gcc_assert (result
->symtree
5449 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5450 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5451 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5452 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5453 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5454 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5456 va_start (ap
, numarg
);
5458 for (i
= 0; i
< numarg
; ++i
)
5462 atail
->next
= gfc_get_actual_arglist ();
5463 atail
= atail
->next
;
5466 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5468 atail
->expr
= va_arg (ap
, gfc_expr
*);
5476 /* Check if an expression may appear in a variable definition context
5477 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5478 This is called from the various places when resolving
5479 the pieces that make up such a context.
5480 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5481 variables), some checks are not performed.
5483 Optionally, a possible error message can be suppressed if context is NULL
5484 and just the return status (true / false) be requested. */
5487 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5488 bool own_scope
, const char* context
)
5490 gfc_symbol
* sym
= NULL
;
5492 bool check_intentin
;
5494 symbol_attribute attr
;
5498 if (e
->expr_type
== EXPR_VARIABLE
)
5500 gcc_assert (e
->symtree
);
5501 sym
= e
->symtree
->n
.sym
;
5503 else if (e
->expr_type
== EXPR_FUNCTION
)
5505 gcc_assert (e
->symtree
);
5506 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5509 attr
= gfc_expr_attr (e
);
5510 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5512 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5515 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5516 " context (%s) at %L", context
, &e
->where
);
5520 else if (e
->expr_type
!= EXPR_VARIABLE
)
5523 gfc_error ("Non-variable expression in variable definition context (%s)"
5524 " at %L", context
, &e
->where
);
5528 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5531 gfc_error ("Named constant %qs in variable definition context (%s)"
5532 " at %L", sym
->name
, context
, &e
->where
);
5535 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5536 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5537 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5540 gfc_error ("%qs in variable definition context (%s) at %L is not"
5541 " a variable", sym
->name
, context
, &e
->where
);
5545 /* Find out whether the expr is a pointer; this also means following
5546 component references to the last one. */
5547 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5548 if (pointer
&& !is_pointer
)
5551 gfc_error ("Non-POINTER in pointer association context (%s)"
5552 " at %L", context
, &e
->where
);
5556 if (e
->ts
.type
== BT_DERIVED
5557 && e
->ts
.u
.derived
== NULL
)
5560 gfc_error ("Type inaccessible in variable definition context (%s) "
5561 "at %L", context
, &e
->where
);
5568 || (e
->ts
.type
== BT_DERIVED
5569 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5570 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5573 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5574 context
, &e
->where
);
5578 /* TS18508, C702/C203. */
5581 || (e
->ts
.type
== BT_DERIVED
5582 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5583 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5586 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5587 context
, &e
->where
);
5591 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5592 component of sub-component of a pointer; we need to distinguish
5593 assignment to a pointer component from pointer-assignment to a pointer
5594 component. Note that (normal) assignment to procedure pointers is not
5596 check_intentin
= !own_scope
;
5597 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5598 && CLASS_DATA (sym
))
5599 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5600 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5602 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5603 check_intentin
= false;
5604 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5606 ptr_component
= true;
5608 check_intentin
= false;
5611 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5613 if (pointer
&& is_pointer
)
5616 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5617 " association context (%s) at %L",
5618 sym
->name
, context
, &e
->where
);
5621 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5624 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5625 " definition context (%s) at %L",
5626 sym
->name
, context
, &e
->where
);
5631 /* PROTECTED and use-associated. */
5632 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5634 if (pointer
&& is_pointer
)
5637 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5638 " pointer association context (%s) at %L",
5639 sym
->name
, context
, &e
->where
);
5642 if (!pointer
&& !is_pointer
)
5645 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5646 " variable definition context (%s) at %L",
5647 sym
->name
, context
, &e
->where
);
5652 /* Variable not assignable from a PURE procedure but appears in
5653 variable definition context. */
5654 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5657 gfc_error ("Variable %qs can not appear in a variable definition"
5658 " context (%s) at %L in PURE procedure",
5659 sym
->name
, context
, &e
->where
);
5663 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5664 && gfc_impure_variable (sym
))
5669 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5671 sym
= ns
->proc_name
;
5674 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5676 sym
->attr
.implicit_pure
= 0;
5681 /* Check variable definition context for associate-names. */
5682 if (!pointer
&& sym
->assoc
)
5685 gfc_association_list
* assoc
;
5687 gcc_assert (sym
->assoc
->target
);
5689 /* If this is a SELECT TYPE temporary (the association is used internally
5690 for SELECT TYPE), silently go over to the target. */
5691 if (sym
->attr
.select_type_temporary
)
5693 gfc_expr
* t
= sym
->assoc
->target
;
5695 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5696 name
= t
->symtree
->name
;
5698 if (t
->symtree
->n
.sym
->assoc
)
5699 assoc
= t
->symtree
->n
.sym
->assoc
;
5708 gcc_assert (name
&& assoc
);
5710 /* Is association to a valid variable? */
5711 if (!assoc
->variable
)
5715 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5716 gfc_error ("%qs at %L associated to vector-indexed target can"
5717 " not be used in a variable definition context (%s)",
5718 name
, &e
->where
, context
);
5720 gfc_error ("%qs at %L associated to expression can"
5721 " not be used in a variable definition context (%s)",
5722 name
, &e
->where
, context
);
5727 /* Target must be allowed to appear in a variable definition context. */
5728 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5731 gfc_error ("Associate-name %qs can not appear in a variable"
5732 " definition context (%s) at %L because its target"
5733 " at %L can not, either",
5734 name
, context
, &e
->where
,
5735 &assoc
->target
->where
);
5740 /* Check for same value in vector expression subscript. */
5743 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5744 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5745 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5746 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5747 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5749 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5750 if (arr
->expr_type
== EXPR_ARRAY
)
5752 gfc_constructor
*c
, *n
;
5755 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5756 c
!= NULL
; c
= gfc_constructor_next (c
))
5758 if (c
== NULL
|| c
->iterator
!= NULL
)
5763 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5764 n
= gfc_constructor_next (n
))
5766 if (n
->iterator
!= NULL
)
5770 if (gfc_dep_compare_expr (ec
, en
) == 0)
5773 gfc_error_now ("Elements with the same value "
5774 "at %L and %L in vector "
5775 "subscript in a variable "
5776 "definition context (%s)",
5777 &(ec
->where
), &(en
->where
),