1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #include "constructor.h"
32 /* The following set of functions provide access to gfc_expr* of
33 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35 There are two functions available elsewhere that provide
36 slightly different flavours of variables. Namely:
37 expr.c (gfc_get_variable_expr)
38 symbol.c (gfc_lval_expr_from_sym)
39 TODO: Merge these functions, if possible. */
41 /* Get a new expression node. */
49 gfc_clear_ts (&e
->ts
);
57 /* Get a new expression node that is an array constructor
58 of given type and kind. */
61 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
66 e
->expr_type
= EXPR_ARRAY
;
67 e
->value
.constructor
= NULL
;
80 /* Get a new expression node that is the NULL expression. */
83 gfc_get_null_expr (locus
*where
)
88 e
->expr_type
= EXPR_NULL
;
89 e
->ts
.type
= BT_UNKNOWN
;
98 /* Get a new expression node that is an operator expression node. */
101 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
102 gfc_expr
*op1
, gfc_expr
*op2
)
107 e
->expr_type
= EXPR_OP
;
109 e
->value
.op
.op1
= op1
;
110 e
->value
.op
.op2
= op2
;
119 /* Get a new expression node that is an structure constructor
120 of given type and kind. */
123 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
128 e
->expr_type
= EXPR_STRUCTURE
;
129 e
->value
.constructor
= NULL
;
140 /* Get a new expression node that is an constant of given type and kind. */
143 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
148 gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
152 e
->expr_type
= EXPR_CONSTANT
;
160 mpz_init (e
->value
.integer
);
164 gfc_set_model_kind (kind
);
165 mpfr_init (e
->value
.real
);
169 gfc_set_model_kind (kind
);
170 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
181 /* Get a new expression node that is an string constant.
182 If no string is passed, a string of len is allocated,
183 blanked and null-terminated. */
186 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, int len
)
193 dest
= gfc_get_wide_string (len
+ 1);
194 gfc_wide_memset (dest
, ' ', len
);
198 dest
= gfc_char_to_widechar (src
);
200 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
201 where
? where
: &gfc_current_locus
);
202 e
->value
.character
.string
= dest
;
203 e
->value
.character
.length
= len
;
209 /* Get a new expression node that is an integer constant. */
212 gfc_get_int_expr (int kind
, locus
*where
, int value
)
215 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
216 where
? where
: &gfc_current_locus
);
218 mpz_set_si (p
->value
.integer
, value
);
224 /* Get a new expression node that is a logical constant. */
227 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
230 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
231 where
? where
: &gfc_current_locus
);
233 p
->value
.logical
= value
;
240 gfc_get_iokind_expr (locus
*where
, io_kind k
)
244 /* Set the types to something compatible with iokind. This is needed to
245 get through gfc_free_expr later since iokind really has no Basic Type,
249 e
->expr_type
= EXPR_CONSTANT
;
250 e
->ts
.type
= BT_LOGICAL
;
258 /* Given an expression pointer, return a copy of the expression. This
259 subroutine is recursive. */
262 gfc_copy_expr (gfc_expr
*p
)
274 switch (q
->expr_type
)
277 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
278 q
->value
.character
.string
= s
;
279 memcpy (s
, p
->value
.character
.string
,
280 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
284 /* Copy target representation, if it exists. */
285 if (p
->representation
.string
)
287 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
288 q
->representation
.string
= c
;
289 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
292 /* Copy the values of any pointer components of p->value. */
296 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
300 gfc_set_model_kind (q
->ts
.kind
);
301 mpfr_init (q
->value
.real
);
302 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
306 gfc_set_model_kind (q
->ts
.kind
);
307 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
308 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
312 if (p
->representation
.string
)
313 q
->value
.character
.string
314 = gfc_char_to_widechar (q
->representation
.string
);
317 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
318 q
->value
.character
.string
= s
;
320 /* This is the case for the C_NULL_CHAR named constant. */
321 if (p
->value
.character
.length
== 0
322 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
325 /* Need to set the length to 1 to make sure the NUL
326 terminator is copied. */
327 q
->value
.character
.length
= 1;
330 memcpy (s
, p
->value
.character
.string
,
331 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
340 break; /* Already done. */
344 /* Should never be reached. */
346 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
353 switch (q
->value
.op
.op
)
356 case INTRINSIC_PARENTHESES
:
357 case INTRINSIC_UPLUS
:
358 case INTRINSIC_UMINUS
:
359 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
362 default: /* Binary operators. */
363 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
364 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
371 q
->value
.function
.actual
=
372 gfc_copy_actual_arglist (p
->value
.function
.actual
);
377 q
->value
.compcall
.actual
=
378 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
379 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
384 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
392 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
394 q
->ref
= gfc_copy_ref (p
->ref
);
401 gfc_clear_shape (mpz_t
*shape
, int rank
)
405 for (i
= 0; i
< rank
; i
++)
406 mpz_clear (shape
[i
]);
411 gfc_free_shape (mpz_t
**shape
, int rank
)
416 gfc_clear_shape (*shape
, rank
);
422 /* Workhorse function for gfc_free_expr() that frees everything
423 beneath an expression node, but not the node itself. This is
424 useful when we want to simplify a node and replace it with
425 something else or the expression node belongs to another structure. */
428 free_expr0 (gfc_expr
*e
)
430 switch (e
->expr_type
)
433 /* Free any parts of the value that need freeing. */
437 mpz_clear (e
->value
.integer
);
441 mpfr_clear (e
->value
.real
);
445 free (e
->value
.character
.string
);
449 mpc_clear (e
->value
.complex);
456 /* Free the representation. */
457 free (e
->representation
.string
);
462 if (e
->value
.op
.op1
!= NULL
)
463 gfc_free_expr (e
->value
.op
.op1
);
464 if (e
->value
.op
.op2
!= NULL
)
465 gfc_free_expr (e
->value
.op
.op2
);
469 gfc_free_actual_arglist (e
->value
.function
.actual
);
474 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
482 gfc_constructor_free (e
->value
.constructor
);
486 free (e
->value
.character
.string
);
493 gfc_internal_error ("free_expr0(): Bad expr type");
496 /* Free a shape array. */
497 gfc_free_shape (&e
->shape
, e
->rank
);
499 gfc_free_ref_list (e
->ref
);
501 memset (e
, '\0', sizeof (gfc_expr
));
505 /* Free an expression node and everything beneath it. */
508 gfc_free_expr (gfc_expr
*e
)
517 /* Free an argument list and everything below it. */
520 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
522 gfc_actual_arglist
*a2
;
527 gfc_free_expr (a1
->expr
);
534 /* Copy an arglist structure and all of the arguments. */
537 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
539 gfc_actual_arglist
*head
, *tail
, *new_arg
;
543 for (; p
; p
= p
->next
)
545 new_arg
= gfc_get_actual_arglist ();
548 new_arg
->expr
= gfc_copy_expr (p
->expr
);
549 new_arg
->next
= NULL
;
554 tail
->next
= new_arg
;
563 /* Free a list of reference structures. */
566 gfc_free_ref_list (gfc_ref
*p
)
578 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
580 gfc_free_expr (p
->u
.ar
.start
[i
]);
581 gfc_free_expr (p
->u
.ar
.end
[i
]);
582 gfc_free_expr (p
->u
.ar
.stride
[i
]);
588 gfc_free_expr (p
->u
.ss
.start
);
589 gfc_free_expr (p
->u
.ss
.end
);
601 /* Graft the *src expression onto the *dest subexpression. */
604 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
612 /* Try to extract an integer constant from the passed expression node.
613 Returns an error message or NULL if the result is set. It is
614 tempting to generate an error and return true or false, but
615 failure is OK for some callers. */
618 gfc_extract_int (gfc_expr
*expr
, int *result
)
620 if (expr
->expr_type
!= EXPR_CONSTANT
)
621 return _("Constant expression required at %C");
623 if (expr
->ts
.type
!= BT_INTEGER
)
624 return _("Integer expression required at %C");
626 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
627 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
629 return _("Integer value too large in expression at %C");
632 *result
= (int) mpz_get_si (expr
->value
.integer
);
638 /* Recursively copy a list of reference structures. */
641 gfc_copy_ref (gfc_ref
*src
)
649 dest
= gfc_get_ref ();
650 dest
->type
= src
->type
;
655 ar
= gfc_copy_array_ref (&src
->u
.ar
);
661 dest
->u
.c
= src
->u
.c
;
665 dest
->u
.ss
= src
->u
.ss
;
666 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
667 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
671 dest
->next
= gfc_copy_ref (src
->next
);
677 /* Detect whether an expression has any vector index array references. */
680 gfc_has_vector_index (gfc_expr
*e
)
684 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
685 if (ref
->type
== REF_ARRAY
)
686 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
687 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
693 /* Copy a shape array. */
696 gfc_copy_shape (mpz_t
*shape
, int rank
)
704 new_shape
= gfc_get_shape (rank
);
706 for (n
= 0; n
< rank
; n
++)
707 mpz_init_set (new_shape
[n
], shape
[n
]);
713 /* Copy a shape array excluding dimension N, where N is an integer
714 constant expression. Dimensions are numbered in Fortran style --
717 So, if the original shape array contains R elements
718 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
719 the result contains R-1 elements:
720 { s1 ... sN-1 sN+1 ... sR-1}
722 If anything goes wrong -- N is not a constant, its value is out
723 of range -- or anything else, just returns NULL. */
726 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
728 mpz_t
*new_shape
, *s
;
734 || dim
->expr_type
!= EXPR_CONSTANT
735 || dim
->ts
.type
!= BT_INTEGER
)
738 n
= mpz_get_si (dim
->value
.integer
);
739 n
--; /* Convert to zero based index. */
740 if (n
< 0 || n
>= rank
)
743 s
= new_shape
= gfc_get_shape (rank
- 1);
745 for (i
= 0; i
< rank
; i
++)
749 mpz_init_set (*s
, shape
[i
]);
757 /* Return the maximum kind of two expressions. In general, higher
758 kind numbers mean more precision for numeric types. */
761 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
763 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
767 /* Returns nonzero if the type is numeric, zero otherwise. */
770 numeric_type (bt type
)
772 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
776 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
779 gfc_numeric_ts (gfc_typespec
*ts
)
781 return numeric_type (ts
->type
);
785 /* Return an expression node with an optional argument list attached.
786 A variable number of gfc_expr pointers are strung together in an
787 argument list with a NULL pointer terminating the list. */
790 gfc_build_conversion (gfc_expr
*e
)
795 p
->expr_type
= EXPR_FUNCTION
;
797 p
->value
.function
.actual
= NULL
;
799 p
->value
.function
.actual
= gfc_get_actual_arglist ();
800 p
->value
.function
.actual
->expr
= e
;
806 /* Given an expression node with some sort of numeric binary
807 expression, insert type conversions required to make the operands
808 have the same type. Conversion warnings are disabled if wconversion
811 The exception is that the operands of an exponential don't have to
812 have the same type. If possible, the base is promoted to the type
813 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
814 1.0**2 stays as it is. */
817 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
821 op1
= e
->value
.op
.op1
;
822 op2
= e
->value
.op
.op2
;
824 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
826 gfc_clear_ts (&e
->ts
);
830 /* Kind conversions of same type. */
831 if (op1
->ts
.type
== op2
->ts
.type
)
833 if (op1
->ts
.kind
== op2
->ts
.kind
)
835 /* No type conversions. */
840 if (op1
->ts
.kind
> op2
->ts
.kind
)
841 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
843 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
849 /* Integer combined with real or complex. */
850 if (op2
->ts
.type
== BT_INTEGER
)
854 /* Special case for ** operator. */
855 if (e
->value
.op
.op
== INTRINSIC_POWER
)
858 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
862 if (op1
->ts
.type
== BT_INTEGER
)
865 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
869 /* Real combined with complex. */
870 e
->ts
.type
= BT_COMPLEX
;
871 if (op1
->ts
.kind
> op2
->ts
.kind
)
872 e
->ts
.kind
= op1
->ts
.kind
;
874 e
->ts
.kind
= op2
->ts
.kind
;
875 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
876 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
877 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
878 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
885 /* Function to determine if an expression is constant or not. This
886 function expects that the expression has already been simplified. */
889 gfc_is_constant_expr (gfc_expr
*e
)
892 gfc_actual_arglist
*arg
;
898 switch (e
->expr_type
)
901 return (gfc_is_constant_expr (e
->value
.op
.op1
)
902 && (e
->value
.op
.op2
== NULL
903 || gfc_is_constant_expr (e
->value
.op
.op2
)));
911 gcc_assert (e
->symtree
|| e
->value
.function
.esym
912 || e
->value
.function
.isym
);
914 /* Call to intrinsic with at least one argument. */
915 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
917 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
918 if (!gfc_is_constant_expr (arg
->expr
))
922 /* Specification functions are constant. */
923 /* F95, 7.1.6.2; F2003, 7.1.7 */
926 sym
= e
->symtree
->n
.sym
;
927 if (e
->value
.function
.esym
)
928 sym
= e
->value
.function
.esym
;
931 && sym
->attr
.function
933 && !sym
->attr
.intrinsic
934 && !sym
->attr
.recursive
935 && sym
->attr
.proc
!= PROC_INTERNAL
936 && sym
->attr
.proc
!= PROC_ST_FUNCTION
937 && sym
->attr
.proc
!= PROC_UNKNOWN
938 && gfc_sym_get_dummy_args (sym
) == NULL
)
941 if (e
->value
.function
.isym
942 && (e
->value
.function
.isym
->elemental
943 || e
->value
.function
.isym
->pure
944 || e
->value
.function
.isym
->inquiry
945 || e
->value
.function
.isym
->transformational
))
955 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
956 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
960 c
= gfc_constructor_first (e
->value
.constructor
);
961 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
962 return gfc_constant_ac (e
);
964 for (; c
; c
= gfc_constructor_next (c
))
965 if (!gfc_is_constant_expr (c
->expr
))
972 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
978 /* Is true if an array reference is followed by a component or substring
981 is_subref_array (gfc_expr
* e
)
986 if (e
->expr_type
!= EXPR_VARIABLE
)
989 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
993 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
995 if (ref
->type
== REF_ARRAY
996 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1000 && ref
->type
!= REF_ARRAY
)
1007 /* Try to collapse intrinsic expressions. */
1010 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1012 gfc_intrinsic_op op
;
1013 gfc_expr
*op1
, *op2
, *result
;
1015 if (p
->value
.op
.op
== INTRINSIC_USER
)
1018 op1
= p
->value
.op
.op1
;
1019 op2
= p
->value
.op
.op2
;
1020 op
= p
->value
.op
.op
;
1022 if (!gfc_simplify_expr (op1
, type
))
1024 if (!gfc_simplify_expr (op2
, type
))
1027 if (!gfc_is_constant_expr (op1
)
1028 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1032 p
->value
.op
.op1
= NULL
;
1033 p
->value
.op
.op2
= NULL
;
1037 case INTRINSIC_PARENTHESES
:
1038 result
= gfc_parentheses (op1
);
1041 case INTRINSIC_UPLUS
:
1042 result
= gfc_uplus (op1
);
1045 case INTRINSIC_UMINUS
:
1046 result
= gfc_uminus (op1
);
1049 case INTRINSIC_PLUS
:
1050 result
= gfc_add (op1
, op2
);
1053 case INTRINSIC_MINUS
:
1054 result
= gfc_subtract (op1
, op2
);
1057 case INTRINSIC_TIMES
:
1058 result
= gfc_multiply (op1
, op2
);
1061 case INTRINSIC_DIVIDE
:
1062 result
= gfc_divide (op1
, op2
);
1065 case INTRINSIC_POWER
:
1066 result
= gfc_power (op1
, op2
);
1069 case INTRINSIC_CONCAT
:
1070 result
= gfc_concat (op1
, op2
);
1074 case INTRINSIC_EQ_OS
:
1075 result
= gfc_eq (op1
, op2
, op
);
1079 case INTRINSIC_NE_OS
:
1080 result
= gfc_ne (op1
, op2
, op
);
1084 case INTRINSIC_GT_OS
:
1085 result
= gfc_gt (op1
, op2
, op
);
1089 case INTRINSIC_GE_OS
:
1090 result
= gfc_ge (op1
, op2
, op
);
1094 case INTRINSIC_LT_OS
:
1095 result
= gfc_lt (op1
, op2
, op
);
1099 case INTRINSIC_LE_OS
:
1100 result
= gfc_le (op1
, op2
, op
);
1104 result
= gfc_not (op1
);
1108 result
= gfc_and (op1
, op2
);
1112 result
= gfc_or (op1
, op2
);
1116 result
= gfc_eqv (op1
, op2
);
1119 case INTRINSIC_NEQV
:
1120 result
= gfc_neqv (op1
, op2
);
1124 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1129 gfc_free_expr (op1
);
1130 gfc_free_expr (op2
);
1134 result
->rank
= p
->rank
;
1135 result
->where
= p
->where
;
1136 gfc_replace_expr (p
, result
);
1142 /* Subroutine to simplify constructor expressions. Mutually recursive
1143 with gfc_simplify_expr(). */
1146 simplify_constructor (gfc_constructor_base base
, int type
)
1151 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1154 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1155 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1156 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1161 /* Try and simplify a copy. Replace the original if successful
1162 but keep going through the constructor at all costs. Not
1163 doing so can make a dog's dinner of complicated things. */
1164 p
= gfc_copy_expr (c
->expr
);
1166 if (!gfc_simplify_expr (p
, type
))
1172 gfc_replace_expr (c
->expr
, p
);
1180 /* Pull a single array element out of an array constructor. */
1183 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1184 gfc_constructor
**rval
)
1186 unsigned long nelemen
;
1192 gfc_constructor
*cons
;
1199 mpz_init_set_ui (offset
, 0);
1202 mpz_init_set_ui (span
, 1);
1203 for (i
= 0; i
< ar
->dimen
; i
++)
1205 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1206 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1214 if (e
->expr_type
!= EXPR_CONSTANT
)
1220 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1221 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1223 /* Check the bounds. */
1224 if ((ar
->as
->upper
[i
]
1225 && mpz_cmp (e
->value
.integer
,
1226 ar
->as
->upper
[i
]->value
.integer
) > 0)
1227 || (mpz_cmp (e
->value
.integer
,
1228 ar
->as
->lower
[i
]->value
.integer
) < 0))
1230 gfc_error ("Index in dimension %d is out of bounds "
1231 "at %L", i
+ 1, &ar
->c_where
[i
]);
1237 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1238 mpz_mul (delta
, delta
, span
);
1239 mpz_add (offset
, offset
, delta
);
1241 mpz_set_ui (tmp
, 1);
1242 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1243 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1244 mpz_mul (span
, span
, tmp
);
1247 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1248 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1267 /* Find a component of a structure constructor. */
1269 static gfc_constructor
*
1270 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1272 gfc_component
*comp
;
1273 gfc_component
*pick
;
1274 gfc_constructor
*c
= gfc_constructor_first (base
);
1276 comp
= ref
->u
.c
.sym
->components
;
1277 pick
= ref
->u
.c
.component
;
1278 while (comp
!= pick
)
1281 c
= gfc_constructor_next (c
);
1288 /* Replace an expression with the contents of a constructor, removing
1289 the subobject reference in the process. */
1292 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1302 e
= gfc_copy_expr (p
);
1303 e
->ref
= p
->ref
->next
;
1304 p
->ref
->next
= NULL
;
1305 gfc_replace_expr (p
, e
);
1309 /* Pull an array section out of an array constructor. */
1312 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1319 long unsigned one
= 1;
1321 mpz_t start
[GFC_MAX_DIMENSIONS
];
1322 mpz_t end
[GFC_MAX_DIMENSIONS
];
1323 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1324 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1325 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1330 gfc_constructor_base base
;
1331 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1341 base
= expr
->value
.constructor
;
1342 expr
->value
.constructor
= NULL
;
1344 rank
= ref
->u
.ar
.as
->rank
;
1346 if (expr
->shape
== NULL
)
1347 expr
->shape
= gfc_get_shape (rank
);
1349 mpz_init_set_ui (delta_mpz
, one
);
1350 mpz_init_set_ui (nelts
, one
);
1353 /* Do the initialization now, so that we can cleanup without
1354 keeping track of where we were. */
1355 for (d
= 0; d
< rank
; d
++)
1357 mpz_init (delta
[d
]);
1358 mpz_init (start
[d
]);
1361 mpz_init (stride
[d
]);
1365 /* Build the counters to clock through the array reference. */
1367 for (d
= 0; d
< rank
; d
++)
1369 /* Make this stretch of code easier on the eye! */
1370 begin
= ref
->u
.ar
.start
[d
];
1371 finish
= ref
->u
.ar
.end
[d
];
1372 step
= ref
->u
.ar
.stride
[d
];
1373 lower
= ref
->u
.ar
.as
->lower
[d
];
1374 upper
= ref
->u
.ar
.as
->upper
[d
];
1376 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1378 gfc_constructor
*ci
;
1381 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1387 gcc_assert (begin
->rank
== 1);
1388 /* Zero-sized arrays have no shape and no elements, stop early. */
1391 mpz_init_set_ui (nelts
, 0);
1395 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1396 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1397 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1398 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1401 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1403 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1404 || mpz_cmp (ci
->expr
->value
.integer
,
1405 lower
->value
.integer
) < 0)
1407 gfc_error ("index in dimension %d is out of bounds "
1408 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1416 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1417 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1418 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1424 /* Obtain the stride. */
1426 mpz_set (stride
[d
], step
->value
.integer
);
1428 mpz_set_ui (stride
[d
], one
);
1430 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1431 mpz_set_ui (stride
[d
], one
);
1433 /* Obtain the start value for the index. */
1435 mpz_set (start
[d
], begin
->value
.integer
);
1437 mpz_set (start
[d
], lower
->value
.integer
);
1439 mpz_set (ctr
[d
], start
[d
]);
1441 /* Obtain the end value for the index. */
1443 mpz_set (end
[d
], finish
->value
.integer
);
1445 mpz_set (end
[d
], upper
->value
.integer
);
1447 /* Separate 'if' because elements sometimes arrive with
1449 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1450 mpz_set (end
[d
], begin
->value
.integer
);
1452 /* Check the bounds. */
1453 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1454 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1455 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1456 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1458 gfc_error ("index in dimension %d is out of bounds "
1459 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1464 /* Calculate the number of elements and the shape. */
1465 mpz_set (tmp_mpz
, stride
[d
]);
1466 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1467 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1468 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1469 mpz_mul (nelts
, nelts
, tmp_mpz
);
1471 /* An element reference reduces the rank of the expression; don't
1472 add anything to the shape array. */
1473 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1474 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1477 /* Calculate the 'stride' (=delta) for conversion of the
1478 counter values into the index along the constructor. */
1479 mpz_set (delta
[d
], delta_mpz
);
1480 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1481 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1482 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1486 cons
= gfc_constructor_first (base
);
1488 /* Now clock through the array reference, calculating the index in
1489 the source constructor and transferring the elements to the new
1491 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1493 mpz_init_set_ui (ptr
, 0);
1496 for (d
= 0; d
< rank
; d
++)
1498 mpz_set (tmp_mpz
, ctr
[d
]);
1499 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1500 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1501 mpz_add (ptr
, ptr
, tmp_mpz
);
1503 if (!incr_ctr
) continue;
1505 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1507 gcc_assert(vecsub
[d
]);
1509 if (!gfc_constructor_next (vecsub
[d
]))
1510 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1513 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1516 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1520 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1522 if (mpz_cmp_ui (stride
[d
], 0) > 0
1523 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1524 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1525 mpz_set (ctr
[d
], start
[d
]);
1531 limit
= mpz_get_ui (ptr
);
1532 if (limit
>= gfc_option
.flag_max_array_constructor
)
1534 gfc_error ("The number of elements in the array constructor "
1535 "at %L requires an increase of the allowed %d "
1536 "upper limit. See -fmax-array-constructor "
1537 "option", &expr
->where
,
1538 gfc_option
.flag_max_array_constructor
);
1542 cons
= gfc_constructor_lookup (base
, limit
);
1544 gfc_constructor_append_expr (&expr
->value
.constructor
,
1545 gfc_copy_expr (cons
->expr
), NULL
);
1552 mpz_clear (delta_mpz
);
1553 mpz_clear (tmp_mpz
);
1555 for (d
= 0; d
< rank
; d
++)
1557 mpz_clear (delta
[d
]);
1558 mpz_clear (start
[d
]);
1561 mpz_clear (stride
[d
]);
1563 gfc_constructor_free (base
);
1567 /* Pull a substring out of an expression. */
1570 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1577 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1578 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1581 *newp
= gfc_copy_expr (p
);
1582 free ((*newp
)->value
.character
.string
);
1584 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1585 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1586 length
= end
- start
+ 1;
1588 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1589 (*newp
)->value
.character
.length
= length
;
1590 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1591 length
* sizeof (gfc_char_t
));
1598 /* Simplify a subobject reference of a constructor. This occurs when
1599 parameter variable values are substituted. */
1602 simplify_const_ref (gfc_expr
*p
)
1604 gfc_constructor
*cons
, *c
;
1610 switch (p
->ref
->type
)
1613 switch (p
->ref
->u
.ar
.type
)
1616 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1617 will generate this. */
1618 if (p
->expr_type
!= EXPR_ARRAY
)
1620 remove_subobject_ref (p
, NULL
);
1623 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1629 remove_subobject_ref (p
, cons
);
1633 if (!find_array_section (p
, p
->ref
))
1635 p
->ref
->u
.ar
.type
= AR_FULL
;
1640 if (p
->ref
->next
!= NULL
1641 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1643 for (c
= gfc_constructor_first (p
->value
.constructor
);
1644 c
; c
= gfc_constructor_next (c
))
1646 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1647 if (!simplify_const_ref (c
->expr
))
1651 if (p
->ts
.type
== BT_DERIVED
1653 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1655 /* There may have been component references. */
1656 p
->ts
= c
->expr
->ts
;
1660 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1662 if (p
->ts
.type
== BT_CHARACTER
1663 && last_ref
->type
== REF_SUBSTRING
)
1665 /* If this is a CHARACTER array and we possibly took
1666 a substring out of it, update the type-spec's
1667 character length according to the first element
1668 (as all should have the same length). */
1670 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1672 const gfc_expr
* first
= c
->expr
;
1673 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1674 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1675 string_len
= first
->value
.character
.length
;
1681 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1684 gfc_free_expr (p
->ts
.u
.cl
->length
);
1687 = gfc_get_int_expr (gfc_default_integer_kind
,
1691 gfc_free_ref_list (p
->ref
);
1702 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1703 remove_subobject_ref (p
, cons
);
1707 if (!find_substring_ref (p
, &newp
))
1710 gfc_replace_expr (p
, newp
);
1711 gfc_free_ref_list (p
->ref
);
1721 /* Simplify a chain of references. */
1724 simplify_ref_chain (gfc_ref
*ref
, int type
)
1728 for (; ref
; ref
= ref
->next
)
1733 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1735 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1737 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1739 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1745 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1747 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1759 /* Try to substitute the value of a parameter variable. */
1762 simplify_parameter_variable (gfc_expr
*p
, int type
)
1767 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1773 /* Do not copy subobject refs for constant. */
1774 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1775 e
->ref
= gfc_copy_ref (p
->ref
);
1776 t
= gfc_simplify_expr (e
, type
);
1778 /* Only use the simplification if it eliminated all subobject references. */
1780 gfc_replace_expr (p
, e
);
1787 /* Given an expression, simplify it by collapsing constant
1788 expressions. Most simplification takes place when the expression
1789 tree is being constructed. If an intrinsic function is simplified
1790 at some point, we get called again to collapse the result against
1793 We work by recursively simplifying expression nodes, simplifying
1794 intrinsic functions where possible, which can lead to further
1795 constant collapsing. If an operator has constant operand(s), we
1796 rip the expression apart, and rebuild it, hoping that it becomes
1799 The expression type is defined for:
1800 0 Basic expression parsing
1801 1 Simplifying array constructors -- will substitute
1803 Returns false on error, true otherwise.
1804 NOTE: Will return true even if the expression can not be simplified. */
1807 gfc_simplify_expr (gfc_expr
*p
, int type
)
1809 gfc_actual_arglist
*ap
;
1814 switch (p
->expr_type
)
1821 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1822 if (!gfc_simplify_expr (ap
->expr
, type
))
1825 if (p
->value
.function
.isym
!= NULL
1826 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1831 case EXPR_SUBSTRING
:
1832 if (!simplify_ref_chain (p
->ref
, type
))
1835 if (gfc_is_constant_expr (p
))
1841 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1843 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1844 start
--; /* Convert from one-based to zero-based. */
1847 end
= p
->value
.character
.length
;
1848 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1849 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1854 s
= gfc_get_wide_string (end
- start
+ 2);
1855 memcpy (s
, p
->value
.character
.string
+ start
,
1856 (end
- start
) * sizeof (gfc_char_t
));
1857 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1858 free (p
->value
.character
.string
);
1859 p
->value
.character
.string
= s
;
1860 p
->value
.character
.length
= end
- start
;
1861 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1862 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1864 p
->value
.character
.length
);
1865 gfc_free_ref_list (p
->ref
);
1867 p
->expr_type
= EXPR_CONSTANT
;
1872 if (!simplify_intrinsic_op (p
, type
))
1877 /* Only substitute array parameter variables if we are in an
1878 initialization expression, or we want a subsection. */
1879 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1880 && (gfc_init_expr_flag
|| p
->ref
1881 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1883 if (!simplify_parameter_variable (p
, type
))
1890 gfc_simplify_iterator_var (p
);
1893 /* Simplify subcomponent references. */
1894 if (!simplify_ref_chain (p
->ref
, type
))
1899 case EXPR_STRUCTURE
:
1901 if (!simplify_ref_chain (p
->ref
, type
))
1904 if (!simplify_constructor (p
->value
.constructor
, type
))
1907 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1908 && p
->ref
->u
.ar
.type
== AR_FULL
)
1909 gfc_expand_constructor (p
, false);
1911 if (!simplify_const_ref (p
))
1925 /* Returns the type of an expression with the exception that iterator
1926 variables are automatically integers no matter what else they may
1932 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1939 /* Scalarize an expression for an elemental intrinsic call. */
1942 scalarize_intrinsic_call (gfc_expr
*e
)
1944 gfc_actual_arglist
*a
, *b
;
1945 gfc_constructor_base ctor
;
1946 gfc_constructor
*args
[5];
1947 gfc_constructor
*ci
, *new_ctor
;
1948 gfc_expr
*expr
, *old
;
1949 int n
, i
, rank
[5], array_arg
;
1951 /* Find which, if any, arguments are arrays. Assume that the old
1952 expression carries the type information and that the first arg
1953 that is an array expression carries all the shape information.*/
1955 a
= e
->value
.function
.actual
;
1956 for (; a
; a
= a
->next
)
1959 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
1962 expr
= gfc_copy_expr (a
->expr
);
1969 old
= gfc_copy_expr (e
);
1971 gfc_constructor_free (expr
->value
.constructor
);
1972 expr
->value
.constructor
= NULL
;
1974 expr
->where
= old
->where
;
1975 expr
->expr_type
= EXPR_ARRAY
;
1977 /* Copy the array argument constructors into an array, with nulls
1980 a
= old
->value
.function
.actual
;
1981 for (; a
; a
= a
->next
)
1983 /* Check that this is OK for an initialization expression. */
1984 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
1988 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1990 rank
[n
] = a
->expr
->rank
;
1991 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1992 args
[n
] = gfc_constructor_first (ctor
);
1994 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1997 rank
[n
] = a
->expr
->rank
;
2000 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2001 args
[n
] = gfc_constructor_first (ctor
);
2010 /* Using the array argument as the master, step through the array
2011 calling the function for each element and advancing the array
2012 constructors together. */
2013 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2015 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2016 gfc_copy_expr (old
), NULL
);
2018 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2020 b
= old
->value
.function
.actual
;
2021 for (i
= 0; i
< n
; i
++)
2024 new_ctor
->expr
->value
.function
.actual
2025 = a
= gfc_get_actual_arglist ();
2028 a
->next
= gfc_get_actual_arglist ();
2033 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2035 a
->expr
= gfc_copy_expr (b
->expr
);
2040 /* Simplify the function calls. If the simplification fails, the
2041 error will be flagged up down-stream or the library will deal
2043 gfc_simplify_expr (new_ctor
->expr
, 0);
2045 for (i
= 0; i
< n
; i
++)
2047 args
[i
] = gfc_constructor_next (args
[i
]);
2049 for (i
= 1; i
< n
; i
++)
2050 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2051 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2057 /* Free "expr" but not the pointers it contains. */
2059 gfc_free_expr (old
);
2063 gfc_error_now ("elemental function arguments at %C are not compliant");
2066 gfc_free_expr (expr
);
2067 gfc_free_expr (old
);
2073 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2075 gfc_expr
*op1
= e
->value
.op
.op1
;
2076 gfc_expr
*op2
= e
->value
.op
.op2
;
2078 if (!(*check_function
)(op1
))
2081 switch (e
->value
.op
.op
)
2083 case INTRINSIC_UPLUS
:
2084 case INTRINSIC_UMINUS
:
2085 if (!numeric_type (et0 (op1
)))
2090 case INTRINSIC_EQ_OS
:
2092 case INTRINSIC_NE_OS
:
2094 case INTRINSIC_GT_OS
:
2096 case INTRINSIC_GE_OS
:
2098 case INTRINSIC_LT_OS
:
2100 case INTRINSIC_LE_OS
:
2101 if (!(*check_function
)(op2
))
2104 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2105 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2107 gfc_error ("Numeric or CHARACTER operands are required in "
2108 "expression at %L", &e
->where
);
2113 case INTRINSIC_PLUS
:
2114 case INTRINSIC_MINUS
:
2115 case INTRINSIC_TIMES
:
2116 case INTRINSIC_DIVIDE
:
2117 case INTRINSIC_POWER
:
2118 if (!(*check_function
)(op2
))
2121 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2126 case INTRINSIC_CONCAT
:
2127 if (!(*check_function
)(op2
))
2130 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2132 gfc_error ("Concatenation operator in expression at %L "
2133 "must have two CHARACTER operands", &op1
->where
);
2137 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2139 gfc_error ("Concat operator at %L must concatenate strings of the "
2140 "same kind", &e
->where
);
2147 if (et0 (op1
) != BT_LOGICAL
)
2149 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2150 "operand", &op1
->where
);
2159 case INTRINSIC_NEQV
:
2160 if (!(*check_function
)(op2
))
2163 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2165 gfc_error ("LOGICAL operands are required in expression at %L",
2172 case INTRINSIC_PARENTHESES
:
2176 gfc_error ("Only intrinsic operators can be used in expression at %L",
2184 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2189 /* F2003, 7.1.7 (3): In init expression, allocatable components
2190 must not be data-initialized. */
2192 check_alloc_comp_init (gfc_expr
*e
)
2194 gfc_component
*comp
;
2195 gfc_constructor
*ctor
;
2197 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2198 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2200 for (comp
= e
->ts
.u
.derived
->components
,
2201 ctor
= gfc_constructor_first (e
->value
.constructor
);
2202 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2204 if (comp
->attr
.allocatable
2205 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2207 gfc_error("Invalid initialization expression for ALLOCATABLE "
2208 "component '%s' in structure constructor at %L",
2209 comp
->name
, &ctor
->expr
->where
);
2218 check_init_expr_arguments (gfc_expr
*e
)
2220 gfc_actual_arglist
*ap
;
2222 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2223 if (!gfc_check_init_expr (ap
->expr
))
2229 static bool check_restricted (gfc_expr
*);
2231 /* F95, 7.1.6.1, Initialization expressions, (7)
2232 F2003, 7.1.7 Initialization expression, (8) */
2235 check_inquiry (gfc_expr
*e
, int not_restricted
)
2238 const char *const *functions
;
2240 static const char *const inquiry_func_f95
[] = {
2241 "lbound", "shape", "size", "ubound",
2242 "bit_size", "len", "kind",
2243 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2244 "precision", "radix", "range", "tiny",
2248 static const char *const inquiry_func_f2003
[] = {
2249 "lbound", "shape", "size", "ubound",
2250 "bit_size", "len", "kind",
2251 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2252 "precision", "radix", "range", "tiny",
2257 gfc_actual_arglist
*ap
;
2259 if (!e
->value
.function
.isym
2260 || !e
->value
.function
.isym
->inquiry
)
2263 /* An undeclared parameter will get us here (PR25018). */
2264 if (e
->symtree
== NULL
)
2267 if (e
->symtree
->n
.sym
->from_intmod
)
2269 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2270 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2271 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2274 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2275 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2280 name
= e
->symtree
->n
.sym
->name
;
2282 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2283 ? inquiry_func_f2003
: inquiry_func_f95
;
2285 for (i
= 0; functions
[i
]; i
++)
2286 if (strcmp (functions
[i
], name
) == 0)
2289 if (functions
[i
] == NULL
)
2293 /* At this point we have an inquiry function with a variable argument. The
2294 type of the variable might be undefined, but we need it now, because the
2295 arguments of these functions are not allowed to be undefined. */
2297 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2302 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2304 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2305 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2308 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2311 /* Assumed character length will not reduce to a constant expression
2312 with LEN, as required by the standard. */
2313 if (i
== 5 && not_restricted
2314 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2315 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2316 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2318 gfc_error ("Assumed or deferred character length variable '%s' "
2319 " in constant expression at %L",
2320 ap
->expr
->symtree
->n
.sym
->name
,
2324 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2327 if (not_restricted
== 0
2328 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2329 && !check_restricted (ap
->expr
))
2332 if (not_restricted
== 0
2333 && ap
->expr
->expr_type
== EXPR_VARIABLE
2334 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2335 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2343 /* F95, 7.1.6.1, Initialization expressions, (5)
2344 F2003, 7.1.7 Initialization expression, (5) */
2347 check_transformational (gfc_expr
*e
)
2349 static const char * const trans_func_f95
[] = {
2350 "repeat", "reshape", "selected_int_kind",
2351 "selected_real_kind", "transfer", "trim", NULL
2354 static const char * const trans_func_f2003
[] = {
2355 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2356 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2357 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2358 "trim", "unpack", NULL
2363 const char *const *functions
;
2365 if (!e
->value
.function
.isym
2366 || !e
->value
.function
.isym
->transformational
)
2369 name
= e
->symtree
->n
.sym
->name
;
2371 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2372 ? trans_func_f2003
: trans_func_f95
;
2374 /* NULL() is dealt with below. */
2375 if (strcmp ("null", name
) == 0)
2378 for (i
= 0; functions
[i
]; i
++)
2379 if (strcmp (functions
[i
], name
) == 0)
2382 if (functions
[i
] == NULL
)
2384 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2385 "in an initialization expression", name
, &e
->where
);
2389 return check_init_expr_arguments (e
);
2393 /* F95, 7.1.6.1, Initialization expressions, (6)
2394 F2003, 7.1.7 Initialization expression, (6) */
2397 check_null (gfc_expr
*e
)
2399 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2402 return check_init_expr_arguments (e
);
2407 check_elemental (gfc_expr
*e
)
2409 if (!e
->value
.function
.isym
2410 || !e
->value
.function
.isym
->elemental
)
2413 if (e
->ts
.type
!= BT_INTEGER
2414 && e
->ts
.type
!= BT_CHARACTER
2415 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2416 "initialization expression at %L", &e
->where
))
2419 return check_init_expr_arguments (e
);
2424 check_conversion (gfc_expr
*e
)
2426 if (!e
->value
.function
.isym
2427 || !e
->value
.function
.isym
->conversion
)
2430 return check_init_expr_arguments (e
);
2434 /* Verify that an expression is an initialization expression. A side
2435 effect is that the expression tree is reduced to a single constant
2436 node if all goes well. This would normally happen when the
2437 expression is constructed but function references are assumed to be
2438 intrinsics in the context of initialization expressions. If
2439 false is returned an error message has been generated. */
2442 gfc_check_init_expr (gfc_expr
*e
)
2450 switch (e
->expr_type
)
2453 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2455 t
= gfc_simplify_expr (e
, 0);
2463 gfc_intrinsic_sym
* isym
;
2464 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2466 /* Special case for IEEE_SELECTED_REAL_KIND from the intrinsic
2467 module IEEE_ARITHMETIC, which is allowed in initialization
2469 if (!strcmp(sym
->name
, "ieee_selected_real_kind")
2470 && sym
->from_intmod
== INTMOD_IEEE_ARITHMETIC
)
2472 gfc_expr
*new_expr
= gfc_simplify_ieee_selected_real_kind (e
);
2475 gfc_replace_expr (e
, new_expr
);
2481 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2482 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2484 gfc_error ("Function '%s' in initialization expression at %L "
2485 "must be an intrinsic function",
2486 e
->symtree
->n
.sym
->name
, &e
->where
);
2490 if ((m
= check_conversion (e
)) == MATCH_NO
2491 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2492 && (m
= check_null (e
)) == MATCH_NO
2493 && (m
= check_transformational (e
)) == MATCH_NO
2494 && (m
= check_elemental (e
)) == MATCH_NO
)
2496 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2497 "in an initialization expression",
2498 e
->symtree
->n
.sym
->name
, &e
->where
);
2502 if (m
== MATCH_ERROR
)
2505 /* Try to scalarize an elemental intrinsic function that has an
2507 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2508 if (isym
&& isym
->elemental
2509 && (t
= scalarize_intrinsic_call(e
)))
2514 t
= gfc_simplify_expr (e
, 0);
2521 if (gfc_check_iter_variable (e
))
2524 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2526 /* A PARAMETER shall not be used to define itself, i.e.
2527 REAL, PARAMETER :: x = transfer(0, x)
2529 if (!e
->symtree
->n
.sym
->value
)
2531 gfc_error("PARAMETER '%s' is used at %L before its definition "
2532 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2536 t
= simplify_parameter_variable (e
, 0);
2541 if (gfc_in_match_data ())
2546 if (e
->symtree
->n
.sym
->as
)
2548 switch (e
->symtree
->n
.sym
->as
->type
)
2550 case AS_ASSUMED_SIZE
:
2551 gfc_error ("Assumed size array '%s' at %L is not permitted "
2552 "in an initialization expression",
2553 e
->symtree
->n
.sym
->name
, &e
->where
);
2556 case AS_ASSUMED_SHAPE
:
2557 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2558 "in an initialization expression",
2559 e
->symtree
->n
.sym
->name
, &e
->where
);
2563 gfc_error ("Deferred array '%s' at %L is not permitted "
2564 "in an initialization expression",
2565 e
->symtree
->n
.sym
->name
, &e
->where
);
2569 gfc_error ("Array '%s' at %L is a variable, which does "
2570 "not reduce to a constant expression",
2571 e
->symtree
->n
.sym
->name
, &e
->where
);
2579 gfc_error ("Parameter '%s' at %L has not been declared or is "
2580 "a variable, which does not reduce to a constant "
2581 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2590 case EXPR_SUBSTRING
:
2591 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2595 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2597 t
= gfc_simplify_expr (e
, 0);
2601 case EXPR_STRUCTURE
:
2602 t
= e
->ts
.is_iso_c
? true : false;
2606 t
= check_alloc_comp_init (e
);
2610 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2617 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2621 t
= gfc_expand_constructor (e
, true);
2625 t
= gfc_check_constructor_type (e
);
2629 gfc_internal_error ("check_init_expr(): Unknown expression type");
2635 /* Reduces a general expression to an initialization expression (a constant).
2636 This used to be part of gfc_match_init_expr.
2637 Note that this function doesn't free the given expression on false. */
2640 gfc_reduce_init_expr (gfc_expr
*expr
)
2644 gfc_init_expr_flag
= true;
2645 t
= gfc_resolve_expr (expr
);
2647 t
= gfc_check_init_expr (expr
);
2648 gfc_init_expr_flag
= false;
2653 if (expr
->expr_type
== EXPR_ARRAY
)
2655 if (!gfc_check_constructor_type (expr
))
2657 if (!gfc_expand_constructor (expr
, true))
2665 /* Match an initialization expression. We work by first matching an
2666 expression, then reducing it to a constant. */
2669 gfc_match_init_expr (gfc_expr
**result
)
2677 gfc_init_expr_flag
= true;
2679 m
= gfc_match_expr (&expr
);
2682 gfc_init_expr_flag
= false;
2686 t
= gfc_reduce_init_expr (expr
);
2689 gfc_free_expr (expr
);
2690 gfc_init_expr_flag
= false;
2695 gfc_init_expr_flag
= false;
2701 /* Given an actual argument list, test to see that each argument is a
2702 restricted expression and optionally if the expression type is
2703 integer or character. */
2706 restricted_args (gfc_actual_arglist
*a
)
2708 for (; a
; a
= a
->next
)
2710 if (!check_restricted (a
->expr
))
2718 /************* Restricted/specification expressions *************/
2721 /* Make sure a non-intrinsic function is a specification function. */
2724 external_spec_function (gfc_expr
*e
)
2728 f
= e
->value
.function
.esym
;
2730 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2732 gfc_error ("Specification function '%s' at %L cannot be a statement "
2733 "function", f
->name
, &e
->where
);
2737 if (f
->attr
.proc
== PROC_INTERNAL
)
2739 gfc_error ("Specification function '%s' at %L cannot be an internal "
2740 "function", f
->name
, &e
->where
);
2744 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2746 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2751 if (f
->attr
.recursive
)
2753 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2754 f
->name
, &e
->where
);
2758 return restricted_args (e
->value
.function
.actual
);
2762 /* Check to see that a function reference to an intrinsic is a
2763 restricted expression. */
2766 restricted_intrinsic (gfc_expr
*e
)
2768 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2769 if (check_inquiry (e
, 0) == MATCH_YES
)
2772 return restricted_args (e
->value
.function
.actual
);
2776 /* Check the expressions of an actual arglist. Used by check_restricted. */
2779 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2781 for (; arg
; arg
= arg
->next
)
2782 if (!checker (arg
->expr
))
2789 /* Check the subscription expressions of a reference chain with a checking
2790 function; used by check_restricted. */
2793 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2803 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2805 if (!checker (ref
->u
.ar
.start
[dim
]))
2807 if (!checker (ref
->u
.ar
.end
[dim
]))
2809 if (!checker (ref
->u
.ar
.stride
[dim
]))
2815 /* Nothing needed, just proceed to next reference. */
2819 if (!checker (ref
->u
.ss
.start
))
2821 if (!checker (ref
->u
.ss
.end
))
2830 return check_references (ref
->next
, checker
);
2834 /* Verify that an expression is a restricted expression. Like its
2835 cousin check_init_expr(), an error message is generated if we
2839 check_restricted (gfc_expr
*e
)
2847 switch (e
->expr_type
)
2850 t
= check_intrinsic_op (e
, check_restricted
);
2852 t
= gfc_simplify_expr (e
, 0);
2857 if (e
->value
.function
.esym
)
2859 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2861 t
= external_spec_function (e
);
2865 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2868 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2871 t
= restricted_intrinsic (e
);
2876 sym
= e
->symtree
->n
.sym
;
2879 /* If a dummy argument appears in a context that is valid for a
2880 restricted expression in an elemental procedure, it will have
2881 already been simplified away once we get here. Therefore we
2882 don't need to jump through hoops to distinguish valid from
2884 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2885 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2887 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2888 sym
->name
, &e
->where
);
2892 if (sym
->attr
.optional
)
2894 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2895 sym
->name
, &e
->where
);
2899 if (sym
->attr
.intent
== INTENT_OUT
)
2901 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2902 sym
->name
, &e
->where
);
2906 /* Check reference chain if any. */
2907 if (!check_references (e
->ref
, &check_restricted
))
2910 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2911 processed in resolve.c(resolve_formal_arglist). This is done so
2912 that host associated dummy array indices are accepted (PR23446).
2913 This mechanism also does the same for the specification expressions
2914 of array-valued functions. */
2916 || sym
->attr
.in_common
2917 || sym
->attr
.use_assoc
2919 || sym
->attr
.implied_index
2920 || sym
->attr
.flavor
== FL_PARAMETER
2921 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2922 || (sym
->ns
&& gfc_current_ns
->parent
2923 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2924 || (sym
->ns
->proc_name
!= NULL
2925 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2926 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2932 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2933 sym
->name
, &e
->where
);
2934 /* Prevent a repetition of the error. */
2943 case EXPR_SUBSTRING
:
2944 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2948 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2950 t
= gfc_simplify_expr (e
, 0);
2954 case EXPR_STRUCTURE
:
2955 t
= gfc_check_constructor (e
, check_restricted
);
2959 t
= gfc_check_constructor (e
, check_restricted
);
2963 gfc_internal_error ("check_restricted(): Unknown expression type");
2970 /* Check to see that an expression is a specification expression. If
2971 we return false, an error has been generated. */
2974 gfc_specification_expr (gfc_expr
*e
)
2976 gfc_component
*comp
;
2981 if (e
->ts
.type
!= BT_INTEGER
)
2983 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2984 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2988 comp
= gfc_get_proc_ptr_comp (e
);
2989 if (e
->expr_type
== EXPR_FUNCTION
2990 && !e
->value
.function
.isym
2991 && !e
->value
.function
.esym
2992 && !gfc_pure (e
->symtree
->n
.sym
)
2993 && (!comp
|| !comp
->attr
.pure
))
2995 gfc_error ("Function '%s' at %L must be PURE",
2996 e
->symtree
->n
.sym
->name
, &e
->where
);
2997 /* Prevent repeat error messages. */
2998 e
->symtree
->n
.sym
->attr
.pure
= 1;
3004 gfc_error ("Expression at %L must be scalar", &e
->where
);
3008 if (!gfc_simplify_expr (e
, 0))
3011 return check_restricted (e
);
3015 /************** Expression conformance checks. *************/
3017 /* Given two expressions, make sure that the arrays are conformable. */
3020 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3022 int op1_flag
, op2_flag
, d
;
3023 mpz_t op1_size
, op2_size
;
3029 if (op1
->rank
== 0 || op2
->rank
== 0)
3032 va_start (argp
, optype_msgid
);
3033 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3036 if (op1
->rank
!= op2
->rank
)
3038 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3039 op1
->rank
, op2
->rank
, &op1
->where
);
3045 for (d
= 0; d
< op1
->rank
; d
++)
3047 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3048 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3050 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3052 gfc_error ("Different shape for %s at %L on dimension %d "
3053 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3054 (int) mpz_get_si (op1_size
),
3055 (int) mpz_get_si (op2_size
));
3061 mpz_clear (op1_size
);
3063 mpz_clear (op2_size
);
3073 /* Given an assignable expression and an arbitrary expression, make
3074 sure that the assignment can take place. */
3077 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3083 sym
= lvalue
->symtree
->n
.sym
;
3085 /* See if this is the component or subcomponent of a pointer. */
3086 has_pointer
= sym
->attr
.pointer
;
3087 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3088 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3094 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3095 variable local to a function subprogram. Its existence begins when
3096 execution of the function is initiated and ends when execution of the
3097 function is terminated...
3098 Therefore, the left hand side is no longer a variable, when it is: */
3099 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3100 && !sym
->attr
.external
)
3105 /* (i) Use associated; */
3106 if (sym
->attr
.use_assoc
)
3109 /* (ii) The assignment is in the main program; or */
3110 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3113 /* (iii) A module or internal procedure... */
3114 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3115 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3116 && gfc_current_ns
->parent
3117 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3118 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3119 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3121 /* ... that is not a function... */
3122 if (!gfc_current_ns
->proc_name
->attr
.function
)
3125 /* ... or is not an entry and has a different name. */
3126 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3130 /* (iv) Host associated and not the function symbol or the
3131 parent result. This picks up sibling references, which
3132 cannot be entries. */
3133 if (!sym
->attr
.entry
3134 && sym
->ns
== gfc_current_ns
->parent
3135 && sym
!= gfc_current_ns
->proc_name
3136 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3141 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3146 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3148 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3149 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3153 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3155 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3160 if (rvalue
->expr_type
== EXPR_NULL
)
3162 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3163 && lvalue
->symtree
->n
.sym
->attr
.data
)
3167 gfc_error ("NULL appears on right-hand side in assignment at %L",
3173 /* This is possibly a typo: x = f() instead of x => f(). */
3175 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3176 gfc_warning ("POINTER-valued function appears on right-hand side of "
3177 "assignment at %L", &rvalue
->where
);
3179 /* Check size of array assignments. */
3180 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3181 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3184 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3185 && lvalue
->symtree
->n
.sym
->attr
.data
3186 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3187 "initialize non-integer variable '%s'",
3188 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3190 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3191 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3192 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3196 /* Handle the case of a BOZ literal on the RHS. */
3197 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3200 if (warn_surprising
)
3201 gfc_warning ("BOZ literal at %L is bitwise transferred "
3202 "non-integer symbol '%s'", &rvalue
->where
,
3203 lvalue
->symtree
->n
.sym
->name
);
3204 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3206 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3208 if (rc
== ARITH_UNDERFLOW
)
3209 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3210 ". This check can be disabled with the option "
3211 "-fno-range-check", &rvalue
->where
);
3212 else if (rc
== ARITH_OVERFLOW
)
3213 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3214 ". This check can be disabled with the option "
3215 "-fno-range-check", &rvalue
->where
);
3216 else if (rc
== ARITH_NAN
)
3217 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3218 ". This check can be disabled with the option "
3219 "-fno-range-check", &rvalue
->where
);
3224 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3225 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3226 will warn anyway, so there is no need to to so here. */
3228 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3229 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3231 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& warn_conversion
)
3233 /* As a special bonus, don't warn about REAL rvalues which are not
3234 changed by the conversion if -Wconversion is specified. */
3235 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3237 /* Calculate the difference between the constant and the rounded
3238 value and check it against zero. */
3240 gfc_set_model_kind (lvalue
->ts
.kind
);
3242 gfc_set_model_kind (rvalue
->ts
.kind
);
3245 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3246 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3248 if (!mpfr_zero_p (diff
))
3249 gfc_warning ("Change of value in conversion from "
3250 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3251 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3257 gfc_warning ("Possible change of value in conversion from %s "
3258 "to %s at %L",gfc_typename (&rvalue
->ts
),
3259 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3262 else if (warn_conversion_extra
&& lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3264 gfc_warning ("Conversion from %s to %s at %L",
3265 gfc_typename (&rvalue
->ts
),
3266 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3270 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3273 /* Only DATA Statements come here. */
3276 /* Numeric can be converted to any other numeric. And Hollerith can be
3277 converted to any other type. */
3278 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3279 || rvalue
->ts
.type
== BT_HOLLERITH
)
3282 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3285 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3286 "conversion of %s to %s", &lvalue
->where
,
3287 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3292 /* Assignment is the only case where character variables of different
3293 kind values can be converted into one another. */
3294 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3296 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3297 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3302 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3306 /* Check that a pointer assignment is OK. We first check lvalue, and
3307 we only check rvalue if it's not an assignment to NULL() or a
3308 NULLIFY statement. */
3311 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3313 symbol_attribute attr
, lhs_attr
;
3315 bool is_pure
, is_implicit_pure
, rank_remap
;
3318 lhs_attr
= gfc_expr_attr (lvalue
);
3319 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3321 gfc_error ("Pointer assignment target is not a POINTER at %L",
3326 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3327 && !lhs_attr
.proc_pointer
)
3329 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3330 "l-value since it is a procedure",
3331 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3335 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3338 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3340 if (ref
->type
== REF_COMPONENT
)
3341 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3343 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3347 if (ref
->u
.ar
.type
== AR_FULL
)
3350 if (ref
->u
.ar
.type
!= AR_SECTION
)
3352 gfc_error ("Expected bounds specification for '%s' at %L",
3353 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3357 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3358 "for '%s' in pointer assignment at %L",
3359 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3362 /* When bounds are given, all lbounds are necessary and either all
3363 or none of the upper bounds; no strides are allowed. If the
3364 upper bounds are present, we may do rank remapping. */
3365 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3367 if (!ref
->u
.ar
.start
[dim
]
3368 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3370 gfc_error ("Lower bound has to be present at %L",
3374 if (ref
->u
.ar
.stride
[dim
])
3376 gfc_error ("Stride must not be present at %L",
3382 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3385 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3386 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3388 gfc_error ("Either all or none of the upper bounds"
3389 " must be specified at %L", &lvalue
->where
);
3397 is_pure
= gfc_pure (NULL
);
3398 is_implicit_pure
= gfc_implicit_pure (NULL
);
3400 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3401 kind, etc for lvalue and rvalue must match, and rvalue must be a
3402 pure variable if we're in a pure function. */
3403 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3406 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3407 if (lvalue
->expr_type
== EXPR_VARIABLE
3408 && gfc_is_coindexed (lvalue
))
3411 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3412 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3414 gfc_error ("Pointer object at %L shall not have a coindex",
3420 /* Checks on rvalue for procedure pointer assignments. */
3425 gfc_component
*comp
;
3428 attr
= gfc_expr_attr (rvalue
);
3429 if (!((rvalue
->expr_type
== EXPR_NULL
)
3430 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3431 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3432 || (rvalue
->expr_type
== EXPR_VARIABLE
3433 && attr
.flavor
== FL_PROCEDURE
)))
3435 gfc_error ("Invalid procedure pointer assignment at %L",
3439 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3441 /* Check for intrinsics. */
3442 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3443 if (!sym
->attr
.intrinsic
3444 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3445 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3447 sym
->attr
.intrinsic
= 1;
3448 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3449 attr
= gfc_expr_attr (rvalue
);
3451 /* Check for result of embracing function. */
3452 if (sym
->attr
.function
&& sym
->result
== sym
)
3456 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3457 if (sym
== ns
->proc_name
)
3459 gfc_error ("Function result '%s' is invalid as proc-target "
3460 "in procedure pointer assignment at %L",
3461 sym
->name
, &rvalue
->where
);
3468 gfc_error ("Abstract interface '%s' is invalid "
3469 "in procedure pointer assignment at %L",
3470 rvalue
->symtree
->name
, &rvalue
->where
);
3473 /* Check for F08:C729. */
3474 if (attr
.flavor
== FL_PROCEDURE
)
3476 if (attr
.proc
== PROC_ST_FUNCTION
)
3478 gfc_error ("Statement function '%s' is invalid "
3479 "in procedure pointer assignment at %L",
3480 rvalue
->symtree
->name
, &rvalue
->where
);
3483 if (attr
.proc
== PROC_INTERNAL
&&
3484 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure '%s' "
3485 "is invalid in procedure pointer assignment "
3486 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3488 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3489 attr
.subroutine
) == 0)
3491 gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
3492 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3496 /* Check for F08:C730. */
3497 if (attr
.elemental
&& !attr
.intrinsic
)
3499 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3500 "in procedure pointer assignment at %L",
3501 rvalue
->symtree
->name
, &rvalue
->where
);
3505 /* Ensure that the calling convention is the same. As other attributes
3506 such as DLLEXPORT may differ, one explicitly only tests for the
3507 calling conventions. */
3508 if (rvalue
->expr_type
== EXPR_VARIABLE
3509 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3510 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3512 symbol_attribute calls
;
3515 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3516 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3517 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3519 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3520 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3522 gfc_error ("Mismatch in the procedure pointer assignment "
3523 "at %L: mismatch in the calling convention",
3529 comp
= gfc_get_proc_ptr_comp (lvalue
);
3531 s1
= comp
->ts
.interface
;
3534 s1
= lvalue
->symtree
->n
.sym
;
3535 if (s1
->ts
.interface
)
3536 s1
= s1
->ts
.interface
;
3539 comp
= gfc_get_proc_ptr_comp (rvalue
);
3542 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3544 s2
= comp
->ts
.interface
->result
;
3549 s2
= comp
->ts
.interface
;
3553 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3555 if (rvalue
->value
.function
.esym
)
3556 s2
= rvalue
->value
.function
.esym
->result
;
3558 s2
= rvalue
->symtree
->n
.sym
->result
;
3564 s2
= rvalue
->symtree
->n
.sym
;
3568 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3569 s2
= s2
->ts
.interface
;
3571 if (s1
== s2
|| !s1
|| !s2
)
3574 /* F08:7.2.2.4 (4) */
3575 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
3576 && gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3578 gfc_error ("Explicit interface required for '%s' at %L: %s",
3579 s1
->name
, &lvalue
->where
, err
);
3582 if (s2
->attr
.if_source
== IFSRC_UNKNOWN
3583 && gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3585 gfc_error ("Explicit interface required for '%s' at %L: %s",
3586 s2
->name
, &rvalue
->where
, err
);
3590 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3591 err
, sizeof(err
), NULL
, NULL
))
3593 gfc_error ("Interface mismatch in procedure pointer assignment "
3594 "at %L: %s", &rvalue
->where
, err
);
3598 /* Check F2008Cor2, C729. */
3599 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3600 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3602 gfc_error ("Procedure pointer target '%s' at %L must be either an "
3603 "intrinsic, host or use associated, referenced or have "
3604 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3611 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3613 /* Check for F03:C717. */
3614 if (UNLIMITED_POLY (rvalue
)
3615 && !(UNLIMITED_POLY (lvalue
)
3616 || (lvalue
->ts
.type
== BT_DERIVED
3617 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3618 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3619 gfc_error ("Data-pointer-object &L must be unlimited "
3620 "polymorphic, a sequence derived type or of a "
3621 "type with the BIND attribute assignment at %L "
3622 "to be compatible with an unlimited polymorphic "
3623 "target", &lvalue
->where
);
3625 gfc_error ("Different types in pointer assignment at %L; "
3626 "attempted assignment of %s to %s", &lvalue
->where
,
3627 gfc_typename (&rvalue
->ts
),
3628 gfc_typename (&lvalue
->ts
));
3632 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3634 gfc_error ("Different kind type parameters in pointer "
3635 "assignment at %L", &lvalue
->where
);
3639 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3641 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3645 /* Make sure the vtab is present. */
3646 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3647 gfc_find_vtab (&rvalue
->ts
);
3649 /* Check rank remapping. */
3654 /* If this can be determined, check that the target must be at least as
3655 large as the pointer assigned to it is. */
3656 if (gfc_array_size (lvalue
, &lsize
)
3657 && gfc_array_size (rvalue
, &rsize
)
3658 && mpz_cmp (rsize
, lsize
) < 0)
3660 gfc_error ("Rank remapping target is smaller than size of the"
3661 " pointer (%ld < %ld) at %L",
3662 mpz_get_si (rsize
), mpz_get_si (lsize
),
3667 /* The target must be either rank one or it must be simply contiguous
3668 and F2008 must be allowed. */
3669 if (rvalue
->rank
!= 1)
3671 if (!gfc_is_simply_contiguous (rvalue
, true))
3673 gfc_error ("Rank remapping target must be rank 1 or"
3674 " simply contiguous at %L", &rvalue
->where
);
3677 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3678 "rank 1 at %L", &rvalue
->where
))
3683 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3684 if (rvalue
->expr_type
== EXPR_NULL
)
3687 if (lvalue
->ts
.type
== BT_CHARACTER
)
3689 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3694 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3695 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3697 attr
= gfc_expr_attr (rvalue
);
3699 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3701 gfc_error ("Target expression in pointer assignment "
3702 "at %L must deliver a pointer result",
3707 if (!attr
.target
&& !attr
.pointer
)
3709 gfc_error ("Pointer assignment target is neither TARGET "
3710 "nor POINTER at %L", &rvalue
->where
);
3714 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3716 gfc_error ("Bad target in pointer assignment in PURE "
3717 "procedure at %L", &rvalue
->where
);
3720 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3721 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3723 if (gfc_has_vector_index (rvalue
))
3725 gfc_error ("Pointer assignment with vector subscript "
3726 "on rhs at %L", &rvalue
->where
);
3730 if (attr
.is_protected
&& attr
.use_assoc
3731 && !(attr
.pointer
|| attr
.proc_pointer
))
3733 gfc_error ("Pointer assignment target has PROTECTED "
3734 "attribute at %L", &rvalue
->where
);
3738 /* F2008, C725. For PURE also C1283. */
3739 if (rvalue
->expr_type
== EXPR_VARIABLE
3740 && gfc_is_coindexed (rvalue
))
3743 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3744 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3746 gfc_error ("Data target at %L shall not have a coindex",
3752 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3753 if (warn_target_lifetime
3754 && rvalue
->expr_type
== EXPR_VARIABLE
3755 && !rvalue
->symtree
->n
.sym
->attr
.save
3756 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3757 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3758 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3759 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3764 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3765 || lvalue
->symtree
->n
.sym
->attr
.result
3766 || lvalue
->symtree
->n
.sym
->attr
.function
3767 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3768 && lvalue
->symtree
->n
.sym
->ns
3769 != rvalue
->symtree
->n
.sym
->ns
)
3770 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3771 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3773 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3774 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3775 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3776 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3777 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3779 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3786 gfc_warning ("Pointer at %L in pointer assignment might outlive the "
3787 "pointer target", &lvalue
->where
);
3794 /* Relative of gfc_check_assign() except that the lvalue is a single
3795 symbol. Used for initialization assignments. */
3798 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3802 bool pointer
, proc_pointer
;
3804 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3806 lvalue
.expr_type
= EXPR_VARIABLE
;
3807 lvalue
.ts
= sym
->ts
;
3809 lvalue
.rank
= sym
->as
->rank
;
3810 lvalue
.symtree
= XCNEW (gfc_symtree
);
3811 lvalue
.symtree
->n
.sym
= sym
;
3812 lvalue
.where
= sym
->declared_at
;
3816 lvalue
.ref
= gfc_get_ref ();
3817 lvalue
.ref
->type
= REF_COMPONENT
;
3818 lvalue
.ref
->u
.c
.component
= comp
;
3819 lvalue
.ref
->u
.c
.sym
= sym
;
3820 lvalue
.ts
= comp
->ts
;
3821 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3822 lvalue
.where
= comp
->loc
;
3823 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3824 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3825 proc_pointer
= comp
->attr
.proc_pointer
;
3829 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3830 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3831 proc_pointer
= sym
->attr
.proc_pointer
;
3834 if (pointer
|| proc_pointer
)
3835 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3837 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3839 free (lvalue
.symtree
);
3845 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3847 /* F08:C461. Additional checks for pointer initialization. */
3848 symbol_attribute attr
;
3849 attr
= gfc_expr_attr (rvalue
);
3850 if (attr
.allocatable
)
3852 gfc_error ("Pointer initialization target at %L "
3853 "must not be ALLOCATABLE", &rvalue
->where
);
3856 if (!attr
.target
|| attr
.pointer
)
3858 gfc_error ("Pointer initialization target at %L "
3859 "must have the TARGET attribute", &rvalue
->where
);
3863 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3864 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3865 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3867 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3868 attr
.save
= SAVE_IMPLICIT
;
3873 gfc_error ("Pointer initialization target at %L "
3874 "must have the SAVE attribute", &rvalue
->where
);
3879 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3881 /* F08:C1220. Additional checks for procedure pointer initialization. */
3882 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3883 if (attr
.proc_pointer
)
3885 gfc_error ("Procedure pointer initialization target at %L "
3886 "may not be a procedure pointer", &rvalue
->where
);
3895 /* Check for default initializer; sym->value is not enough
3896 as it is also set for EXPR_NULL of allocatables. */
3899 gfc_has_default_initializer (gfc_symbol
*der
)
3903 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3904 for (c
= der
->components
; c
; c
= c
->next
)
3905 if (c
->ts
.type
== BT_DERIVED
)
3907 if (!c
->attr
.pointer
3908 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3910 if (c
->attr
.pointer
&& c
->initializer
)
3923 /* Get an expression for a default initializer. */
3926 gfc_default_initializer (gfc_typespec
*ts
)
3929 gfc_component
*comp
;
3931 /* See if we have a default initializer in this, but not in nested
3932 types (otherwise we could use gfc_has_default_initializer()). */
3933 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3934 if (comp
->initializer
|| comp
->attr
.allocatable
3935 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3936 && CLASS_DATA (comp
)->attr
.allocatable
))
3942 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3943 &ts
->u
.derived
->declared_at
);
3946 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3948 gfc_constructor
*ctor
= gfc_constructor_get();
3950 if (comp
->initializer
)
3952 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3953 if ((comp
->ts
.type
!= comp
->initializer
->ts
.type
3954 || comp
->ts
.kind
!= comp
->initializer
->ts
.kind
)
3955 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
3956 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
3959 if (comp
->attr
.allocatable
3960 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3962 ctor
->expr
= gfc_get_expr ();
3963 ctor
->expr
->expr_type
= EXPR_NULL
;
3964 ctor
->expr
->ts
= comp
->ts
;
3967 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3974 /* Given a symbol, create an expression node with that symbol as a
3975 variable. If the symbol is array valued, setup a reference of the
3979 gfc_get_variable_expr (gfc_symtree
*var
)
3983 e
= gfc_get_expr ();
3984 e
->expr_type
= EXPR_VARIABLE
;
3986 e
->ts
= var
->n
.sym
->ts
;
3988 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
3989 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
3990 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
3991 && CLASS_DATA (var
->n
.sym
)->as
)))
3993 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
3994 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
3995 e
->ref
= gfc_get_ref ();
3996 e
->ref
->type
= REF_ARRAY
;
3997 e
->ref
->u
.ar
.type
= AR_FULL
;
3998 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
3999 ? CLASS_DATA (var
->n
.sym
)->as
4007 /* Adds a full array reference to an expression, as needed. */
4010 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4013 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4018 ref
->next
= gfc_get_ref ();
4023 e
->ref
= gfc_get_ref ();
4026 ref
->type
= REF_ARRAY
;
4027 ref
->u
.ar
.type
= AR_FULL
;
4028 ref
->u
.ar
.dimen
= e
->rank
;
4029 ref
->u
.ar
.where
= e
->where
;
4035 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4038 lval
= gfc_get_expr ();
4039 lval
->expr_type
= EXPR_VARIABLE
;
4040 lval
->where
= sym
->declared_at
;
4042 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4044 /* It will always be a full array. */
4045 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
4047 gfc_add_full_array_ref (lval
, sym
->ts
.type
== BT_CLASS
?
4048 CLASS_DATA (sym
)->as
: sym
->as
);
4053 /* Returns the array_spec of a full array expression. A NULL is
4054 returned otherwise. */
4056 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4061 if (expr
->rank
== 0)
4064 /* Follow any component references. */
4065 if (expr
->expr_type
== EXPR_VARIABLE
4066 || expr
->expr_type
== EXPR_CONSTANT
)
4068 as
= expr
->symtree
->n
.sym
->as
;
4069 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4074 as
= ref
->u
.c
.component
->as
;
4082 switch (ref
->u
.ar
.type
)
4105 /* General expression traversal function. */
4108 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4109 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4114 gfc_actual_arglist
*args
;
4121 if ((*func
) (expr
, sym
, &f
))
4124 if (expr
->ts
.type
== BT_CHARACTER
4126 && expr
->ts
.u
.cl
->length
4127 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4128 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4131 switch (expr
->expr_type
)
4136 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4138 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4146 case EXPR_SUBSTRING
:
4149 case EXPR_STRUCTURE
:
4151 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4152 c
; c
= gfc_constructor_next (c
))
4154 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4158 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4160 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4162 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4164 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4171 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4173 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4189 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4191 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4193 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4195 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4201 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4203 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4208 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4209 && ref
->u
.c
.component
->ts
.u
.cl
4210 && ref
->u
.c
.component
->ts
.u
.cl
->length
4211 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4213 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4217 if (ref
->u
.c
.component
->as
)
4218 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4219 + ref
->u
.c
.component
->as
->corank
; i
++)
4221 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4224 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4238 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4241 expr_set_symbols_referenced (gfc_expr
*expr
,
4242 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4243 int *f ATTRIBUTE_UNUSED
)
4245 if (expr
->expr_type
!= EXPR_VARIABLE
)
4247 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4252 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4254 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4258 /* Determine if an expression is a procedure pointer component and return
4259 the component in that case. Otherwise return NULL. */
4262 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4266 if (!expr
|| !expr
->ref
)
4273 if (ref
->type
== REF_COMPONENT
4274 && ref
->u
.c
.component
->attr
.proc_pointer
)
4275 return ref
->u
.c
.component
;
4281 /* Determine if an expression is a procedure pointer component. */
4284 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4286 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4290 /* Walk an expression tree and check each variable encountered for being typed.
4291 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4292 mode as is a basic arithmetic expression using those; this is for things in
4295 INTEGER :: arr(n), n
4296 INTEGER :: arr(n + 1), n
4298 The namespace is needed for IMPLICIT typing. */
4300 static gfc_namespace
* check_typed_ns
;
4303 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4304 int* f ATTRIBUTE_UNUSED
)
4308 if (e
->expr_type
!= EXPR_VARIABLE
)
4311 gcc_assert (e
->symtree
);
4312 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4319 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4323 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4327 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4328 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4330 if (e
->expr_type
== EXPR_OP
)
4334 gcc_assert (e
->value
.op
.op1
);
4335 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4337 if (t
&& e
->value
.op
.op2
)
4338 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4344 /* Otherwise, walk the expression and do it strictly. */
4345 check_typed_ns
= ns
;
4346 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4348 return error_found
? false : true;
4353 gfc_ref_this_image (gfc_ref
*ref
)
4357 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4359 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4360 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4368 gfc_is_coindexed (gfc_expr
*e
)
4372 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4373 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4374 return !gfc_ref_this_image (ref
);
4380 /* Coarrays are variables with a corank but not being coindexed. However, also
4381 the following is a coarray: A subobject of a coarray is a coarray if it does
4382 not have any cosubscripts, vector subscripts, allocatable component
4383 selection, or pointer component selection. (F2008, 2.4.7) */
4386 gfc_is_coarray (gfc_expr
*e
)
4390 gfc_component
*comp
;
4395 if (e
->expr_type
!= EXPR_VARIABLE
)
4399 sym
= e
->symtree
->n
.sym
;
4401 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4402 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4404 coarray
= sym
->attr
.codimension
;
4406 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4410 comp
= ref
->u
.c
.component
;
4411 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4412 && (CLASS_DATA (comp
)->attr
.class_pointer
4413 || CLASS_DATA (comp
)->attr
.allocatable
))
4416 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4418 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4421 coarray
= comp
->attr
.codimension
;
4429 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4435 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4436 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4447 return coarray
&& !coindexed
;
4452 gfc_get_corank (gfc_expr
*e
)
4457 if (!gfc_is_coarray (e
))
4460 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4461 corank
= e
->ts
.u
.derived
->components
->as
4462 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4464 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4466 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4468 if (ref
->type
== REF_ARRAY
)
4469 corank
= ref
->u
.ar
.as
->corank
;
4470 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4477 /* Check whether the expression has an ultimate allocatable component.
4478 Being itself allocatable does not count. */
4480 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4482 gfc_ref
*ref
, *last
= NULL
;
4484 if (e
->expr_type
!= EXPR_VARIABLE
)
4487 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4488 if (ref
->type
== REF_COMPONENT
)
4491 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4492 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4493 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4494 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4498 if (e
->ts
.type
== BT_CLASS
)
4499 return CLASS_DATA (e
)->attr
.alloc_comp
;
4500 else if (e
->ts
.type
== BT_DERIVED
)
4501 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4507 /* Check whether the expression has an pointer component.
4508 Being itself a pointer does not count. */
4510 gfc_has_ultimate_pointer (gfc_expr
*e
)
4512 gfc_ref
*ref
, *last
= NULL
;
4514 if (e
->expr_type
!= EXPR_VARIABLE
)
4517 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4518 if (ref
->type
== REF_COMPONENT
)
4521 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4522 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4523 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4524 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4528 if (e
->ts
.type
== BT_CLASS
)
4529 return CLASS_DATA (e
)->attr
.pointer_comp
;
4530 else if (e
->ts
.type
== BT_DERIVED
)
4531 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4537 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4538 Note: A scalar is not regarded as "simply contiguous" by the standard.
4539 if bool is not strict, some further checks are done - for instance,
4540 a "(::1)" is accepted. */
4543 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4547 gfc_array_ref
*ar
= NULL
;
4548 gfc_ref
*ref
, *part_ref
= NULL
;
4551 if (expr
->expr_type
== EXPR_FUNCTION
)
4552 return expr
->value
.function
.esym
4553 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4554 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4557 if (expr
->rank
== 0)
4560 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4563 return false; /* Array shall be last part-ref. */
4565 if (ref
->type
== REF_COMPONENT
)
4567 else if (ref
->type
== REF_SUBSTRING
)
4569 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4573 sym
= expr
->symtree
->n
.sym
;
4574 if (expr
->ts
.type
!= BT_CLASS
4576 && !part_ref
->u
.c
.component
->attr
.contiguous
4577 && part_ref
->u
.c
.component
->attr
.pointer
)
4579 && !sym
->attr
.contiguous
4580 && (sym
->attr
.pointer
4581 || sym
->as
->type
== AS_ASSUMED_RANK
4582 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
4585 if (!ar
|| ar
->type
== AR_FULL
)
4588 gcc_assert (ar
->type
== AR_SECTION
);
4590 /* Check for simply contiguous array */
4592 for (i
= 0; i
< ar
->dimen
; i
++)
4594 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4597 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4603 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4606 /* If the previous section was not contiguous, that's an error,
4607 unless we have effective only one element and checking is not
4609 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4610 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4611 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4612 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4613 ar
->end
[i
]->value
.integer
) != 0))
4616 /* Following the standard, "(::1)" or - if known at compile time -
4617 "(lbound:ubound)" are not simply contiguous; if strict
4618 is false, they are regarded as simply contiguous. */
4619 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4620 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4621 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4625 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4626 || !ar
->as
->lower
[i
]
4627 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4628 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4629 ar
->as
->lower
[i
]->value
.integer
) != 0))
4633 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4634 || !ar
->as
->upper
[i
]
4635 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4636 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4637 ar
->as
->upper
[i
]->value
.integer
) != 0))
4645 /* Build call to an intrinsic procedure. The number of arguments has to be
4646 passed (rather than ending the list with a NULL value) because we may
4647 want to add arguments but with a NULL-expression. */
4650 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
4651 locus where
, unsigned numarg
, ...)
4654 gfc_actual_arglist
* atail
;
4655 gfc_intrinsic_sym
* isym
;
4658 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
4660 isym
= gfc_intrinsic_function_by_id (id
);
4663 result
= gfc_get_expr ();
4664 result
->expr_type
= EXPR_FUNCTION
;
4665 result
->ts
= isym
->ts
;
4666 result
->where
= where
;
4667 result
->value
.function
.name
= mangled_name
;
4668 result
->value
.function
.isym
= isym
;
4670 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
4671 gfc_commit_symbol (result
->symtree
->n
.sym
);
4672 gcc_assert (result
->symtree
4673 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
4674 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
4675 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
4676 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4677 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
4678 result
->symtree
->n
.sym
->attr
.artificial
= 1;
4680 va_start (ap
, numarg
);
4682 for (i
= 0; i
< numarg
; ++i
)
4686 atail
->next
= gfc_get_actual_arglist ();
4687 atail
= atail
->next
;
4690 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4692 atail
->expr
= va_arg (ap
, gfc_expr
*);
4700 /* Check if an expression may appear in a variable definition context
4701 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4702 This is called from the various places when resolving
4703 the pieces that make up such a context.
4704 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
4705 variables), some checks are not performed.
4707 Optionally, a possible error message can be suppressed if context is NULL
4708 and just the return status (true / false) be requested. */
4711 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4712 bool own_scope
, const char* context
)
4714 gfc_symbol
* sym
= NULL
;
4716 bool check_intentin
;
4718 symbol_attribute attr
;
4722 if (e
->expr_type
== EXPR_VARIABLE
)
4724 gcc_assert (e
->symtree
);
4725 sym
= e
->symtree
->n
.sym
;
4727 else if (e
->expr_type
== EXPR_FUNCTION
)
4729 gcc_assert (e
->symtree
);
4730 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4733 attr
= gfc_expr_attr (e
);
4734 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4736 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4739 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4740 " context (%s) at %L", context
, &e
->where
);
4744 else if (e
->expr_type
!= EXPR_VARIABLE
)
4747 gfc_error ("Non-variable expression in variable definition context (%s)"
4748 " at %L", context
, &e
->where
);
4752 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4755 gfc_error ("Named constant '%s' in variable definition context (%s)"
4756 " at %L", sym
->name
, context
, &e
->where
);
4759 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4760 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4761 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4764 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4765 " a variable", sym
->name
, context
, &e
->where
);
4769 /* Find out whether the expr is a pointer; this also means following
4770 component references to the last one. */
4771 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4772 if (pointer
&& !is_pointer
)
4775 gfc_error ("Non-POINTER in pointer association context (%s)"
4776 " at %L", context
, &e
->where
);
4783 || (e
->ts
.type
== BT_DERIVED
4784 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4785 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4788 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4789 context
, &e
->where
);
4793 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
4794 component of sub-component of a pointer; we need to distinguish
4795 assignment to a pointer component from pointer-assignment to a pointer
4796 component. Note that (normal) assignment to procedure pointers is not
4798 check_intentin
= !own_scope
;
4799 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4800 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4801 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4803 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4804 check_intentin
= false;
4805 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4807 ptr_component
= true;
4809 check_intentin
= false;
4812 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4814 if (pointer
&& is_pointer
)
4817 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4818 " association context (%s) at %L",
4819 sym
->name
, context
, &e
->where
);
4822 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
4825 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4826 " definition context (%s) at %L",
4827 sym
->name
, context
, &e
->where
);
4832 /* PROTECTED and use-associated. */
4833 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4835 if (pointer
&& is_pointer
)
4838 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4839 " pointer association context (%s) at %L",
4840 sym
->name
, context
, &e
->where
);
4843 if (!pointer
&& !is_pointer
)
4846 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4847 " variable definition context (%s) at %L",
4848 sym
->name
, context
, &e
->where
);
4853 /* Variable not assignable from a PURE procedure but appears in
4854 variable definition context. */
4855 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4858 gfc_error ("Variable '%s' can not appear in a variable definition"
4859 " context (%s) at %L in PURE procedure",
4860 sym
->name
, context
, &e
->where
);
4864 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
4865 && gfc_impure_variable (sym
))
4870 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4872 sym
= ns
->proc_name
;
4875 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4877 sym
->attr
.implicit_pure
= 0;
4882 /* Check variable definition context for associate-names. */
4883 if (!pointer
&& sym
->assoc
)
4886 gfc_association_list
* assoc
;
4888 gcc_assert (sym
->assoc
->target
);
4890 /* If this is a SELECT TYPE temporary (the association is used internally
4891 for SELECT TYPE), silently go over to the target. */
4892 if (sym
->attr
.select_type_temporary
)
4894 gfc_expr
* t
= sym
->assoc
->target
;
4896 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4897 name
= t
->symtree
->name
;
4899 if (t
->symtree
->n
.sym
->assoc
)
4900 assoc
= t
->symtree
->n
.sym
->assoc
;
4909 gcc_assert (name
&& assoc
);
4911 /* Is association to a valid variable? */
4912 if (!assoc
->variable
)
4916 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4917 gfc_error ("'%s' at %L associated to vector-indexed target can"
4918 " not be used in a variable definition context (%s)",
4919 name
, &e
->where
, context
);
4921 gfc_error ("'%s' at %L associated to expression can"
4922 " not be used in a variable definition context (%s)",
4923 name
, &e
->where
, context
);
4928 /* Target must be allowed to appear in a variable definition context. */
4929 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
4932 gfc_error ("Associate-name '%s' can not appear in a variable"
4933 " definition context (%s) at %L because its target"
4934 " at %L can not, either",
4935 name
, context
, &e
->where
,
4936 &assoc
->target
->where
);
4941 /* Check for same value in vector expression subscript. */
4944 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
4945 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4946 for (i
= 0; i
< GFC_MAX_DIMENSIONS
4947 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
4948 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4950 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
4951 if (arr
->expr_type
== EXPR_ARRAY
)
4953 gfc_constructor
*c
, *n
;
4956 for (c
= gfc_constructor_first (arr
->value
.constructor
);
4957 c
!= NULL
; c
= gfc_constructor_next (c
))
4959 if (c
== NULL
|| c
->iterator
!= NULL
)
4964 for (n
= gfc_constructor_next (c
); n
!= NULL
;
4965 n
= gfc_constructor_next (n
))
4967 if (n
->iterator
!= NULL
)
4971 if (gfc_dep_compare_expr (ec
, en
) == 0)
4974 gfc_error_now_1 ("Elements with the same value "
4975 "at %L and %L in vector "
4976 "subscript in a variable "
4977 "definition context (%s)",
4978 &(ec
->where
), &(en
->where
),