1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
29 #include "target-memory.h" /* for gfc_convert_boz */
30 #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 NULL");
153 e
->expr_type
= EXPR_CONSTANT
;
161 mpz_init (e
->value
.integer
);
165 gfc_set_model_kind (kind
);
166 mpfr_init (e
->value
.real
);
170 gfc_set_model_kind (kind
);
171 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
182 /* Get a new expression node that is an string constant.
183 If no string is passed, a string of len is allocated,
184 blanked and null-terminated. */
187 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, int len
)
194 dest
= gfc_get_wide_string (len
+ 1);
195 gfc_wide_memset (dest
, ' ', len
);
199 dest
= gfc_char_to_widechar (src
);
201 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
202 where
? where
: &gfc_current_locus
);
203 e
->value
.character
.string
= dest
;
204 e
->value
.character
.length
= len
;
210 /* Get a new expression node that is an integer constant. */
213 gfc_get_int_expr (int kind
, locus
*where
, int value
)
216 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
217 where
? where
: &gfc_current_locus
);
219 mpz_set_si (p
->value
.integer
, value
);
225 /* Get a new expression node that is a logical constant. */
228 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
231 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
232 where
? where
: &gfc_current_locus
);
234 p
->value
.logical
= value
;
241 gfc_get_iokind_expr (locus
*where
, io_kind k
)
245 /* Set the types to something compatible with iokind. This is needed to
246 get through gfc_free_expr later since iokind really has no Basic Type,
250 e
->expr_type
= EXPR_CONSTANT
;
251 e
->ts
.type
= BT_LOGICAL
;
259 /* Given an expression pointer, return a copy of the expression. This
260 subroutine is recursive. */
263 gfc_copy_expr (gfc_expr
*p
)
275 switch (q
->expr_type
)
278 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
279 q
->value
.character
.string
= s
;
280 memcpy (s
, p
->value
.character
.string
,
281 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
285 /* Copy target representation, if it exists. */
286 if (p
->representation
.string
)
288 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
289 q
->representation
.string
= c
;
290 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
293 /* Copy the values of any pointer components of p->value. */
297 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
301 gfc_set_model_kind (q
->ts
.kind
);
302 mpfr_init (q
->value
.real
);
303 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
307 gfc_set_model_kind (q
->ts
.kind
);
308 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
309 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
313 if (p
->representation
.string
)
314 q
->value
.character
.string
315 = gfc_char_to_widechar (q
->representation
.string
);
318 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
319 q
->value
.character
.string
= s
;
321 /* This is the case for the C_NULL_CHAR named constant. */
322 if (p
->value
.character
.length
== 0
323 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
326 /* Need to set the length to 1 to make sure the NUL
327 terminator is copied. */
328 q
->value
.character
.length
= 1;
331 memcpy (s
, p
->value
.character
.string
,
332 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
341 break; /* Already done. */
345 /* Should never be reached. */
347 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
354 switch (q
->value
.op
.op
)
357 case INTRINSIC_PARENTHESES
:
358 case INTRINSIC_UPLUS
:
359 case INTRINSIC_UMINUS
:
360 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
363 default: /* Binary operators. */
364 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
365 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
372 q
->value
.function
.actual
=
373 gfc_copy_actual_arglist (p
->value
.function
.actual
);
378 q
->value
.compcall
.actual
=
379 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
380 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
385 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
393 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
395 q
->ref
= gfc_copy_ref (p
->ref
);
402 gfc_clear_shape (mpz_t
*shape
, int rank
)
406 for (i
= 0; i
< rank
; i
++)
407 mpz_clear (shape
[i
]);
412 gfc_free_shape (mpz_t
**shape
, int rank
)
417 gfc_clear_shape (*shape
, rank
);
423 /* Workhorse function for gfc_free_expr() that frees everything
424 beneath an expression node, but not the node itself. This is
425 useful when we want to simplify a node and replace it with
426 something else or the expression node belongs to another structure. */
429 free_expr0 (gfc_expr
*e
)
431 switch (e
->expr_type
)
434 /* Free any parts of the value that need freeing. */
438 mpz_clear (e
->value
.integer
);
442 mpfr_clear (e
->value
.real
);
446 free (e
->value
.character
.string
);
450 mpc_clear (e
->value
.complex);
457 /* Free the representation. */
458 free (e
->representation
.string
);
463 if (e
->value
.op
.op1
!= NULL
)
464 gfc_free_expr (e
->value
.op
.op1
);
465 if (e
->value
.op
.op2
!= NULL
)
466 gfc_free_expr (e
->value
.op
.op2
);
470 gfc_free_actual_arglist (e
->value
.function
.actual
);
475 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
483 gfc_constructor_free (e
->value
.constructor
);
487 free (e
->value
.character
.string
);
494 gfc_internal_error ("free_expr0(): Bad expr type");
497 /* Free a shape array. */
498 gfc_free_shape (&e
->shape
, e
->rank
);
500 gfc_free_ref_list (e
->ref
);
502 memset (e
, '\0', sizeof (gfc_expr
));
506 /* Free an expression node and everything beneath it. */
509 gfc_free_expr (gfc_expr
*e
)
518 /* Free an argument list and everything below it. */
521 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
523 gfc_actual_arglist
*a2
;
528 gfc_free_expr (a1
->expr
);
535 /* Copy an arglist structure and all of the arguments. */
538 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
540 gfc_actual_arglist
*head
, *tail
, *new_arg
;
544 for (; p
; p
= p
->next
)
546 new_arg
= gfc_get_actual_arglist ();
549 new_arg
->expr
= gfc_copy_expr (p
->expr
);
550 new_arg
->next
= NULL
;
555 tail
->next
= new_arg
;
564 /* Free a list of reference structures. */
567 gfc_free_ref_list (gfc_ref
*p
)
579 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
581 gfc_free_expr (p
->u
.ar
.start
[i
]);
582 gfc_free_expr (p
->u
.ar
.end
[i
]);
583 gfc_free_expr (p
->u
.ar
.stride
[i
]);
589 gfc_free_expr (p
->u
.ss
.start
);
590 gfc_free_expr (p
->u
.ss
.end
);
602 /* Graft the *src expression onto the *dest subexpression. */
605 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
613 /* Try to extract an integer constant from the passed expression node.
614 Returns an error message or NULL if the result is set. It is
615 tempting to generate an error and return SUCCESS or FAILURE, but
616 failure is OK for some callers. */
619 gfc_extract_int (gfc_expr
*expr
, int *result
)
621 if (expr
->expr_type
!= EXPR_CONSTANT
)
622 return _("Constant expression required at %C");
624 if (expr
->ts
.type
!= BT_INTEGER
)
625 return _("Integer expression required at %C");
627 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
628 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
630 return _("Integer value too large in expression at %C");
633 *result
= (int) mpz_get_si (expr
->value
.integer
);
639 /* Recursively copy a list of reference structures. */
642 gfc_copy_ref (gfc_ref
*src
)
650 dest
= gfc_get_ref ();
651 dest
->type
= src
->type
;
656 ar
= gfc_copy_array_ref (&src
->u
.ar
);
662 dest
->u
.c
= src
->u
.c
;
666 dest
->u
.ss
= src
->u
.ss
;
667 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
668 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
672 dest
->next
= gfc_copy_ref (src
->next
);
678 /* Detect whether an expression has any vector index array references. */
681 gfc_has_vector_index (gfc_expr
*e
)
685 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
686 if (ref
->type
== REF_ARRAY
)
687 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
688 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
694 /* Copy a shape array. */
697 gfc_copy_shape (mpz_t
*shape
, int rank
)
705 new_shape
= gfc_get_shape (rank
);
707 for (n
= 0; n
< rank
; n
++)
708 mpz_init_set (new_shape
[n
], shape
[n
]);
714 /* Copy a shape array excluding dimension N, where N is an integer
715 constant expression. Dimensions are numbered in Fortran style --
718 So, if the original shape array contains R elements
719 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
720 the result contains R-1 elements:
721 { s1 ... sN-1 sN+1 ... sR-1}
723 If anything goes wrong -- N is not a constant, its value is out
724 of range -- or anything else, just returns NULL. */
727 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
729 mpz_t
*new_shape
, *s
;
735 || dim
->expr_type
!= EXPR_CONSTANT
736 || dim
->ts
.type
!= BT_INTEGER
)
739 n
= mpz_get_si (dim
->value
.integer
);
740 n
--; /* Convert to zero based index. */
741 if (n
< 0 || n
>= rank
)
744 s
= new_shape
= gfc_get_shape (rank
- 1);
746 for (i
= 0; i
< rank
; i
++)
750 mpz_init_set (*s
, shape
[i
]);
758 /* Return the maximum kind of two expressions. In general, higher
759 kind numbers mean more precision for numeric types. */
762 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
764 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
768 /* Returns nonzero if the type is numeric, zero otherwise. */
771 numeric_type (bt type
)
773 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
777 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
780 gfc_numeric_ts (gfc_typespec
*ts
)
782 return numeric_type (ts
->type
);
786 /* Return an expression node with an optional argument list attached.
787 A variable number of gfc_expr pointers are strung together in an
788 argument list with a NULL pointer terminating the list. */
791 gfc_build_conversion (gfc_expr
*e
)
796 p
->expr_type
= EXPR_FUNCTION
;
798 p
->value
.function
.actual
= NULL
;
800 p
->value
.function
.actual
= gfc_get_actual_arglist ();
801 p
->value
.function
.actual
->expr
= e
;
807 /* Given an expression node with some sort of numeric binary
808 expression, insert type conversions required to make the operands
809 have the same type. Conversion warnings are disabled if wconversion
812 The exception is that the operands of an exponential don't have to
813 have the same type. If possible, the base is promoted to the type
814 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
815 1.0**2 stays as it is. */
818 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
822 op1
= e
->value
.op
.op1
;
823 op2
= e
->value
.op
.op2
;
825 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
827 gfc_clear_ts (&e
->ts
);
831 /* Kind conversions of same type. */
832 if (op1
->ts
.type
== op2
->ts
.type
)
834 if (op1
->ts
.kind
== op2
->ts
.kind
)
836 /* No type conversions. */
841 if (op1
->ts
.kind
> op2
->ts
.kind
)
842 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
844 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
850 /* Integer combined with real or complex. */
851 if (op2
->ts
.type
== BT_INTEGER
)
855 /* Special case for ** operator. */
856 if (e
->value
.op
.op
== INTRINSIC_POWER
)
859 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
863 if (op1
->ts
.type
== BT_INTEGER
)
866 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
870 /* Real combined with complex. */
871 e
->ts
.type
= BT_COMPLEX
;
872 if (op1
->ts
.kind
> op2
->ts
.kind
)
873 e
->ts
.kind
= op1
->ts
.kind
;
875 e
->ts
.kind
= op2
->ts
.kind
;
876 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
877 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
878 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
879 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
886 /* Function to determine if an expression is constant or not. This
887 function expects that the expression has already been simplified. */
890 gfc_is_constant_expr (gfc_expr
*e
)
893 gfc_actual_arglist
*arg
;
899 switch (e
->expr_type
)
902 return (gfc_is_constant_expr (e
->value
.op
.op1
)
903 && (e
->value
.op
.op2
== NULL
904 || gfc_is_constant_expr (e
->value
.op
.op2
)));
912 gcc_assert (e
->symtree
|| e
->value
.function
.esym
913 || e
->value
.function
.isym
);
915 /* Call to intrinsic with at least one argument. */
916 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
918 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
919 if (!gfc_is_constant_expr (arg
->expr
))
923 /* Specification functions are constant. */
924 /* F95, 7.1.6.2; F2003, 7.1.7 */
927 sym
= e
->symtree
->n
.sym
;
928 if (e
->value
.function
.esym
)
929 sym
= e
->value
.function
.esym
;
932 && sym
->attr
.function
934 && !sym
->attr
.intrinsic
935 && !sym
->attr
.recursive
936 && sym
->attr
.proc
!= PROC_INTERNAL
937 && sym
->attr
.proc
!= PROC_ST_FUNCTION
938 && sym
->attr
.proc
!= PROC_UNKNOWN
939 && sym
->formal
== NULL
)
942 if (e
->value
.function
.isym
943 && (e
->value
.function
.isym
->elemental
944 || e
->value
.function
.isym
->pure
945 || e
->value
.function
.isym
->inquiry
946 || e
->value
.function
.isym
->transformational
))
956 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
957 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
961 c
= gfc_constructor_first (e
->value
.constructor
);
962 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
963 return gfc_constant_ac (e
);
965 for (; c
; c
= gfc_constructor_next (c
))
966 if (!gfc_is_constant_expr (c
->expr
))
973 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
979 /* Is true if an array reference is followed by a component or substring
982 is_subref_array (gfc_expr
* e
)
987 if (e
->expr_type
!= EXPR_VARIABLE
)
990 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
994 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
996 if (ref
->type
== REF_ARRAY
997 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1001 && ref
->type
!= REF_ARRAY
)
1008 /* Try to collapse intrinsic expressions. */
1011 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1013 gfc_intrinsic_op op
;
1014 gfc_expr
*op1
, *op2
, *result
;
1016 if (p
->value
.op
.op
== INTRINSIC_USER
)
1019 op1
= p
->value
.op
.op1
;
1020 op2
= p
->value
.op
.op2
;
1021 op
= p
->value
.op
.op
;
1023 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1025 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1028 if (!gfc_is_constant_expr (op1
)
1029 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1033 p
->value
.op
.op1
= NULL
;
1034 p
->value
.op
.op2
= NULL
;
1038 case INTRINSIC_PARENTHESES
:
1039 result
= gfc_parentheses (op1
);
1042 case INTRINSIC_UPLUS
:
1043 result
= gfc_uplus (op1
);
1046 case INTRINSIC_UMINUS
:
1047 result
= gfc_uminus (op1
);
1050 case INTRINSIC_PLUS
:
1051 result
= gfc_add (op1
, op2
);
1054 case INTRINSIC_MINUS
:
1055 result
= gfc_subtract (op1
, op2
);
1058 case INTRINSIC_TIMES
:
1059 result
= gfc_multiply (op1
, op2
);
1062 case INTRINSIC_DIVIDE
:
1063 result
= gfc_divide (op1
, op2
);
1066 case INTRINSIC_POWER
:
1067 result
= gfc_power (op1
, op2
);
1070 case INTRINSIC_CONCAT
:
1071 result
= gfc_concat (op1
, op2
);
1075 case INTRINSIC_EQ_OS
:
1076 result
= gfc_eq (op1
, op2
, op
);
1080 case INTRINSIC_NE_OS
:
1081 result
= gfc_ne (op1
, op2
, op
);
1085 case INTRINSIC_GT_OS
:
1086 result
= gfc_gt (op1
, op2
, op
);
1090 case INTRINSIC_GE_OS
:
1091 result
= gfc_ge (op1
, op2
, op
);
1095 case INTRINSIC_LT_OS
:
1096 result
= gfc_lt (op1
, op2
, op
);
1100 case INTRINSIC_LE_OS
:
1101 result
= gfc_le (op1
, op2
, op
);
1105 result
= gfc_not (op1
);
1109 result
= gfc_and (op1
, op2
);
1113 result
= gfc_or (op1
, op2
);
1117 result
= gfc_eqv (op1
, op2
);
1120 case INTRINSIC_NEQV
:
1121 result
= gfc_neqv (op1
, op2
);
1125 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1130 gfc_free_expr (op1
);
1131 gfc_free_expr (op2
);
1135 result
->rank
= p
->rank
;
1136 result
->where
= p
->where
;
1137 gfc_replace_expr (p
, result
);
1143 /* Subroutine to simplify constructor expressions. Mutually recursive
1144 with gfc_simplify_expr(). */
1147 simplify_constructor (gfc_constructor_base base
, int type
)
1152 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1155 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1156 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1157 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1162 /* Try and simplify a copy. Replace the original if successful
1163 but keep going through the constructor at all costs. Not
1164 doing so can make a dog's dinner of complicated things. */
1165 p
= gfc_copy_expr (c
->expr
);
1167 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1173 gfc_replace_expr (c
->expr
, p
);
1181 /* Pull a single array element out of an array constructor. */
1184 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1185 gfc_constructor
**rval
)
1187 unsigned long nelemen
;
1193 gfc_constructor
*cons
;
1200 mpz_init_set_ui (offset
, 0);
1203 mpz_init_set_ui (span
, 1);
1204 for (i
= 0; i
< ar
->dimen
; i
++)
1206 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1207 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1214 e
= gfc_copy_expr (ar
->start
[i
]);
1215 if (e
->expr_type
!= EXPR_CONSTANT
)
1221 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1222 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1224 /* Check the bounds. */
1225 if ((ar
->as
->upper
[i
]
1226 && mpz_cmp (e
->value
.integer
,
1227 ar
->as
->upper
[i
]->value
.integer
) > 0)
1228 || (mpz_cmp (e
->value
.integer
,
1229 ar
->as
->lower
[i
]->value
.integer
) < 0))
1231 gfc_error ("Index in dimension %d is out of bounds "
1232 "at %L", i
+ 1, &ar
->c_where
[i
]);
1238 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1239 mpz_mul (delta
, delta
, span
);
1240 mpz_add (offset
, offset
, delta
);
1242 mpz_set_ui (tmp
, 1);
1243 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1244 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1245 mpz_mul (span
, span
, tmp
);
1248 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1249 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1270 /* Find a component of a structure constructor. */
1272 static gfc_constructor
*
1273 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1275 gfc_component
*comp
;
1276 gfc_component
*pick
;
1277 gfc_constructor
*c
= gfc_constructor_first (base
);
1279 comp
= ref
->u
.c
.sym
->components
;
1280 pick
= ref
->u
.c
.component
;
1281 while (comp
!= pick
)
1284 c
= gfc_constructor_next (c
);
1291 /* Replace an expression with the contents of a constructor, removing
1292 the subobject reference in the process. */
1295 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1305 e
= gfc_copy_expr (p
);
1306 e
->ref
= p
->ref
->next
;
1307 p
->ref
->next
= NULL
;
1308 gfc_replace_expr (p
, e
);
1312 /* Pull an array section out of an array constructor. */
1315 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1322 long unsigned one
= 1;
1324 mpz_t start
[GFC_MAX_DIMENSIONS
];
1325 mpz_t end
[GFC_MAX_DIMENSIONS
];
1326 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1327 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1328 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1333 gfc_constructor_base base
;
1334 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1344 base
= expr
->value
.constructor
;
1345 expr
->value
.constructor
= NULL
;
1347 rank
= ref
->u
.ar
.as
->rank
;
1349 if (expr
->shape
== NULL
)
1350 expr
->shape
= gfc_get_shape (rank
);
1352 mpz_init_set_ui (delta_mpz
, one
);
1353 mpz_init_set_ui (nelts
, one
);
1356 /* Do the initialization now, so that we can cleanup without
1357 keeping track of where we were. */
1358 for (d
= 0; d
< rank
; d
++)
1360 mpz_init (delta
[d
]);
1361 mpz_init (start
[d
]);
1364 mpz_init (stride
[d
]);
1368 /* Build the counters to clock through the array reference. */
1370 for (d
= 0; d
< rank
; d
++)
1372 /* Make this stretch of code easier on the eye! */
1373 begin
= ref
->u
.ar
.start
[d
];
1374 finish
= ref
->u
.ar
.end
[d
];
1375 step
= ref
->u
.ar
.stride
[d
];
1376 lower
= ref
->u
.ar
.as
->lower
[d
];
1377 upper
= ref
->u
.ar
.as
->upper
[d
];
1379 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1381 gfc_constructor
*ci
;
1384 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1390 gcc_assert (begin
->rank
== 1);
1391 /* Zero-sized arrays have no shape and no elements, stop early. */
1394 mpz_init_set_ui (nelts
, 0);
1398 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1399 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1400 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1401 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1404 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1406 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1407 || mpz_cmp (ci
->expr
->value
.integer
,
1408 lower
->value
.integer
) < 0)
1410 gfc_error ("index in dimension %d is out of bounds "
1411 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1419 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1420 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1421 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1427 /* Obtain the stride. */
1429 mpz_set (stride
[d
], step
->value
.integer
);
1431 mpz_set_ui (stride
[d
], one
);
1433 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1434 mpz_set_ui (stride
[d
], one
);
1436 /* Obtain the start value for the index. */
1438 mpz_set (start
[d
], begin
->value
.integer
);
1440 mpz_set (start
[d
], lower
->value
.integer
);
1442 mpz_set (ctr
[d
], start
[d
]);
1444 /* Obtain the end value for the index. */
1446 mpz_set (end
[d
], finish
->value
.integer
);
1448 mpz_set (end
[d
], upper
->value
.integer
);
1450 /* Separate 'if' because elements sometimes arrive with
1452 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1453 mpz_set (end
[d
], begin
->value
.integer
);
1455 /* Check the bounds. */
1456 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1457 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1458 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1459 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1461 gfc_error ("index in dimension %d is out of bounds "
1462 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1467 /* Calculate the number of elements and the shape. */
1468 mpz_set (tmp_mpz
, stride
[d
]);
1469 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1470 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1471 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1472 mpz_mul (nelts
, nelts
, tmp_mpz
);
1474 /* An element reference reduces the rank of the expression; don't
1475 add anything to the shape array. */
1476 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1477 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1480 /* Calculate the 'stride' (=delta) for conversion of the
1481 counter values into the index along the constructor. */
1482 mpz_set (delta
[d
], delta_mpz
);
1483 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1484 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1485 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1489 cons
= gfc_constructor_first (base
);
1491 /* Now clock through the array reference, calculating the index in
1492 the source constructor and transferring the elements to the new
1494 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1496 mpz_init_set_ui (ptr
, 0);
1499 for (d
= 0; d
< rank
; d
++)
1501 mpz_set (tmp_mpz
, ctr
[d
]);
1502 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1503 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1504 mpz_add (ptr
, ptr
, tmp_mpz
);
1506 if (!incr_ctr
) continue;
1508 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1510 gcc_assert(vecsub
[d
]);
1512 if (!gfc_constructor_next (vecsub
[d
]))
1513 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1516 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1519 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1523 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1525 if (mpz_cmp_ui (stride
[d
], 0) > 0
1526 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1527 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1528 mpz_set (ctr
[d
], start
[d
]);
1534 limit
= mpz_get_ui (ptr
);
1535 if (limit
>= gfc_option
.flag_max_array_constructor
)
1537 gfc_error ("The number of elements in the array constructor "
1538 "at %L requires an increase of the allowed %d "
1539 "upper limit. See -fmax-array-constructor "
1540 "option", &expr
->where
,
1541 gfc_option
.flag_max_array_constructor
);
1545 cons
= gfc_constructor_lookup (base
, limit
);
1547 gfc_constructor_append_expr (&expr
->value
.constructor
,
1548 gfc_copy_expr (cons
->expr
), NULL
);
1555 mpz_clear (delta_mpz
);
1556 mpz_clear (tmp_mpz
);
1558 for (d
= 0; d
< rank
; d
++)
1560 mpz_clear (delta
[d
]);
1561 mpz_clear (start
[d
]);
1564 mpz_clear (stride
[d
]);
1566 gfc_constructor_free (base
);
1570 /* Pull a substring out of an expression. */
1573 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1580 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1581 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1584 *newp
= gfc_copy_expr (p
);
1585 free ((*newp
)->value
.character
.string
);
1587 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1588 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1589 length
= end
- start
+ 1;
1591 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1592 (*newp
)->value
.character
.length
= length
;
1593 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1594 length
* sizeof (gfc_char_t
));
1601 /* Simplify a subobject reference of a constructor. This occurs when
1602 parameter variable values are substituted. */
1605 simplify_const_ref (gfc_expr
*p
)
1607 gfc_constructor
*cons
, *c
;
1613 switch (p
->ref
->type
)
1616 switch (p
->ref
->u
.ar
.type
)
1619 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1620 will generate this. */
1621 if (p
->expr_type
!= EXPR_ARRAY
)
1623 remove_subobject_ref (p
, NULL
);
1626 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1633 remove_subobject_ref (p
, cons
);
1637 if (find_array_section (p
, p
->ref
) == FAILURE
)
1639 p
->ref
->u
.ar
.type
= AR_FULL
;
1644 if (p
->ref
->next
!= NULL
1645 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1647 for (c
= gfc_constructor_first (p
->value
.constructor
);
1648 c
; c
= gfc_constructor_next (c
))
1650 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1651 if (simplify_const_ref (c
->expr
) == FAILURE
)
1655 if (p
->ts
.type
== BT_DERIVED
1657 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1659 /* There may have been component references. */
1660 p
->ts
= c
->expr
->ts
;
1664 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1666 if (p
->ts
.type
== BT_CHARACTER
1667 && last_ref
->type
== REF_SUBSTRING
)
1669 /* If this is a CHARACTER array and we possibly took
1670 a substring out of it, update the type-spec's
1671 character length according to the first element
1672 (as all should have the same length). */
1674 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1676 const gfc_expr
* first
= c
->expr
;
1677 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1678 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1679 string_len
= first
->value
.character
.length
;
1685 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1688 gfc_free_expr (p
->ts
.u
.cl
->length
);
1691 = gfc_get_int_expr (gfc_default_integer_kind
,
1695 gfc_free_ref_list (p
->ref
);
1706 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1707 remove_subobject_ref (p
, cons
);
1711 if (find_substring_ref (p
, &newp
) == FAILURE
)
1714 gfc_replace_expr (p
, newp
);
1715 gfc_free_ref_list (p
->ref
);
1725 /* Simplify a chain of references. */
1728 simplify_ref_chain (gfc_ref
*ref
, int type
)
1732 for (; ref
; ref
= ref
->next
)
1737 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1739 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1741 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1743 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1749 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1751 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1763 /* Try to substitute the value of a parameter variable. */
1766 simplify_parameter_variable (gfc_expr
*p
, int type
)
1771 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1777 /* Do not copy subobject refs for constant. */
1778 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1779 e
->ref
= gfc_copy_ref (p
->ref
);
1780 t
= gfc_simplify_expr (e
, type
);
1782 /* Only use the simplification if it eliminated all subobject references. */
1783 if (t
== SUCCESS
&& !e
->ref
)
1784 gfc_replace_expr (p
, e
);
1791 /* Given an expression, simplify it by collapsing constant
1792 expressions. Most simplification takes place when the expression
1793 tree is being constructed. If an intrinsic function is simplified
1794 at some point, we get called again to collapse the result against
1797 We work by recursively simplifying expression nodes, simplifying
1798 intrinsic functions where possible, which can lead to further
1799 constant collapsing. If an operator has constant operand(s), we
1800 rip the expression apart, and rebuild it, hoping that it becomes
1803 The expression type is defined for:
1804 0 Basic expression parsing
1805 1 Simplifying array constructors -- will substitute
1807 Returns FAILURE on error, SUCCESS otherwise.
1808 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1811 gfc_simplify_expr (gfc_expr
*p
, int type
)
1813 gfc_actual_arglist
*ap
;
1818 switch (p
->expr_type
)
1825 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1826 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1829 if (p
->value
.function
.isym
!= NULL
1830 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1835 case EXPR_SUBSTRING
:
1836 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1839 if (gfc_is_constant_expr (p
))
1845 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1847 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1848 start
--; /* Convert from one-based to zero-based. */
1851 end
= p
->value
.character
.length
;
1852 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1853 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1858 s
= gfc_get_wide_string (end
- start
+ 2);
1859 memcpy (s
, p
->value
.character
.string
+ start
,
1860 (end
- start
) * sizeof (gfc_char_t
));
1861 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1862 free (p
->value
.character
.string
);
1863 p
->value
.character
.string
= s
;
1864 p
->value
.character
.length
= end
- start
;
1865 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1866 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1868 p
->value
.character
.length
);
1869 gfc_free_ref_list (p
->ref
);
1871 p
->expr_type
= EXPR_CONSTANT
;
1876 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1881 /* Only substitute array parameter variables if we are in an
1882 initialization expression, or we want a subsection. */
1883 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1884 && (gfc_init_expr_flag
|| p
->ref
1885 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1887 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1894 gfc_simplify_iterator_var (p
);
1897 /* Simplify subcomponent references. */
1898 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1903 case EXPR_STRUCTURE
:
1905 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1908 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1911 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1912 && p
->ref
->u
.ar
.type
== AR_FULL
)
1913 gfc_expand_constructor (p
, false);
1915 if (simplify_const_ref (p
) == FAILURE
)
1930 /* Returns the type of an expression with the exception that iterator
1931 variables are automatically integers no matter what else they may
1937 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1944 /* Scalarize an expression for an elemental intrinsic call. */
1947 scalarize_intrinsic_call (gfc_expr
*e
)
1949 gfc_actual_arglist
*a
, *b
;
1950 gfc_constructor_base ctor
;
1951 gfc_constructor
*args
[5];
1952 gfc_constructor
*ci
, *new_ctor
;
1953 gfc_expr
*expr
, *old
;
1954 int n
, i
, rank
[5], array_arg
;
1956 /* Find which, if any, arguments are arrays. Assume that the old
1957 expression carries the type information and that the first arg
1958 that is an array expression carries all the shape information.*/
1960 a
= e
->value
.function
.actual
;
1961 for (; a
; a
= a
->next
)
1964 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1967 expr
= gfc_copy_expr (a
->expr
);
1974 old
= gfc_copy_expr (e
);
1976 gfc_constructor_free (expr
->value
.constructor
);
1977 expr
->value
.constructor
= NULL
;
1979 expr
->where
= old
->where
;
1980 expr
->expr_type
= EXPR_ARRAY
;
1982 /* Copy the array argument constructors into an array, with nulls
1985 a
= old
->value
.function
.actual
;
1986 for (; a
; a
= a
->next
)
1988 /* Check that this is OK for an initialization expression. */
1989 if (a
->expr
&& gfc_check_init_expr (a
->expr
) == FAILURE
)
1993 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1995 rank
[n
] = a
->expr
->rank
;
1996 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1997 args
[n
] = gfc_constructor_first (ctor
);
1999 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2002 rank
[n
] = a
->expr
->rank
;
2005 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2006 args
[n
] = gfc_constructor_first (ctor
);
2015 /* Using the array argument as the master, step through the array
2016 calling the function for each element and advancing the array
2017 constructors together. */
2018 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2020 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2021 gfc_copy_expr (old
), NULL
);
2023 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2025 b
= old
->value
.function
.actual
;
2026 for (i
= 0; i
< n
; i
++)
2029 new_ctor
->expr
->value
.function
.actual
2030 = a
= gfc_get_actual_arglist ();
2033 a
->next
= gfc_get_actual_arglist ();
2038 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2040 a
->expr
= gfc_copy_expr (b
->expr
);
2045 /* Simplify the function calls. If the simplification fails, the
2046 error will be flagged up down-stream or the library will deal
2048 gfc_simplify_expr (new_ctor
->expr
, 0);
2050 for (i
= 0; i
< n
; i
++)
2052 args
[i
] = gfc_constructor_next (args
[i
]);
2054 for (i
= 1; i
< n
; i
++)
2055 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2056 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2062 /* Free "expr" but not the pointers it contains. */
2064 gfc_free_expr (old
);
2068 gfc_error_now ("elemental function arguments at %C are not compliant");
2071 gfc_free_expr (expr
);
2072 gfc_free_expr (old
);
2078 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2080 gfc_expr
*op1
= e
->value
.op
.op1
;
2081 gfc_expr
*op2
= e
->value
.op
.op2
;
2083 if ((*check_function
) (op1
) == FAILURE
)
2086 switch (e
->value
.op
.op
)
2088 case INTRINSIC_UPLUS
:
2089 case INTRINSIC_UMINUS
:
2090 if (!numeric_type (et0 (op1
)))
2095 case INTRINSIC_EQ_OS
:
2097 case INTRINSIC_NE_OS
:
2099 case INTRINSIC_GT_OS
:
2101 case INTRINSIC_GE_OS
:
2103 case INTRINSIC_LT_OS
:
2105 case INTRINSIC_LE_OS
:
2106 if ((*check_function
) (op2
) == FAILURE
)
2109 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2110 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2112 gfc_error ("Numeric or CHARACTER operands are required in "
2113 "expression at %L", &e
->where
);
2118 case INTRINSIC_PLUS
:
2119 case INTRINSIC_MINUS
:
2120 case INTRINSIC_TIMES
:
2121 case INTRINSIC_DIVIDE
:
2122 case INTRINSIC_POWER
:
2123 if ((*check_function
) (op2
) == FAILURE
)
2126 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2131 case INTRINSIC_CONCAT
:
2132 if ((*check_function
) (op2
) == FAILURE
)
2135 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2137 gfc_error ("Concatenation operator in expression at %L "
2138 "must have two CHARACTER operands", &op1
->where
);
2142 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2144 gfc_error ("Concat operator at %L must concatenate strings of the "
2145 "same kind", &e
->where
);
2152 if (et0 (op1
) != BT_LOGICAL
)
2154 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2155 "operand", &op1
->where
);
2164 case INTRINSIC_NEQV
:
2165 if ((*check_function
) (op2
) == FAILURE
)
2168 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2170 gfc_error ("LOGICAL operands are required in expression at %L",
2177 case INTRINSIC_PARENTHESES
:
2181 gfc_error ("Only intrinsic operators can be used in expression at %L",
2189 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2194 /* F2003, 7.1.7 (3): In init expression, allocatable components
2195 must not be data-initialized. */
2197 check_alloc_comp_init (gfc_expr
*e
)
2199 gfc_component
*comp
;
2200 gfc_constructor
*ctor
;
2202 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2203 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2205 for (comp
= e
->ts
.u
.derived
->components
,
2206 ctor
= gfc_constructor_first (e
->value
.constructor
);
2207 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2209 if (comp
->attr
.allocatable
2210 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2212 gfc_error("Invalid initialization expression for ALLOCATABLE "
2213 "component '%s' in structure constructor at %L",
2214 comp
->name
, &ctor
->expr
->where
);
2223 check_init_expr_arguments (gfc_expr
*e
)
2225 gfc_actual_arglist
*ap
;
2227 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2228 if (gfc_check_init_expr (ap
->expr
) == FAILURE
)
2234 static gfc_try
check_restricted (gfc_expr
*);
2236 /* F95, 7.1.6.1, Initialization expressions, (7)
2237 F2003, 7.1.7 Initialization expression, (8) */
2240 check_inquiry (gfc_expr
*e
, int not_restricted
)
2243 const char *const *functions
;
2245 static const char *const inquiry_func_f95
[] = {
2246 "lbound", "shape", "size", "ubound",
2247 "bit_size", "len", "kind",
2248 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2249 "precision", "radix", "range", "tiny",
2253 static const char *const inquiry_func_f2003
[] = {
2254 "lbound", "shape", "size", "ubound",
2255 "bit_size", "len", "kind",
2256 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2257 "precision", "radix", "range", "tiny",
2262 gfc_actual_arglist
*ap
;
2264 if (!e
->value
.function
.isym
2265 || !e
->value
.function
.isym
->inquiry
)
2268 /* An undeclared parameter will get us here (PR25018). */
2269 if (e
->symtree
== NULL
)
2272 name
= e
->symtree
->n
.sym
->name
;
2274 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2275 ? inquiry_func_f2003
: inquiry_func_f95
;
2277 for (i
= 0; functions
[i
]; i
++)
2278 if (strcmp (functions
[i
], name
) == 0)
2281 if (functions
[i
] == NULL
)
2284 /* At this point we have an inquiry function with a variable argument. The
2285 type of the variable might be undefined, but we need it now, because the
2286 arguments of these functions are not allowed to be undefined. */
2288 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2293 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2295 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2296 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2300 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2303 /* Assumed character length will not reduce to a constant expression
2304 with LEN, as required by the standard. */
2305 if (i
== 5 && not_restricted
2306 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2307 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2308 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2310 gfc_error ("Assumed or deferred character length variable '%s' "
2311 " in constant expression at %L",
2312 ap
->expr
->symtree
->n
.sym
->name
,
2316 else if (not_restricted
&& gfc_check_init_expr (ap
->expr
) == FAILURE
)
2319 if (not_restricted
== 0
2320 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2321 && check_restricted (ap
->expr
) == FAILURE
)
2324 if (not_restricted
== 0
2325 && ap
->expr
->expr_type
== EXPR_VARIABLE
2326 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2327 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2335 /* F95, 7.1.6.1, Initialization expressions, (5)
2336 F2003, 7.1.7 Initialization expression, (5) */
2339 check_transformational (gfc_expr
*e
)
2341 static const char * const trans_func_f95
[] = {
2342 "repeat", "reshape", "selected_int_kind",
2343 "selected_real_kind", "transfer", "trim", NULL
2346 static const char * const trans_func_f2003
[] = {
2347 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2348 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2349 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2350 "trim", "unpack", NULL
2355 const char *const *functions
;
2357 if (!e
->value
.function
.isym
2358 || !e
->value
.function
.isym
->transformational
)
2361 name
= e
->symtree
->n
.sym
->name
;
2363 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2364 ? trans_func_f2003
: trans_func_f95
;
2366 /* NULL() is dealt with below. */
2367 if (strcmp ("null", name
) == 0)
2370 for (i
= 0; functions
[i
]; i
++)
2371 if (strcmp (functions
[i
], name
) == 0)
2374 if (functions
[i
] == NULL
)
2376 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2377 "in an initialization expression", name
, &e
->where
);
2381 return check_init_expr_arguments (e
);
2385 /* F95, 7.1.6.1, Initialization expressions, (6)
2386 F2003, 7.1.7 Initialization expression, (6) */
2389 check_null (gfc_expr
*e
)
2391 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2394 return check_init_expr_arguments (e
);
2399 check_elemental (gfc_expr
*e
)
2401 if (!e
->value
.function
.isym
2402 || !e
->value
.function
.isym
->elemental
)
2405 if (e
->ts
.type
!= BT_INTEGER
2406 && e
->ts
.type
!= BT_CHARACTER
2407 && gfc_notify_std (GFC_STD_F2003
, "Evaluation of "
2408 "nonstandard initialization expression at %L",
2409 &e
->where
) == FAILURE
)
2412 return check_init_expr_arguments (e
);
2417 check_conversion (gfc_expr
*e
)
2419 if (!e
->value
.function
.isym
2420 || !e
->value
.function
.isym
->conversion
)
2423 return check_init_expr_arguments (e
);
2427 /* Verify that an expression is an initialization expression. A side
2428 effect is that the expression tree is reduced to a single constant
2429 node if all goes well. This would normally happen when the
2430 expression is constructed but function references are assumed to be
2431 intrinsics in the context of initialization expressions. If
2432 FAILURE is returned an error message has been generated. */
2435 gfc_check_init_expr (gfc_expr
*e
)
2443 switch (e
->expr_type
)
2446 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2448 t
= gfc_simplify_expr (e
, 0);
2456 gfc_intrinsic_sym
* isym
;
2459 sym
= e
->symtree
->n
.sym
;
2460 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2461 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2463 gfc_error ("Function '%s' in initialization expression at %L "
2464 "must be an intrinsic function",
2465 e
->symtree
->n
.sym
->name
, &e
->where
);
2469 if ((m
= check_conversion (e
)) == MATCH_NO
2470 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2471 && (m
= check_null (e
)) == MATCH_NO
2472 && (m
= check_transformational (e
)) == MATCH_NO
2473 && (m
= check_elemental (e
)) == MATCH_NO
)
2475 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2476 "in an initialization expression",
2477 e
->symtree
->n
.sym
->name
, &e
->where
);
2481 if (m
== MATCH_ERROR
)
2484 /* Try to scalarize an elemental intrinsic function that has an
2486 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2487 if (isym
&& isym
->elemental
2488 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2493 t
= gfc_simplify_expr (e
, 0);
2500 if (gfc_check_iter_variable (e
) == SUCCESS
)
2503 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2505 /* A PARAMETER shall not be used to define itself, i.e.
2506 REAL, PARAMETER :: x = transfer(0, x)
2508 if (!e
->symtree
->n
.sym
->value
)
2510 gfc_error("PARAMETER '%s' is used at %L before its definition "
2511 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2515 t
= simplify_parameter_variable (e
, 0);
2520 if (gfc_in_match_data ())
2525 if (e
->symtree
->n
.sym
->as
)
2527 switch (e
->symtree
->n
.sym
->as
->type
)
2529 case AS_ASSUMED_SIZE
:
2530 gfc_error ("Assumed size array '%s' at %L is not permitted "
2531 "in an initialization expression",
2532 e
->symtree
->n
.sym
->name
, &e
->where
);
2535 case AS_ASSUMED_SHAPE
:
2536 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2537 "in an initialization expression",
2538 e
->symtree
->n
.sym
->name
, &e
->where
);
2542 gfc_error ("Deferred array '%s' at %L is not permitted "
2543 "in an initialization expression",
2544 e
->symtree
->n
.sym
->name
, &e
->where
);
2548 gfc_error ("Array '%s' at %L is a variable, which does "
2549 "not reduce to a constant expression",
2550 e
->symtree
->n
.sym
->name
, &e
->where
);
2558 gfc_error ("Parameter '%s' at %L has not been declared or is "
2559 "a variable, which does not reduce to a constant "
2560 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2569 case EXPR_SUBSTRING
:
2570 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2574 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2576 t
= gfc_simplify_expr (e
, 0);
2580 case EXPR_STRUCTURE
:
2581 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2585 t
= check_alloc_comp_init (e
);
2589 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2596 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2600 t
= gfc_expand_constructor (e
, true);
2604 t
= gfc_check_constructor_type (e
);
2608 gfc_internal_error ("check_init_expr(): Unknown expression type");
2614 /* Reduces a general expression to an initialization expression (a constant).
2615 This used to be part of gfc_match_init_expr.
2616 Note that this function doesn't free the given expression on FAILURE. */
2619 gfc_reduce_init_expr (gfc_expr
*expr
)
2623 gfc_init_expr_flag
= true;
2624 t
= gfc_resolve_expr (expr
);
2626 t
= gfc_check_init_expr (expr
);
2627 gfc_init_expr_flag
= false;
2632 if (expr
->expr_type
== EXPR_ARRAY
)
2634 if (gfc_check_constructor_type (expr
) == FAILURE
)
2636 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2644 /* Match an initialization expression. We work by first matching an
2645 expression, then reducing it to a constant. */
2648 gfc_match_init_expr (gfc_expr
**result
)
2656 gfc_init_expr_flag
= true;
2658 m
= gfc_match_expr (&expr
);
2661 gfc_init_expr_flag
= false;
2665 t
= gfc_reduce_init_expr (expr
);
2668 gfc_free_expr (expr
);
2669 gfc_init_expr_flag
= false;
2674 gfc_init_expr_flag
= false;
2680 /* Given an actual argument list, test to see that each argument is a
2681 restricted expression and optionally if the expression type is
2682 integer or character. */
2685 restricted_args (gfc_actual_arglist
*a
)
2687 for (; a
; a
= a
->next
)
2689 if (check_restricted (a
->expr
) == FAILURE
)
2697 /************* Restricted/specification expressions *************/
2700 /* Make sure a non-intrinsic function is a specification function. */
2703 external_spec_function (gfc_expr
*e
)
2707 f
= e
->value
.function
.esym
;
2709 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2711 gfc_error ("Specification function '%s' at %L cannot be a statement "
2712 "function", f
->name
, &e
->where
);
2716 if (f
->attr
.proc
== PROC_INTERNAL
)
2718 gfc_error ("Specification function '%s' at %L cannot be an internal "
2719 "function", f
->name
, &e
->where
);
2723 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2725 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2730 if (f
->attr
.recursive
)
2732 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2733 f
->name
, &e
->where
);
2737 return restricted_args (e
->value
.function
.actual
);
2741 /* Check to see that a function reference to an intrinsic is a
2742 restricted expression. */
2745 restricted_intrinsic (gfc_expr
*e
)
2747 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2748 if (check_inquiry (e
, 0) == MATCH_YES
)
2751 return restricted_args (e
->value
.function
.actual
);
2755 /* Check the expressions of an actual arglist. Used by check_restricted. */
2758 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2760 for (; arg
; arg
= arg
->next
)
2761 if (checker (arg
->expr
) == FAILURE
)
2768 /* Check the subscription expressions of a reference chain with a checking
2769 function; used by check_restricted. */
2772 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2782 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2784 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2786 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2788 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2794 /* Nothing needed, just proceed to next reference. */
2798 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2800 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2809 return check_references (ref
->next
, checker
);
2813 /* Verify that an expression is a restricted expression. Like its
2814 cousin check_init_expr(), an error message is generated if we
2818 check_restricted (gfc_expr
*e
)
2826 switch (e
->expr_type
)
2829 t
= check_intrinsic_op (e
, check_restricted
);
2831 t
= gfc_simplify_expr (e
, 0);
2836 if (e
->value
.function
.esym
)
2838 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2840 t
= external_spec_function (e
);
2844 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2847 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2850 t
= restricted_intrinsic (e
);
2855 sym
= e
->symtree
->n
.sym
;
2858 /* If a dummy argument appears in a context that is valid for a
2859 restricted expression in an elemental procedure, it will have
2860 already been simplified away once we get here. Therefore we
2861 don't need to jump through hoops to distinguish valid from
2863 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2864 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2866 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2867 sym
->name
, &e
->where
);
2871 if (sym
->attr
.optional
)
2873 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2874 sym
->name
, &e
->where
);
2878 if (sym
->attr
.intent
== INTENT_OUT
)
2880 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2881 sym
->name
, &e
->where
);
2885 /* Check reference chain if any. */
2886 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2889 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2890 processed in resolve.c(resolve_formal_arglist). This is done so
2891 that host associated dummy array indices are accepted (PR23446).
2892 This mechanism also does the same for the specification expressions
2893 of array-valued functions. */
2895 || sym
->attr
.in_common
2896 || sym
->attr
.use_assoc
2898 || sym
->attr
.implied_index
2899 || sym
->attr
.flavor
== FL_PARAMETER
2900 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2901 || (sym
->ns
&& gfc_current_ns
->parent
2902 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2903 || (sym
->ns
->proc_name
!= NULL
2904 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2905 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2911 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2912 sym
->name
, &e
->where
);
2913 /* Prevent a repetition of the error. */
2922 case EXPR_SUBSTRING
:
2923 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2927 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2929 t
= gfc_simplify_expr (e
, 0);
2933 case EXPR_STRUCTURE
:
2934 t
= gfc_check_constructor (e
, check_restricted
);
2938 t
= gfc_check_constructor (e
, check_restricted
);
2942 gfc_internal_error ("check_restricted(): Unknown expression type");
2949 /* Check to see that an expression is a specification expression. If
2950 we return FAILURE, an error has been generated. */
2953 gfc_specification_expr (gfc_expr
*e
)
2955 gfc_component
*comp
;
2960 if (e
->ts
.type
!= BT_INTEGER
)
2962 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2963 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2967 comp
= gfc_get_proc_ptr_comp (e
);
2968 if (e
->expr_type
== EXPR_FUNCTION
2969 && !e
->value
.function
.isym
2970 && !e
->value
.function
.esym
2971 && !gfc_pure (e
->symtree
->n
.sym
)
2972 && (!comp
|| !comp
->attr
.pure
))
2974 gfc_error ("Function '%s' at %L must be PURE",
2975 e
->symtree
->n
.sym
->name
, &e
->where
);
2976 /* Prevent repeat error messages. */
2977 e
->symtree
->n
.sym
->attr
.pure
= 1;
2983 gfc_error ("Expression at %L must be scalar", &e
->where
);
2987 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2990 return check_restricted (e
);
2994 /************** Expression conformance checks. *************/
2996 /* Given two expressions, make sure that the arrays are conformable. */
2999 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3001 int op1_flag
, op2_flag
, d
;
3002 mpz_t op1_size
, op2_size
;
3008 if (op1
->rank
== 0 || op2
->rank
== 0)
3011 va_start (argp
, optype_msgid
);
3012 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3015 if (op1
->rank
!= op2
->rank
)
3017 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3018 op1
->rank
, op2
->rank
, &op1
->where
);
3024 for (d
= 0; d
< op1
->rank
; d
++)
3026 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3027 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3029 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3031 gfc_error ("Different shape for %s at %L on dimension %d "
3032 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3033 (int) mpz_get_si (op1_size
),
3034 (int) mpz_get_si (op2_size
));
3040 mpz_clear (op1_size
);
3042 mpz_clear (op2_size
);
3052 /* Given an assignable expression and an arbitrary expression, make
3053 sure that the assignment can take place. */
3056 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3062 sym
= lvalue
->symtree
->n
.sym
;
3064 /* See if this is the component or subcomponent of a pointer. */
3065 has_pointer
= sym
->attr
.pointer
;
3066 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3067 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3073 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3074 variable local to a function subprogram. Its existence begins when
3075 execution of the function is initiated and ends when execution of the
3076 function is terminated...
3077 Therefore, the left hand side is no longer a variable, when it is: */
3078 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3079 && !sym
->attr
.external
)
3084 /* (i) Use associated; */
3085 if (sym
->attr
.use_assoc
)
3088 /* (ii) The assignment is in the main program; or */
3089 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3092 /* (iii) A module or internal procedure... */
3093 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3094 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3095 && gfc_current_ns
->parent
3096 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3097 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3098 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3100 /* ... that is not a function... */
3101 if (!gfc_current_ns
->proc_name
->attr
.function
)
3104 /* ... or is not an entry and has a different name. */
3105 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3109 /* (iv) Host associated and not the function symbol or the
3110 parent result. This picks up sibling references, which
3111 cannot be entries. */
3112 if (!sym
->attr
.entry
3113 && sym
->ns
== gfc_current_ns
->parent
3114 && sym
!= gfc_current_ns
->proc_name
3115 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3120 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3125 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3127 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3128 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3132 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3134 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3139 if (rvalue
->expr_type
== EXPR_NULL
)
3141 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3142 && lvalue
->symtree
->n
.sym
->attr
.data
)
3146 gfc_error ("NULL appears on right-hand side in assignment at %L",
3152 /* This is possibly a typo: x = f() instead of x => f(). */
3153 if (gfc_option
.warn_surprising
3154 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3155 gfc_warning ("POINTER-valued function appears on right-hand side of "
3156 "assignment at %L", &rvalue
->where
);
3158 /* Check size of array assignments. */
3159 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3160 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3163 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3164 && lvalue
->symtree
->n
.sym
->attr
.data
3165 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3166 "initialize non-integer variable '%s'",
3167 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3170 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3171 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3172 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3173 &rvalue
->where
) == FAILURE
)
3176 /* Handle the case of a BOZ literal on the RHS. */
3177 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3180 if (gfc_option
.warn_surprising
)
3181 gfc_warning ("BOZ literal at %L is bitwise transferred "
3182 "non-integer symbol '%s'", &rvalue
->where
,
3183 lvalue
->symtree
->n
.sym
->name
);
3184 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3186 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3188 if (rc
== ARITH_UNDERFLOW
)
3189 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3190 ". This check can be disabled with the option "
3191 "-fno-range-check", &rvalue
->where
);
3192 else if (rc
== ARITH_OVERFLOW
)
3193 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3194 ". This check can be disabled with the option "
3195 "-fno-range-check", &rvalue
->where
);
3196 else if (rc
== ARITH_NAN
)
3197 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3198 ". This check can be disabled with the option "
3199 "-fno-range-check", &rvalue
->where
);
3204 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3205 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3206 will warn anyway, so there is no need to to so here. */
3208 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3209 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3211 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3213 /* As a special bonus, don't warn about REAL rvalues which are not
3214 changed by the conversion if -Wconversion is specified. */
3215 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3217 /* Calculate the difference between the constant and the rounded
3218 value and check it against zero. */
3220 gfc_set_model_kind (lvalue
->ts
.kind
);
3222 gfc_set_model_kind (rvalue
->ts
.kind
);
3225 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3226 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3228 if (!mpfr_zero_p (diff
))
3229 gfc_warning ("Change of value in conversion from "
3230 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3231 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3237 gfc_warning ("Possible change of value in conversion from %s "
3238 "to %s at %L",gfc_typename (&rvalue
->ts
),
3239 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3242 else if (gfc_option
.warn_conversion_extra
3243 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3245 gfc_warning ("Conversion from %s to %s at %L",
3246 gfc_typename (&rvalue
->ts
),
3247 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3251 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3254 /* Only DATA Statements come here. */
3257 /* Numeric can be converted to any other numeric. And Hollerith can be
3258 converted to any other type. */
3259 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3260 || rvalue
->ts
.type
== BT_HOLLERITH
)
3263 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3266 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3267 "conversion of %s to %s", &lvalue
->where
,
3268 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3273 /* Assignment is the only case where character variables of different
3274 kind values can be converted into one another. */
3275 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3277 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3278 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3283 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3287 /* Check that a pointer assignment is OK. We first check lvalue, and
3288 we only check rvalue if it's not an assignment to NULL() or a
3289 NULLIFY statement. */
3292 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3294 symbol_attribute attr
, lhs_attr
;
3296 bool is_pure
, is_implicit_pure
, rank_remap
;
3299 lhs_attr
= gfc_expr_attr (lvalue
);
3300 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3302 gfc_error ("Pointer assignment target is not a POINTER at %L",
3307 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3308 && !lhs_attr
.proc_pointer
)
3310 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3311 "l-value since it is a procedure",
3312 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3316 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3319 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3321 if (ref
->type
== REF_COMPONENT
)
3322 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3324 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3328 if (ref
->u
.ar
.type
== AR_FULL
)
3331 if (ref
->u
.ar
.type
!= AR_SECTION
)
3333 gfc_error ("Expected bounds specification for '%s' at %L",
3334 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3338 if (gfc_notify_std (GFC_STD_F2003
,"Bounds "
3339 "specification for '%s' in pointer assignment "
3340 "at %L", lvalue
->symtree
->n
.sym
->name
,
3341 &lvalue
->where
) == FAILURE
)
3344 /* When bounds are given, all lbounds are necessary and either all
3345 or none of the upper bounds; no strides are allowed. If the
3346 upper bounds are present, we may do rank remapping. */
3347 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3349 if (!ref
->u
.ar
.start
[dim
]
3350 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3352 gfc_error ("Lower bound has to be present at %L",
3356 if (ref
->u
.ar
.stride
[dim
])
3358 gfc_error ("Stride must not be present at %L",
3364 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3367 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3368 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3370 gfc_error ("Either all or none of the upper bounds"
3371 " must be specified at %L", &lvalue
->where
);
3379 is_pure
= gfc_pure (NULL
);
3380 is_implicit_pure
= gfc_implicit_pure (NULL
);
3382 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3383 kind, etc for lvalue and rvalue must match, and rvalue must be a
3384 pure variable if we're in a pure function. */
3385 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3388 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3389 if (lvalue
->expr_type
== EXPR_VARIABLE
3390 && gfc_is_coindexed (lvalue
))
3393 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3394 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3396 gfc_error ("Pointer object at %L shall not have a coindex",
3402 /* Checks on rvalue for procedure pointer assignments. */
3407 gfc_component
*comp
;
3410 attr
= gfc_expr_attr (rvalue
);
3411 if (!((rvalue
->expr_type
== EXPR_NULL
)
3412 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3413 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3414 || (rvalue
->expr_type
== EXPR_VARIABLE
3415 && attr
.flavor
== FL_PROCEDURE
)))
3417 gfc_error ("Invalid procedure pointer assignment at %L",
3421 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3423 /* Check for intrinsics. */
3424 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3425 if (!sym
->attr
.intrinsic
3426 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3427 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3429 sym
->attr
.intrinsic
= 1;
3430 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3431 attr
= gfc_expr_attr (rvalue
);
3433 /* Check for result of embracing function. */
3434 if (sym
== gfc_current_ns
->proc_name
3435 && sym
->attr
.function
&& sym
->result
== sym
)
3437 gfc_error ("Function result '%s' is invalid as proc-target "
3438 "in procedure pointer assignment at %L",
3439 sym
->name
, &rvalue
->where
);
3445 gfc_error ("Abstract interface '%s' is invalid "
3446 "in procedure pointer assignment at %L",
3447 rvalue
->symtree
->name
, &rvalue
->where
);
3450 /* Check for F08:C729. */
3451 if (attr
.flavor
== FL_PROCEDURE
)
3453 if (attr
.proc
== PROC_ST_FUNCTION
)
3455 gfc_error ("Statement function '%s' is invalid "
3456 "in procedure pointer assignment at %L",
3457 rvalue
->symtree
->name
, &rvalue
->where
);
3460 if (attr
.proc
== PROC_INTERNAL
&&
3461 gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
3462 "'%s' is invalid in procedure pointer assignment "
3463 "at %L", rvalue
->symtree
->name
, &rvalue
->where
)
3466 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3467 attr
.subroutine
) == 0)
3469 gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
3470 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3474 /* Check for F08:C730. */
3475 if (attr
.elemental
&& !attr
.intrinsic
)
3477 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3478 "in procedure pointer assignment at %L",
3479 rvalue
->symtree
->name
, &rvalue
->where
);
3483 /* Ensure that the calling convention is the same. As other attributes
3484 such as DLLEXPORT may differ, one explicitly only tests for the
3485 calling conventions. */
3486 if (rvalue
->expr_type
== EXPR_VARIABLE
3487 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3488 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3490 symbol_attribute calls
;
3493 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3494 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3495 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3497 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3498 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3500 gfc_error ("Mismatch in the procedure pointer assignment "
3501 "at %L: mismatch in the calling convention",
3507 comp
= gfc_get_proc_ptr_comp (lvalue
);
3509 s1
= comp
->ts
.interface
;
3511 s1
= lvalue
->symtree
->n
.sym
;
3513 comp
= gfc_get_proc_ptr_comp (rvalue
);
3516 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3518 s2
= comp
->ts
.interface
->result
;
3519 name
= comp
->ts
.interface
->result
->name
;
3523 s2
= comp
->ts
.interface
;
3527 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3529 s2
= rvalue
->symtree
->n
.sym
->result
;
3530 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3534 s2
= rvalue
->symtree
->n
.sym
;
3535 name
= rvalue
->symtree
->n
.sym
->name
;
3538 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3539 err
, sizeof(err
), NULL
, NULL
))
3541 gfc_error ("Interface mismatch in procedure pointer assignment "
3542 "at %L: %s", &rvalue
->where
, err
);
3549 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3551 /* Check for F03:C717. */
3552 if (UNLIMITED_POLY (rvalue
)
3553 && !(UNLIMITED_POLY (lvalue
)
3554 || (lvalue
->ts
.type
== BT_DERIVED
3555 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3556 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3557 gfc_error ("Data-pointer-object &L must be unlimited "
3558 "polymorphic, a sequence derived type or of a "
3559 "type with the BIND attribute assignment at %L "
3560 "to be compatible with an unlimited polymorphic "
3561 "target", &lvalue
->where
);
3563 gfc_error ("Different types in pointer assignment at %L; "
3564 "attempted assignment of %s to %s", &lvalue
->where
,
3565 gfc_typename (&rvalue
->ts
),
3566 gfc_typename (&lvalue
->ts
));
3570 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3572 gfc_error ("Different kind type parameters in pointer "
3573 "assignment at %L", &lvalue
->where
);
3577 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3579 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3583 /* Make sure the vtab is present. */
3584 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3585 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3586 else if (UNLIMITED_POLY (lvalue
) && !UNLIMITED_POLY (rvalue
))
3587 gfc_find_intrinsic_vtab (&rvalue
->ts
);
3589 /* Check rank remapping. */
3594 /* If this can be determined, check that the target must be at least as
3595 large as the pointer assigned to it is. */
3596 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3597 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3598 && mpz_cmp (rsize
, lsize
) < 0)
3600 gfc_error ("Rank remapping target is smaller than size of the"
3601 " pointer (%ld < %ld) at %L",
3602 mpz_get_si (rsize
), mpz_get_si (lsize
),
3607 /* The target must be either rank one or it must be simply contiguous
3608 and F2008 must be allowed. */
3609 if (rvalue
->rank
!= 1)
3611 if (!gfc_is_simply_contiguous (rvalue
, true))
3613 gfc_error ("Rank remapping target must be rank 1 or"
3614 " simply contiguous at %L", &rvalue
->where
);
3617 if (gfc_notify_std (GFC_STD_F2008
, "Rank remapping"
3618 " target is not rank 1 at %L", &rvalue
->where
)
3624 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3625 if (rvalue
->expr_type
== EXPR_NULL
)
3628 if (lvalue
->ts
.type
== BT_CHARACTER
)
3630 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3635 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3636 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3638 attr
= gfc_expr_attr (rvalue
);
3640 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3642 gfc_error ("Target expression in pointer assignment "
3643 "at %L must deliver a pointer result",
3648 if (!attr
.target
&& !attr
.pointer
)
3650 gfc_error ("Pointer assignment target is neither TARGET "
3651 "nor POINTER at %L", &rvalue
->where
);
3655 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3657 gfc_error ("Bad target in pointer assignment in PURE "
3658 "procedure at %L", &rvalue
->where
);
3661 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3662 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3665 if (gfc_has_vector_index (rvalue
))
3667 gfc_error ("Pointer assignment with vector subscript "
3668 "on rhs at %L", &rvalue
->where
);
3672 if (attr
.is_protected
&& attr
.use_assoc
3673 && !(attr
.pointer
|| attr
.proc_pointer
))
3675 gfc_error ("Pointer assignment target has PROTECTED "
3676 "attribute at %L", &rvalue
->where
);
3680 /* F2008, C725. For PURE also C1283. */
3681 if (rvalue
->expr_type
== EXPR_VARIABLE
3682 && gfc_is_coindexed (rvalue
))
3685 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3686 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3688 gfc_error ("Data target at %L shall not have a coindex",
3694 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3695 if (gfc_option
.warn_target_lifetime
3696 && rvalue
->expr_type
== EXPR_VARIABLE
3697 && !rvalue
->symtree
->n
.sym
->attr
.save
3698 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3699 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3700 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3701 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3706 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3707 || lvalue
->symtree
->n
.sym
->attr
.result
3708 || lvalue
->symtree
->n
.sym
->attr
.function
3709 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3710 && lvalue
->symtree
->n
.sym
->ns
3711 != rvalue
->symtree
->n
.sym
->ns
)
3712 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3713 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3715 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3716 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3717 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3718 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3719 ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3721 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3725 gfc_warning ("Pointer at %L in pointer assignment might outlive the "
3726 "pointer target", &lvalue
->where
);
3733 /* Relative of gfc_check_assign() except that the lvalue is a single
3734 symbol. Used for initialization assignments. */
3737 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3741 bool pointer
, proc_pointer
;
3743 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3745 lvalue
.expr_type
= EXPR_VARIABLE
;
3746 lvalue
.ts
= sym
->ts
;
3748 lvalue
.rank
= sym
->as
->rank
;
3749 lvalue
.symtree
= XCNEW (gfc_symtree
);
3750 lvalue
.symtree
->n
.sym
= sym
;
3751 lvalue
.where
= sym
->declared_at
;
3755 lvalue
.ref
= gfc_get_ref ();
3756 lvalue
.ref
->type
= REF_COMPONENT
;
3757 lvalue
.ref
->u
.c
.component
= comp
;
3758 lvalue
.ref
->u
.c
.sym
= sym
;
3759 lvalue
.ts
= comp
->ts
;
3760 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3761 lvalue
.where
= comp
->loc
;
3762 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3763 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3764 proc_pointer
= comp
->attr
.proc_pointer
;
3768 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3769 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3770 proc_pointer
= sym
->attr
.proc_pointer
;
3773 if (pointer
|| proc_pointer
)
3774 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3776 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3778 free (lvalue
.symtree
);
3783 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3785 /* F08:C461. Additional checks for pointer initialization. */
3786 symbol_attribute attr
;
3787 attr
= gfc_expr_attr (rvalue
);
3788 if (attr
.allocatable
)
3790 gfc_error ("Pointer initialization target at %L "
3791 "must not be ALLOCATABLE", &rvalue
->where
);
3794 if (!attr
.target
|| attr
.pointer
)
3796 gfc_error ("Pointer initialization target at %L "
3797 "must have the TARGET attribute", &rvalue
->where
);
3801 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3802 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3803 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3805 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3806 attr
.save
= SAVE_IMPLICIT
;
3811 gfc_error ("Pointer initialization target at %L "
3812 "must have the SAVE attribute", &rvalue
->where
);
3817 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3819 /* F08:C1220. Additional checks for procedure pointer initialization. */
3820 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3821 if (attr
.proc_pointer
)
3823 gfc_error ("Procedure pointer initialization target at %L "
3824 "may not be a procedure pointer", &rvalue
->where
);
3833 /* Check for default initializer; sym->value is not enough
3834 as it is also set for EXPR_NULL of allocatables. */
3837 gfc_has_default_initializer (gfc_symbol
*der
)
3841 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3842 for (c
= der
->components
; c
; c
= c
->next
)
3843 if (c
->ts
.type
== BT_DERIVED
)
3845 if (!c
->attr
.pointer
3846 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3848 if (c
->attr
.pointer
&& c
->initializer
)
3861 /* Get an expression for a default initializer. */
3864 gfc_default_initializer (gfc_typespec
*ts
)
3867 gfc_component
*comp
;
3869 /* See if we have a default initializer in this, but not in nested
3870 types (otherwise we could use gfc_has_default_initializer()). */
3871 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3872 if (comp
->initializer
|| comp
->attr
.allocatable
3873 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3879 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3880 &ts
->u
.derived
->declared_at
);
3883 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3885 gfc_constructor
*ctor
= gfc_constructor_get();
3887 if (comp
->initializer
)
3889 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3890 if ((comp
->ts
.type
!= comp
->initializer
->ts
.type
3891 || comp
->ts
.kind
!= comp
->initializer
->ts
.kind
)
3892 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
3893 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
3896 if (comp
->attr
.allocatable
3897 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3899 ctor
->expr
= gfc_get_expr ();
3900 ctor
->expr
->expr_type
= EXPR_NULL
;
3901 ctor
->expr
->ts
= comp
->ts
;
3904 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3911 /* Given a symbol, create an expression node with that symbol as a
3912 variable. If the symbol is array valued, setup a reference of the
3916 gfc_get_variable_expr (gfc_symtree
*var
)
3920 e
= gfc_get_expr ();
3921 e
->expr_type
= EXPR_VARIABLE
;
3923 e
->ts
= var
->n
.sym
->ts
;
3925 if ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
3926 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
3927 && CLASS_DATA (var
->n
.sym
)->as
))
3929 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
3930 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
3931 e
->ref
= gfc_get_ref ();
3932 e
->ref
->type
= REF_ARRAY
;
3933 e
->ref
->u
.ar
.type
= AR_FULL
;
3934 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
3935 ? CLASS_DATA (var
->n
.sym
)->as
3943 /* Adds a full array reference to an expression, as needed. */
3946 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
3949 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3954 ref
->next
= gfc_get_ref ();
3959 e
->ref
= gfc_get_ref ();
3962 ref
->type
= REF_ARRAY
;
3963 ref
->u
.ar
.type
= AR_FULL
;
3964 ref
->u
.ar
.dimen
= e
->rank
;
3965 ref
->u
.ar
.where
= e
->where
;
3971 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3974 lval
= gfc_get_expr ();
3975 lval
->expr_type
= EXPR_VARIABLE
;
3976 lval
->where
= sym
->declared_at
;
3978 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3980 /* It will always be a full array. */
3981 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
3983 gfc_add_full_array_ref (lval
, sym
->ts
.type
== BT_CLASS
?
3984 CLASS_DATA (sym
)->as
: sym
->as
);
3989 /* Returns the array_spec of a full array expression. A NULL is
3990 returned otherwise. */
3992 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3997 if (expr
->rank
== 0)
4000 /* Follow any component references. */
4001 if (expr
->expr_type
== EXPR_VARIABLE
4002 || expr
->expr_type
== EXPR_CONSTANT
)
4004 as
= expr
->symtree
->n
.sym
->as
;
4005 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4010 as
= ref
->u
.c
.component
->as
;
4018 switch (ref
->u
.ar
.type
)
4041 /* General expression traversal function. */
4044 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4045 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4050 gfc_actual_arglist
*args
;
4057 if ((*func
) (expr
, sym
, &f
))
4060 if (expr
->ts
.type
== BT_CHARACTER
4062 && expr
->ts
.u
.cl
->length
4063 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4064 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4067 switch (expr
->expr_type
)
4072 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4074 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4082 case EXPR_SUBSTRING
:
4085 case EXPR_STRUCTURE
:
4087 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4088 c
; c
= gfc_constructor_next (c
))
4090 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4094 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4096 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4098 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4100 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4107 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4109 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4125 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4127 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4129 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4131 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4137 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4139 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4144 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4145 && ref
->u
.c
.component
->ts
.u
.cl
4146 && ref
->u
.c
.component
->ts
.u
.cl
->length
4147 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4149 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4153 if (ref
->u
.c
.component
->as
)
4154 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4155 + ref
->u
.c
.component
->as
->corank
; i
++)
4157 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4160 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4174 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4177 expr_set_symbols_referenced (gfc_expr
*expr
,
4178 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4179 int *f ATTRIBUTE_UNUSED
)
4181 if (expr
->expr_type
!= EXPR_VARIABLE
)
4183 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4188 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4190 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4194 /* Determine if an expression is a procedure pointer component and return
4195 the component in that case. Otherwise return NULL. */
4198 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4202 if (!expr
|| !expr
->ref
)
4209 if (ref
->type
== REF_COMPONENT
4210 && ref
->u
.c
.component
->attr
.proc_pointer
)
4211 return ref
->u
.c
.component
;
4217 /* Determine if an expression is a procedure pointer component. */
4220 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4222 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4226 /* Walk an expression tree and check each variable encountered for being typed.
4227 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4228 mode as is a basic arithmetic expression using those; this is for things in
4231 INTEGER :: arr(n), n
4232 INTEGER :: arr(n + 1), n
4234 The namespace is needed for IMPLICIT typing. */
4236 static gfc_namespace
* check_typed_ns
;
4239 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4240 int* f ATTRIBUTE_UNUSED
)
4244 if (e
->expr_type
!= EXPR_VARIABLE
)
4247 gcc_assert (e
->symtree
);
4248 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4251 return (t
== FAILURE
);
4255 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4259 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4263 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4264 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4266 if (e
->expr_type
== EXPR_OP
)
4268 gfc_try t
= SUCCESS
;
4270 gcc_assert (e
->value
.op
.op1
);
4271 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4273 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4274 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4280 /* Otherwise, walk the expression and do it strictly. */
4281 check_typed_ns
= ns
;
4282 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4284 return error_found
? FAILURE
: SUCCESS
;
4288 /* Walk an expression tree and replace all dummy symbols by the corresponding
4289 symbol in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4290 statements. The boolean return value is required by gfc_traverse_expr. */
4293 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4295 if ((expr
->expr_type
== EXPR_VARIABLE
4296 || (expr
->expr_type
== EXPR_FUNCTION
4297 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4298 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
4299 && expr
->symtree
->n
.sym
->attr
.dummy
)
4301 gfc_symtree
*root
= sym
->formal_ns
? sym
->formal_ns
->sym_root
4302 : gfc_current_ns
->sym_root
;
4303 gfc_symtree
*stree
= gfc_find_symtree (root
, expr
->symtree
->n
.sym
->name
);
4305 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4306 expr
->symtree
= stree
;
4312 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
4314 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
4318 /* The following is analogous to 'replace_symbol', and needed for copying
4319 interfaces for procedure pointer components. The argument 'sym' must formally
4320 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4321 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4322 component in whose formal_ns the arguments have to be). */
4325 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4327 gfc_component
*comp
;
4328 comp
= (gfc_component
*)sym
;
4329 if ((expr
->expr_type
== EXPR_VARIABLE
4330 || (expr
->expr_type
== EXPR_FUNCTION
4331 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4332 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4335 gfc_namespace
*ns
= comp
->formal_ns
;
4336 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4337 the symtree rather than create a new one (and probably fail later). */
4338 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4339 expr
->symtree
->n
.sym
->name
);
4341 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4342 expr
->symtree
= stree
;
4348 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4350 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4355 gfc_ref_this_image (gfc_ref
*ref
)
4359 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4361 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4362 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4370 gfc_is_coindexed (gfc_expr
*e
)
4374 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4375 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4376 return !gfc_ref_this_image (ref
);
4382 /* Coarrays are variables with a corank but not being coindexed. However, also
4383 the following is a coarray: A subobject of a coarray is a coarray if it does
4384 not have any cosubscripts, vector subscripts, allocatable component
4385 selection, or pointer component selection. (F2008, 2.4.7) */
4388 gfc_is_coarray (gfc_expr
*e
)
4392 gfc_component
*comp
;
4397 if (e
->expr_type
!= EXPR_VARIABLE
)
4401 sym
= e
->symtree
->n
.sym
;
4403 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4404 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4406 coarray
= sym
->attr
.codimension
;
4408 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4412 comp
= ref
->u
.c
.component
;
4413 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4414 && (CLASS_DATA (comp
)->attr
.class_pointer
4415 || CLASS_DATA (comp
)->attr
.allocatable
))
4418 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4420 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4423 coarray
= comp
->attr
.codimension
;
4431 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4437 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4438 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4449 return coarray
&& !coindexed
;
4454 gfc_get_corank (gfc_expr
*e
)
4459 if (!gfc_is_coarray (e
))
4462 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4463 corank
= e
->ts
.u
.derived
->components
->as
4464 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4466 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4468 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4470 if (ref
->type
== REF_ARRAY
)
4471 corank
= ref
->u
.ar
.as
->corank
;
4472 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4479 /* Check whether the expression has an ultimate allocatable component.
4480 Being itself allocatable does not count. */
4482 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4484 gfc_ref
*ref
, *last
= NULL
;
4486 if (e
->expr_type
!= EXPR_VARIABLE
)
4489 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4490 if (ref
->type
== REF_COMPONENT
)
4493 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4494 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4495 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4496 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4500 if (e
->ts
.type
== BT_CLASS
)
4501 return CLASS_DATA (e
)->attr
.alloc_comp
;
4502 else if (e
->ts
.type
== BT_DERIVED
)
4503 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4509 /* Check whether the expression has an pointer component.
4510 Being itself a pointer does not count. */
4512 gfc_has_ultimate_pointer (gfc_expr
*e
)
4514 gfc_ref
*ref
, *last
= NULL
;
4516 if (e
->expr_type
!= EXPR_VARIABLE
)
4519 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4520 if (ref
->type
== REF_COMPONENT
)
4523 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4524 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4525 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4526 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4530 if (e
->ts
.type
== BT_CLASS
)
4531 return CLASS_DATA (e
)->attr
.pointer_comp
;
4532 else if (e
->ts
.type
== BT_DERIVED
)
4533 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4539 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4540 Note: A scalar is not regarded as "simply contiguous" by the standard.
4541 if bool is not strict, some further checks are done - for instance,
4542 a "(::1)" is accepted. */
4545 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4549 gfc_array_ref
*ar
= NULL
;
4550 gfc_ref
*ref
, *part_ref
= NULL
;
4553 if (expr
->expr_type
== EXPR_FUNCTION
)
4554 return expr
->value
.function
.esym
4555 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4556 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4559 if (expr
->rank
== 0)
4562 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4565 return false; /* Array shall be last part-ref. */
4567 if (ref
->type
== REF_COMPONENT
)
4569 else if (ref
->type
== REF_SUBSTRING
)
4571 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4575 sym
= expr
->symtree
->n
.sym
;
4576 if (expr
->ts
.type
!= BT_CLASS
4578 && !part_ref
->u
.c
.component
->attr
.contiguous
4579 && part_ref
->u
.c
.component
->attr
.pointer
)
4581 && !sym
->attr
.contiguous
4582 && (sym
->attr
.pointer
4583 || sym
->as
->type
== AS_ASSUMED_RANK
4584 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
4587 if (!ar
|| ar
->type
== AR_FULL
)
4590 gcc_assert (ar
->type
== AR_SECTION
);
4592 /* Check for simply contiguous array */
4594 for (i
= 0; i
< ar
->dimen
; i
++)
4596 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4599 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4605 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4608 /* If the previous section was not contiguous, that's an error,
4609 unless we have effective only one element and checking is not
4611 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4612 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4613 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4614 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4615 ar
->end
[i
]->value
.integer
) != 0))
4618 /* Following the standard, "(::1)" or - if known at compile time -
4619 "(lbound:ubound)" are not simply contiguous; if strict
4620 is false, they are regarded as simply contiguous. */
4621 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4622 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4623 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4627 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4628 || !ar
->as
->lower
[i
]
4629 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4630 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4631 ar
->as
->lower
[i
]->value
.integer
) != 0))
4635 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4636 || !ar
->as
->upper
[i
]
4637 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4638 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4639 ar
->as
->upper
[i
]->value
.integer
) != 0))
4647 /* Build call to an intrinsic procedure. The number of arguments has to be
4648 passed (rather than ending the list with a NULL value) because we may
4649 want to add arguments but with a NULL-expression. */
4652 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
4653 locus where
, unsigned numarg
, ...)
4656 gfc_actual_arglist
* atail
;
4657 gfc_intrinsic_sym
* isym
;
4660 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
4662 isym
= gfc_intrinsic_function_by_id (id
);
4665 result
= gfc_get_expr ();
4666 result
->expr_type
= EXPR_FUNCTION
;
4667 result
->ts
= isym
->ts
;
4668 result
->where
= where
;
4669 result
->value
.function
.name
= mangled_name
;
4670 result
->value
.function
.isym
= isym
;
4672 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
4673 gfc_commit_symbol (result
->symtree
->n
.sym
);
4674 gcc_assert (result
->symtree
4675 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
4676 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
4677 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
4678 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4679 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
4681 va_start (ap
, numarg
);
4683 for (i
= 0; i
< numarg
; ++i
)
4687 atail
->next
= gfc_get_actual_arglist ();
4688 atail
= atail
->next
;
4691 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4693 atail
->expr
= va_arg (ap
, gfc_expr
*);
4701 /* Check if an expression may appear in a variable definition context
4702 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4703 This is called from the various places when resolving
4704 the pieces that make up such a context.
4705 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
4706 variables), some checks are not performed.
4708 Optionally, a possible error message can be suppressed if context is NULL
4709 and just the return status (SUCCESS / FAILURE) be requested. */
4712 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4713 bool own_scope
, const char* context
)
4715 gfc_symbol
* sym
= NULL
;
4717 bool check_intentin
;
4720 symbol_attribute attr
;
4723 if (e
->expr_type
== EXPR_VARIABLE
)
4725 gcc_assert (e
->symtree
);
4726 sym
= e
->symtree
->n
.sym
;
4728 else if (e
->expr_type
== EXPR_FUNCTION
)
4730 gcc_assert (e
->symtree
);
4731 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4734 unlimited
= e
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (sym
);
4736 attr
= gfc_expr_attr (e
);
4737 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4739 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4742 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4743 " context (%s) at %L", context
, &e
->where
);
4747 else if (e
->expr_type
!= EXPR_VARIABLE
)
4750 gfc_error ("Non-variable expression in variable definition context (%s)"
4751 " at %L", context
, &e
->where
);
4755 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4758 gfc_error ("Named constant '%s' in variable definition context (%s)"
4759 " at %L", sym
->name
, context
, &e
->where
);
4762 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4763 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4764 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4767 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4768 " a variable", sym
->name
, context
, &e
->where
);
4772 /* Find out whether the expr is a pointer; this also means following
4773 component references to the last one. */
4774 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4775 if (pointer
&& !is_pointer
&& !unlimited
)
4778 gfc_error ("Non-POINTER in pointer association context (%s)"
4779 " at %L", context
, &e
->where
);
4786 || (e
->ts
.type
== BT_DERIVED
4787 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4788 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4791 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4792 context
, &e
->where
);
4796 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
4797 component of sub-component of a pointer; we need to distinguish
4798 assignment to a pointer component from pointer-assignment to a pointer
4799 component. Note that (normal) assignment to procedure pointers is not
4801 check_intentin
= !own_scope
;
4802 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4803 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4804 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4806 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4807 check_intentin
= false;
4808 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4810 ptr_component
= true;
4812 check_intentin
= false;
4815 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4817 if (pointer
&& is_pointer
)
4820 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4821 " association context (%s) at %L",
4822 sym
->name
, context
, &e
->where
);
4825 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
4828 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4829 " definition context (%s) at %L",
4830 sym
->name
, context
, &e
->where
);
4835 /* PROTECTED and use-associated. */
4836 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4838 if (pointer
&& is_pointer
)
4841 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4842 " pointer association context (%s) at %L",
4843 sym
->name
, context
, &e
->where
);
4846 if (!pointer
&& !is_pointer
)
4849 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4850 " variable definition context (%s) at %L",
4851 sym
->name
, context
, &e
->where
);
4856 /* Variable not assignable from a PURE procedure but appears in
4857 variable definition context. */
4858 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4861 gfc_error ("Variable '%s' can not appear in a variable definition"
4862 " context (%s) at %L in PURE procedure",
4863 sym
->name
, context
, &e
->where
);
4867 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
4868 && gfc_impure_variable (sym
))
4873 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4875 sym
= ns
->proc_name
;
4878 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4880 sym
->attr
.implicit_pure
= 0;
4885 /* Check variable definition context for associate-names. */
4886 if (!pointer
&& sym
->assoc
)
4889 gfc_association_list
* assoc
;
4891 gcc_assert (sym
->assoc
->target
);
4893 /* If this is a SELECT TYPE temporary (the association is used internally
4894 for SELECT TYPE), silently go over to the target. */
4895 if (sym
->attr
.select_type_temporary
)
4897 gfc_expr
* t
= sym
->assoc
->target
;
4899 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4900 name
= t
->symtree
->name
;
4902 if (t
->symtree
->n
.sym
->assoc
)
4903 assoc
= t
->symtree
->n
.sym
->assoc
;
4912 gcc_assert (name
&& assoc
);
4914 /* Is association to a valid variable? */
4915 if (!assoc
->variable
)
4919 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4920 gfc_error ("'%s' at %L associated to vector-indexed target can"
4921 " not be used in a variable definition context (%s)",
4922 name
, &e
->where
, context
);
4924 gfc_error ("'%s' at %L associated to expression can"
4925 " not be used in a variable definition context (%s)",
4926 name
, &e
->where
, context
);
4931 /* Target must be allowed to appear in a variable definition context. */
4932 if (gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
)
4936 gfc_error ("Associate-name '%s' can not appear in a variable"
4937 " definition context (%s) at %L because its target"
4938 " at %L can not, either",
4939 name
, context
, &e
->where
,
4940 &assoc
->target
->where
);