1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2013 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"
27 #include "target-memory.h" /* for gfc_convert_boz */
28 #include "constructor.h"
31 /* The following set of functions provide access to gfc_expr* of
32 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
34 There are two functions available elsewhere that provide
35 slightly different flavours of variables. Namely:
36 expr.c (gfc_get_variable_expr)
37 symbol.c (gfc_lval_expr_from_sym)
38 TODO: Merge these functions, if possible. */
40 /* Get a new expression node. */
48 gfc_clear_ts (&e
->ts
);
56 /* Get a new expression node that is an array constructor
57 of given type and kind. */
60 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
65 e
->expr_type
= EXPR_ARRAY
;
66 e
->value
.constructor
= NULL
;
79 /* Get a new expression node that is the NULL expression. */
82 gfc_get_null_expr (locus
*where
)
87 e
->expr_type
= EXPR_NULL
;
88 e
->ts
.type
= BT_UNKNOWN
;
97 /* Get a new expression node that is an operator expression node. */
100 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
101 gfc_expr
*op1
, gfc_expr
*op2
)
106 e
->expr_type
= EXPR_OP
;
108 e
->value
.op
.op1
= op1
;
109 e
->value
.op
.op2
= op2
;
118 /* Get a new expression node that is an structure constructor
119 of given type and kind. */
122 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
127 e
->expr_type
= EXPR_STRUCTURE
;
128 e
->value
.constructor
= NULL
;
139 /* Get a new expression node that is an constant of given type and kind. */
142 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
147 gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
151 e
->expr_type
= EXPR_CONSTANT
;
159 mpz_init (e
->value
.integer
);
163 gfc_set_model_kind (kind
);
164 mpfr_init (e
->value
.real
);
168 gfc_set_model_kind (kind
);
169 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
180 /* Get a new expression node that is an string constant.
181 If no string is passed, a string of len is allocated,
182 blanked and null-terminated. */
185 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, int len
)
192 dest
= gfc_get_wide_string (len
+ 1);
193 gfc_wide_memset (dest
, ' ', len
);
197 dest
= gfc_char_to_widechar (src
);
199 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
200 where
? where
: &gfc_current_locus
);
201 e
->value
.character
.string
= dest
;
202 e
->value
.character
.length
= len
;
208 /* Get a new expression node that is an integer constant. */
211 gfc_get_int_expr (int kind
, locus
*where
, int value
)
214 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
215 where
? where
: &gfc_current_locus
);
217 mpz_set_si (p
->value
.integer
, value
);
223 /* Get a new expression node that is a logical constant. */
226 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
229 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
230 where
? where
: &gfc_current_locus
);
232 p
->value
.logical
= value
;
239 gfc_get_iokind_expr (locus
*where
, io_kind k
)
243 /* Set the types to something compatible with iokind. This is needed to
244 get through gfc_free_expr later since iokind really has no Basic Type,
248 e
->expr_type
= EXPR_CONSTANT
;
249 e
->ts
.type
= BT_LOGICAL
;
257 /* Given an expression pointer, return a copy of the expression. This
258 subroutine is recursive. */
261 gfc_copy_expr (gfc_expr
*p
)
273 switch (q
->expr_type
)
276 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
277 q
->value
.character
.string
= s
;
278 memcpy (s
, p
->value
.character
.string
,
279 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
283 /* Copy target representation, if it exists. */
284 if (p
->representation
.string
)
286 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
287 q
->representation
.string
= c
;
288 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
291 /* Copy the values of any pointer components of p->value. */
295 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
299 gfc_set_model_kind (q
->ts
.kind
);
300 mpfr_init (q
->value
.real
);
301 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
305 gfc_set_model_kind (q
->ts
.kind
);
306 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
307 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
311 if (p
->representation
.string
)
312 q
->value
.character
.string
313 = gfc_char_to_widechar (q
->representation
.string
);
316 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
317 q
->value
.character
.string
= s
;
319 /* This is the case for the C_NULL_CHAR named constant. */
320 if (p
->value
.character
.length
== 0
321 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
324 /* Need to set the length to 1 to make sure the NUL
325 terminator is copied. */
326 q
->value
.character
.length
= 1;
329 memcpy (s
, p
->value
.character
.string
,
330 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
339 break; /* Already done. */
343 /* Should never be reached. */
345 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
352 switch (q
->value
.op
.op
)
355 case INTRINSIC_PARENTHESES
:
356 case INTRINSIC_UPLUS
:
357 case INTRINSIC_UMINUS
:
358 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
361 default: /* Binary operators. */
362 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
363 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
370 q
->value
.function
.actual
=
371 gfc_copy_actual_arglist (p
->value
.function
.actual
);
376 q
->value
.compcall
.actual
=
377 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
378 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
383 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
391 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
393 q
->ref
= gfc_copy_ref (p
->ref
);
400 gfc_clear_shape (mpz_t
*shape
, int rank
)
404 for (i
= 0; i
< rank
; i
++)
405 mpz_clear (shape
[i
]);
410 gfc_free_shape (mpz_t
**shape
, int rank
)
415 gfc_clear_shape (*shape
, rank
);
421 /* Workhorse function for gfc_free_expr() that frees everything
422 beneath an expression node, but not the node itself. This is
423 useful when we want to simplify a node and replace it with
424 something else or the expression node belongs to another structure. */
427 free_expr0 (gfc_expr
*e
)
429 switch (e
->expr_type
)
432 /* Free any parts of the value that need freeing. */
436 mpz_clear (e
->value
.integer
);
440 mpfr_clear (e
->value
.real
);
444 free (e
->value
.character
.string
);
448 mpc_clear (e
->value
.complex);
455 /* Free the representation. */
456 free (e
->representation
.string
);
461 if (e
->value
.op
.op1
!= NULL
)
462 gfc_free_expr (e
->value
.op
.op1
);
463 if (e
->value
.op
.op2
!= NULL
)
464 gfc_free_expr (e
->value
.op
.op2
);
468 gfc_free_actual_arglist (e
->value
.function
.actual
);
473 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
481 gfc_constructor_free (e
->value
.constructor
);
485 free (e
->value
.character
.string
);
492 gfc_internal_error ("free_expr0(): Bad expr type");
495 /* Free a shape array. */
496 gfc_free_shape (&e
->shape
, e
->rank
);
498 gfc_free_ref_list (e
->ref
);
500 memset (e
, '\0', sizeof (gfc_expr
));
504 /* Free an expression node and everything beneath it. */
507 gfc_free_expr (gfc_expr
*e
)
516 /* Free an argument list and everything below it. */
519 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
521 gfc_actual_arglist
*a2
;
526 gfc_free_expr (a1
->expr
);
533 /* Copy an arglist structure and all of the arguments. */
536 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
538 gfc_actual_arglist
*head
, *tail
, *new_arg
;
542 for (; p
; p
= p
->next
)
544 new_arg
= gfc_get_actual_arglist ();
547 new_arg
->expr
= gfc_copy_expr (p
->expr
);
548 new_arg
->next
= NULL
;
553 tail
->next
= new_arg
;
562 /* Free a list of reference structures. */
565 gfc_free_ref_list (gfc_ref
*p
)
577 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
579 gfc_free_expr (p
->u
.ar
.start
[i
]);
580 gfc_free_expr (p
->u
.ar
.end
[i
]);
581 gfc_free_expr (p
->u
.ar
.stride
[i
]);
587 gfc_free_expr (p
->u
.ss
.start
);
588 gfc_free_expr (p
->u
.ss
.end
);
600 /* Graft the *src expression onto the *dest subexpression. */
603 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
611 /* Try to extract an integer constant from the passed expression node.
612 Returns an error message or NULL if the result is set. It is
613 tempting to generate an error and return SUCCESS or FAILURE, but
614 failure is OK for some callers. */
617 gfc_extract_int (gfc_expr
*expr
, int *result
)
619 if (expr
->expr_type
!= EXPR_CONSTANT
)
620 return _("Constant expression required at %C");
622 if (expr
->ts
.type
!= BT_INTEGER
)
623 return _("Integer expression required at %C");
625 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
626 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
628 return _("Integer value too large in expression at %C");
631 *result
= (int) mpz_get_si (expr
->value
.integer
);
637 /* Recursively copy a list of reference structures. */
640 gfc_copy_ref (gfc_ref
*src
)
648 dest
= gfc_get_ref ();
649 dest
->type
= src
->type
;
654 ar
= gfc_copy_array_ref (&src
->u
.ar
);
660 dest
->u
.c
= src
->u
.c
;
664 dest
->u
.ss
= src
->u
.ss
;
665 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
666 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
670 dest
->next
= gfc_copy_ref (src
->next
);
676 /* Detect whether an expression has any vector index array references. */
679 gfc_has_vector_index (gfc_expr
*e
)
683 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
684 if (ref
->type
== REF_ARRAY
)
685 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
686 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
692 /* Copy a shape array. */
695 gfc_copy_shape (mpz_t
*shape
, int rank
)
703 new_shape
= gfc_get_shape (rank
);
705 for (n
= 0; n
< rank
; n
++)
706 mpz_init_set (new_shape
[n
], shape
[n
]);
712 /* Copy a shape array excluding dimension N, where N is an integer
713 constant expression. Dimensions are numbered in Fortran style --
716 So, if the original shape array contains R elements
717 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
718 the result contains R-1 elements:
719 { s1 ... sN-1 sN+1 ... sR-1}
721 If anything goes wrong -- N is not a constant, its value is out
722 of range -- or anything else, just returns NULL. */
725 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
727 mpz_t
*new_shape
, *s
;
733 || dim
->expr_type
!= EXPR_CONSTANT
734 || dim
->ts
.type
!= BT_INTEGER
)
737 n
= mpz_get_si (dim
->value
.integer
);
738 n
--; /* Convert to zero based index. */
739 if (n
< 0 || n
>= rank
)
742 s
= new_shape
= gfc_get_shape (rank
- 1);
744 for (i
= 0; i
< rank
; i
++)
748 mpz_init_set (*s
, shape
[i
]);
756 /* Return the maximum kind of two expressions. In general, higher
757 kind numbers mean more precision for numeric types. */
760 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
762 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
766 /* Returns nonzero if the type is numeric, zero otherwise. */
769 numeric_type (bt type
)
771 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
775 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
778 gfc_numeric_ts (gfc_typespec
*ts
)
780 return numeric_type (ts
->type
);
784 /* Return an expression node with an optional argument list attached.
785 A variable number of gfc_expr pointers are strung together in an
786 argument list with a NULL pointer terminating the list. */
789 gfc_build_conversion (gfc_expr
*e
)
794 p
->expr_type
= EXPR_FUNCTION
;
796 p
->value
.function
.actual
= NULL
;
798 p
->value
.function
.actual
= gfc_get_actual_arglist ();
799 p
->value
.function
.actual
->expr
= e
;
805 /* Given an expression node with some sort of numeric binary
806 expression, insert type conversions required to make the operands
807 have the same type. Conversion warnings are disabled if wconversion
810 The exception is that the operands of an exponential don't have to
811 have the same type. If possible, the base is promoted to the type
812 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
813 1.0**2 stays as it is. */
816 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
820 op1
= e
->value
.op
.op1
;
821 op2
= e
->value
.op
.op2
;
823 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
825 gfc_clear_ts (&e
->ts
);
829 /* Kind conversions of same type. */
830 if (op1
->ts
.type
== op2
->ts
.type
)
832 if (op1
->ts
.kind
== op2
->ts
.kind
)
834 /* No type conversions. */
839 if (op1
->ts
.kind
> op2
->ts
.kind
)
840 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
842 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
848 /* Integer combined with real or complex. */
849 if (op2
->ts
.type
== BT_INTEGER
)
853 /* Special case for ** operator. */
854 if (e
->value
.op
.op
== INTRINSIC_POWER
)
857 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
861 if (op1
->ts
.type
== BT_INTEGER
)
864 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
868 /* Real combined with complex. */
869 e
->ts
.type
= BT_COMPLEX
;
870 if (op1
->ts
.kind
> op2
->ts
.kind
)
871 e
->ts
.kind
= op1
->ts
.kind
;
873 e
->ts
.kind
= op2
->ts
.kind
;
874 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
875 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
876 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
877 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
884 /* Function to determine if an expression is constant or not. This
885 function expects that the expression has already been simplified. */
888 gfc_is_constant_expr (gfc_expr
*e
)
891 gfc_actual_arglist
*arg
;
897 switch (e
->expr_type
)
900 return (gfc_is_constant_expr (e
->value
.op
.op1
)
901 && (e
->value
.op
.op2
== NULL
902 || gfc_is_constant_expr (e
->value
.op
.op2
)));
910 gcc_assert (e
->symtree
|| e
->value
.function
.esym
911 || e
->value
.function
.isym
);
913 /* Call to intrinsic with at least one argument. */
914 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
916 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
917 if (!gfc_is_constant_expr (arg
->expr
))
921 /* Specification functions are constant. */
922 /* F95, 7.1.6.2; F2003, 7.1.7 */
925 sym
= e
->symtree
->n
.sym
;
926 if (e
->value
.function
.esym
)
927 sym
= e
->value
.function
.esym
;
930 && sym
->attr
.function
932 && !sym
->attr
.intrinsic
933 && !sym
->attr
.recursive
934 && sym
->attr
.proc
!= PROC_INTERNAL
935 && sym
->attr
.proc
!= PROC_ST_FUNCTION
936 && sym
->attr
.proc
!= PROC_UNKNOWN
937 && gfc_sym_get_dummy_args (sym
) == NULL
)
940 if (e
->value
.function
.isym
941 && (e
->value
.function
.isym
->elemental
942 || e
->value
.function
.isym
->pure
943 || e
->value
.function
.isym
->inquiry
944 || e
->value
.function
.isym
->transformational
))
954 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
955 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
959 c
= gfc_constructor_first (e
->value
.constructor
);
960 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
961 return gfc_constant_ac (e
);
963 for (; c
; c
= gfc_constructor_next (c
))
964 if (!gfc_is_constant_expr (c
->expr
))
971 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
977 /* Is true if an array reference is followed by a component or substring
980 is_subref_array (gfc_expr
* e
)
985 if (e
->expr_type
!= EXPR_VARIABLE
)
988 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
992 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
994 if (ref
->type
== REF_ARRAY
995 && ref
->u
.ar
.type
!= AR_ELEMENT
)
999 && ref
->type
!= REF_ARRAY
)
1006 /* Try to collapse intrinsic expressions. */
1009 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1011 gfc_intrinsic_op op
;
1012 gfc_expr
*op1
, *op2
, *result
;
1014 if (p
->value
.op
.op
== INTRINSIC_USER
)
1017 op1
= p
->value
.op
.op1
;
1018 op2
= p
->value
.op
.op2
;
1019 op
= p
->value
.op
.op
;
1021 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1023 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1026 if (!gfc_is_constant_expr (op1
)
1027 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1031 p
->value
.op
.op1
= NULL
;
1032 p
->value
.op
.op2
= NULL
;
1036 case INTRINSIC_PARENTHESES
:
1037 result
= gfc_parentheses (op1
);
1040 case INTRINSIC_UPLUS
:
1041 result
= gfc_uplus (op1
);
1044 case INTRINSIC_UMINUS
:
1045 result
= gfc_uminus (op1
);
1048 case INTRINSIC_PLUS
:
1049 result
= gfc_add (op1
, op2
);
1052 case INTRINSIC_MINUS
:
1053 result
= gfc_subtract (op1
, op2
);
1056 case INTRINSIC_TIMES
:
1057 result
= gfc_multiply (op1
, op2
);
1060 case INTRINSIC_DIVIDE
:
1061 result
= gfc_divide (op1
, op2
);
1064 case INTRINSIC_POWER
:
1065 result
= gfc_power (op1
, op2
);
1068 case INTRINSIC_CONCAT
:
1069 result
= gfc_concat (op1
, op2
);
1073 case INTRINSIC_EQ_OS
:
1074 result
= gfc_eq (op1
, op2
, op
);
1078 case INTRINSIC_NE_OS
:
1079 result
= gfc_ne (op1
, op2
, op
);
1083 case INTRINSIC_GT_OS
:
1084 result
= gfc_gt (op1
, op2
, op
);
1088 case INTRINSIC_GE_OS
:
1089 result
= gfc_ge (op1
, op2
, op
);
1093 case INTRINSIC_LT_OS
:
1094 result
= gfc_lt (op1
, op2
, op
);
1098 case INTRINSIC_LE_OS
:
1099 result
= gfc_le (op1
, op2
, op
);
1103 result
= gfc_not (op1
);
1107 result
= gfc_and (op1
, op2
);
1111 result
= gfc_or (op1
, op2
);
1115 result
= gfc_eqv (op1
, op2
);
1118 case INTRINSIC_NEQV
:
1119 result
= gfc_neqv (op1
, op2
);
1123 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1128 gfc_free_expr (op1
);
1129 gfc_free_expr (op2
);
1133 result
->rank
= p
->rank
;
1134 result
->where
= p
->where
;
1135 gfc_replace_expr (p
, result
);
1141 /* Subroutine to simplify constructor expressions. Mutually recursive
1142 with gfc_simplify_expr(). */
1145 simplify_constructor (gfc_constructor_base base
, int type
)
1150 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1153 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1154 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1155 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1160 /* Try and simplify a copy. Replace the original if successful
1161 but keep going through the constructor at all costs. Not
1162 doing so can make a dog's dinner of complicated things. */
1163 p
= gfc_copy_expr (c
->expr
);
1165 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1171 gfc_replace_expr (c
->expr
, p
);
1179 /* Pull a single array element out of an array constructor. */
1182 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1183 gfc_constructor
**rval
)
1185 unsigned long nelemen
;
1191 gfc_constructor
*cons
;
1198 mpz_init_set_ui (offset
, 0);
1201 mpz_init_set_ui (span
, 1);
1202 for (i
= 0; i
< ar
->dimen
; i
++)
1204 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1205 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1212 e
= gfc_copy_expr (ar
->start
[i
]);
1213 if (e
->expr_type
!= EXPR_CONSTANT
)
1219 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1220 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1222 /* Check the bounds. */
1223 if ((ar
->as
->upper
[i
]
1224 && mpz_cmp (e
->value
.integer
,
1225 ar
->as
->upper
[i
]->value
.integer
) > 0)
1226 || (mpz_cmp (e
->value
.integer
,
1227 ar
->as
->lower
[i
]->value
.integer
) < 0))
1229 gfc_error ("Index in dimension %d is out of bounds "
1230 "at %L", i
+ 1, &ar
->c_where
[i
]);
1236 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1237 mpz_mul (delta
, delta
, span
);
1238 mpz_add (offset
, offset
, delta
);
1240 mpz_set_ui (tmp
, 1);
1241 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1242 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1243 mpz_mul (span
, span
, tmp
);
1246 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1247 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1268 /* Find a component of a structure constructor. */
1270 static gfc_constructor
*
1271 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1273 gfc_component
*comp
;
1274 gfc_component
*pick
;
1275 gfc_constructor
*c
= gfc_constructor_first (base
);
1277 comp
= ref
->u
.c
.sym
->components
;
1278 pick
= ref
->u
.c
.component
;
1279 while (comp
!= pick
)
1282 c
= gfc_constructor_next (c
);
1289 /* Replace an expression with the contents of a constructor, removing
1290 the subobject reference in the process. */
1293 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1303 e
= gfc_copy_expr (p
);
1304 e
->ref
= p
->ref
->next
;
1305 p
->ref
->next
= NULL
;
1306 gfc_replace_expr (p
, e
);
1310 /* Pull an array section out of an array constructor. */
1313 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1320 long unsigned one
= 1;
1322 mpz_t start
[GFC_MAX_DIMENSIONS
];
1323 mpz_t end
[GFC_MAX_DIMENSIONS
];
1324 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1325 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1326 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1331 gfc_constructor_base base
;
1332 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1342 base
= expr
->value
.constructor
;
1343 expr
->value
.constructor
= NULL
;
1345 rank
= ref
->u
.ar
.as
->rank
;
1347 if (expr
->shape
== NULL
)
1348 expr
->shape
= gfc_get_shape (rank
);
1350 mpz_init_set_ui (delta_mpz
, one
);
1351 mpz_init_set_ui (nelts
, one
);
1354 /* Do the initialization now, so that we can cleanup without
1355 keeping track of where we were. */
1356 for (d
= 0; d
< rank
; d
++)
1358 mpz_init (delta
[d
]);
1359 mpz_init (start
[d
]);
1362 mpz_init (stride
[d
]);
1366 /* Build the counters to clock through the array reference. */
1368 for (d
= 0; d
< rank
; d
++)
1370 /* Make this stretch of code easier on the eye! */
1371 begin
= ref
->u
.ar
.start
[d
];
1372 finish
= ref
->u
.ar
.end
[d
];
1373 step
= ref
->u
.ar
.stride
[d
];
1374 lower
= ref
->u
.ar
.as
->lower
[d
];
1375 upper
= ref
->u
.ar
.as
->upper
[d
];
1377 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1379 gfc_constructor
*ci
;
1382 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1388 gcc_assert (begin
->rank
== 1);
1389 /* Zero-sized arrays have no shape and no elements, stop early. */
1392 mpz_init_set_ui (nelts
, 0);
1396 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1397 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1398 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1399 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1402 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1404 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1405 || mpz_cmp (ci
->expr
->value
.integer
,
1406 lower
->value
.integer
) < 0)
1408 gfc_error ("index in dimension %d is out of bounds "
1409 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1417 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1418 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1419 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1425 /* Obtain the stride. */
1427 mpz_set (stride
[d
], step
->value
.integer
);
1429 mpz_set_ui (stride
[d
], one
);
1431 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1432 mpz_set_ui (stride
[d
], one
);
1434 /* Obtain the start value for the index. */
1436 mpz_set (start
[d
], begin
->value
.integer
);
1438 mpz_set (start
[d
], lower
->value
.integer
);
1440 mpz_set (ctr
[d
], start
[d
]);
1442 /* Obtain the end value for the index. */
1444 mpz_set (end
[d
], finish
->value
.integer
);
1446 mpz_set (end
[d
], upper
->value
.integer
);
1448 /* Separate 'if' because elements sometimes arrive with
1450 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1451 mpz_set (end
[d
], begin
->value
.integer
);
1453 /* Check the bounds. */
1454 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1455 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1456 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1457 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1459 gfc_error ("index in dimension %d is out of bounds "
1460 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1465 /* Calculate the number of elements and the shape. */
1466 mpz_set (tmp_mpz
, stride
[d
]);
1467 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1468 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1469 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1470 mpz_mul (nelts
, nelts
, tmp_mpz
);
1472 /* An element reference reduces the rank of the expression; don't
1473 add anything to the shape array. */
1474 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1475 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1478 /* Calculate the 'stride' (=delta) for conversion of the
1479 counter values into the index along the constructor. */
1480 mpz_set (delta
[d
], delta_mpz
);
1481 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1482 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1483 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1487 cons
= gfc_constructor_first (base
);
1489 /* Now clock through the array reference, calculating the index in
1490 the source constructor and transferring the elements to the new
1492 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1494 mpz_init_set_ui (ptr
, 0);
1497 for (d
= 0; d
< rank
; d
++)
1499 mpz_set (tmp_mpz
, ctr
[d
]);
1500 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1501 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1502 mpz_add (ptr
, ptr
, tmp_mpz
);
1504 if (!incr_ctr
) continue;
1506 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1508 gcc_assert(vecsub
[d
]);
1510 if (!gfc_constructor_next (vecsub
[d
]))
1511 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1514 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1517 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1521 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1523 if (mpz_cmp_ui (stride
[d
], 0) > 0
1524 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1525 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1526 mpz_set (ctr
[d
], start
[d
]);
1532 limit
= mpz_get_ui (ptr
);
1533 if (limit
>= gfc_option
.flag_max_array_constructor
)
1535 gfc_error ("The number of elements in the array constructor "
1536 "at %L requires an increase of the allowed %d "
1537 "upper limit. See -fmax-array-constructor "
1538 "option", &expr
->where
,
1539 gfc_option
.flag_max_array_constructor
);
1543 cons
= gfc_constructor_lookup (base
, limit
);
1545 gfc_constructor_append_expr (&expr
->value
.constructor
,
1546 gfc_copy_expr (cons
->expr
), NULL
);
1553 mpz_clear (delta_mpz
);
1554 mpz_clear (tmp_mpz
);
1556 for (d
= 0; d
< rank
; d
++)
1558 mpz_clear (delta
[d
]);
1559 mpz_clear (start
[d
]);
1562 mpz_clear (stride
[d
]);
1564 gfc_constructor_free (base
);
1568 /* Pull a substring out of an expression. */
1571 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1578 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1579 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1582 *newp
= gfc_copy_expr (p
);
1583 free ((*newp
)->value
.character
.string
);
1585 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1586 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1587 length
= end
- start
+ 1;
1589 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1590 (*newp
)->value
.character
.length
= length
;
1591 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1592 length
* sizeof (gfc_char_t
));
1599 /* Simplify a subobject reference of a constructor. This occurs when
1600 parameter variable values are substituted. */
1603 simplify_const_ref (gfc_expr
*p
)
1605 gfc_constructor
*cons
, *c
;
1611 switch (p
->ref
->type
)
1614 switch (p
->ref
->u
.ar
.type
)
1617 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1618 will generate this. */
1619 if (p
->expr_type
!= EXPR_ARRAY
)
1621 remove_subobject_ref (p
, NULL
);
1624 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1631 remove_subobject_ref (p
, cons
);
1635 if (find_array_section (p
, p
->ref
) == FAILURE
)
1637 p
->ref
->u
.ar
.type
= AR_FULL
;
1642 if (p
->ref
->next
!= NULL
1643 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1645 for (c
= gfc_constructor_first (p
->value
.constructor
);
1646 c
; c
= gfc_constructor_next (c
))
1648 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1649 if (simplify_const_ref (c
->expr
) == FAILURE
)
1653 if (p
->ts
.type
== BT_DERIVED
1655 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1657 /* There may have been component references. */
1658 p
->ts
= c
->expr
->ts
;
1662 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1664 if (p
->ts
.type
== BT_CHARACTER
1665 && last_ref
->type
== REF_SUBSTRING
)
1667 /* If this is a CHARACTER array and we possibly took
1668 a substring out of it, update the type-spec's
1669 character length according to the first element
1670 (as all should have the same length). */
1672 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1674 const gfc_expr
* first
= c
->expr
;
1675 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1676 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1677 string_len
= first
->value
.character
.length
;
1683 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1686 gfc_free_expr (p
->ts
.u
.cl
->length
);
1689 = gfc_get_int_expr (gfc_default_integer_kind
,
1693 gfc_free_ref_list (p
->ref
);
1704 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1705 remove_subobject_ref (p
, cons
);
1709 if (find_substring_ref (p
, &newp
) == FAILURE
)
1712 gfc_replace_expr (p
, newp
);
1713 gfc_free_ref_list (p
->ref
);
1723 /* Simplify a chain of references. */
1726 simplify_ref_chain (gfc_ref
*ref
, int type
)
1730 for (; ref
; ref
= ref
->next
)
1735 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1737 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1739 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1741 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1747 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1749 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1761 /* Try to substitute the value of a parameter variable. */
1764 simplify_parameter_variable (gfc_expr
*p
, int type
)
1769 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1775 /* Do not copy subobject refs for constant. */
1776 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1777 e
->ref
= gfc_copy_ref (p
->ref
);
1778 t
= gfc_simplify_expr (e
, type
);
1780 /* Only use the simplification if it eliminated all subobject references. */
1781 if (t
== SUCCESS
&& !e
->ref
)
1782 gfc_replace_expr (p
, e
);
1789 /* Given an expression, simplify it by collapsing constant
1790 expressions. Most simplification takes place when the expression
1791 tree is being constructed. If an intrinsic function is simplified
1792 at some point, we get called again to collapse the result against
1795 We work by recursively simplifying expression nodes, simplifying
1796 intrinsic functions where possible, which can lead to further
1797 constant collapsing. If an operator has constant operand(s), we
1798 rip the expression apart, and rebuild it, hoping that it becomes
1801 The expression type is defined for:
1802 0 Basic expression parsing
1803 1 Simplifying array constructors -- will substitute
1805 Returns FAILURE on error, SUCCESS otherwise.
1806 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1809 gfc_simplify_expr (gfc_expr
*p
, int type
)
1811 gfc_actual_arglist
*ap
;
1816 switch (p
->expr_type
)
1823 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1824 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1827 if (p
->value
.function
.isym
!= NULL
1828 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1833 case EXPR_SUBSTRING
:
1834 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1837 if (gfc_is_constant_expr (p
))
1843 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1845 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1846 start
--; /* Convert from one-based to zero-based. */
1849 end
= p
->value
.character
.length
;
1850 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1851 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1856 s
= gfc_get_wide_string (end
- start
+ 2);
1857 memcpy (s
, p
->value
.character
.string
+ start
,
1858 (end
- start
) * sizeof (gfc_char_t
));
1859 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1860 free (p
->value
.character
.string
);
1861 p
->value
.character
.string
= s
;
1862 p
->value
.character
.length
= end
- start
;
1863 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1864 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1866 p
->value
.character
.length
);
1867 gfc_free_ref_list (p
->ref
);
1869 p
->expr_type
= EXPR_CONSTANT
;
1874 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1879 /* Only substitute array parameter variables if we are in an
1880 initialization expression, or we want a subsection. */
1881 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1882 && (gfc_init_expr_flag
|| p
->ref
1883 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1885 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1892 gfc_simplify_iterator_var (p
);
1895 /* Simplify subcomponent references. */
1896 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1901 case EXPR_STRUCTURE
:
1903 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1906 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1909 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1910 && p
->ref
->u
.ar
.type
== AR_FULL
)
1911 gfc_expand_constructor (p
, false);
1913 if (simplify_const_ref (p
) == FAILURE
)
1928 /* Returns the type of an expression with the exception that iterator
1929 variables are automatically integers no matter what else they may
1935 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1942 /* Scalarize an expression for an elemental intrinsic call. */
1945 scalarize_intrinsic_call (gfc_expr
*e
)
1947 gfc_actual_arglist
*a
, *b
;
1948 gfc_constructor_base ctor
;
1949 gfc_constructor
*args
[5];
1950 gfc_constructor
*ci
, *new_ctor
;
1951 gfc_expr
*expr
, *old
;
1952 int n
, i
, rank
[5], array_arg
;
1954 /* Find which, if any, arguments are arrays. Assume that the old
1955 expression carries the type information and that the first arg
1956 that is an array expression carries all the shape information.*/
1958 a
= e
->value
.function
.actual
;
1959 for (; a
; a
= a
->next
)
1962 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1965 expr
= gfc_copy_expr (a
->expr
);
1972 old
= gfc_copy_expr (e
);
1974 gfc_constructor_free (expr
->value
.constructor
);
1975 expr
->value
.constructor
= NULL
;
1977 expr
->where
= old
->where
;
1978 expr
->expr_type
= EXPR_ARRAY
;
1980 /* Copy the array argument constructors into an array, with nulls
1983 a
= old
->value
.function
.actual
;
1984 for (; a
; a
= a
->next
)
1986 /* Check that this is OK for an initialization expression. */
1987 if (a
->expr
&& gfc_check_init_expr (a
->expr
) == FAILURE
)
1991 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1993 rank
[n
] = a
->expr
->rank
;
1994 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1995 args
[n
] = gfc_constructor_first (ctor
);
1997 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2000 rank
[n
] = a
->expr
->rank
;
2003 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2004 args
[n
] = gfc_constructor_first (ctor
);
2013 /* Using the array argument as the master, step through the array
2014 calling the function for each element and advancing the array
2015 constructors together. */
2016 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2018 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2019 gfc_copy_expr (old
), NULL
);
2021 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2023 b
= old
->value
.function
.actual
;
2024 for (i
= 0; i
< n
; i
++)
2027 new_ctor
->expr
->value
.function
.actual
2028 = a
= gfc_get_actual_arglist ();
2031 a
->next
= gfc_get_actual_arglist ();
2036 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2038 a
->expr
= gfc_copy_expr (b
->expr
);
2043 /* Simplify the function calls. If the simplification fails, the
2044 error will be flagged up down-stream or the library will deal
2046 gfc_simplify_expr (new_ctor
->expr
, 0);
2048 for (i
= 0; i
< n
; i
++)
2050 args
[i
] = gfc_constructor_next (args
[i
]);
2052 for (i
= 1; i
< n
; i
++)
2053 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2054 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2060 /* Free "expr" but not the pointers it contains. */
2062 gfc_free_expr (old
);
2066 gfc_error_now ("elemental function arguments at %C are not compliant");
2069 gfc_free_expr (expr
);
2070 gfc_free_expr (old
);
2076 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2078 gfc_expr
*op1
= e
->value
.op
.op1
;
2079 gfc_expr
*op2
= e
->value
.op
.op2
;
2081 if ((*check_function
) (op1
) == FAILURE
)
2084 switch (e
->value
.op
.op
)
2086 case INTRINSIC_UPLUS
:
2087 case INTRINSIC_UMINUS
:
2088 if (!numeric_type (et0 (op1
)))
2093 case INTRINSIC_EQ_OS
:
2095 case INTRINSIC_NE_OS
:
2097 case INTRINSIC_GT_OS
:
2099 case INTRINSIC_GE_OS
:
2101 case INTRINSIC_LT_OS
:
2103 case INTRINSIC_LE_OS
:
2104 if ((*check_function
) (op2
) == FAILURE
)
2107 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2108 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2110 gfc_error ("Numeric or CHARACTER operands are required in "
2111 "expression at %L", &e
->where
);
2116 case INTRINSIC_PLUS
:
2117 case INTRINSIC_MINUS
:
2118 case INTRINSIC_TIMES
:
2119 case INTRINSIC_DIVIDE
:
2120 case INTRINSIC_POWER
:
2121 if ((*check_function
) (op2
) == FAILURE
)
2124 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2129 case INTRINSIC_CONCAT
:
2130 if ((*check_function
) (op2
) == FAILURE
)
2133 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2135 gfc_error ("Concatenation operator in expression at %L "
2136 "must have two CHARACTER operands", &op1
->where
);
2140 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2142 gfc_error ("Concat operator at %L must concatenate strings of the "
2143 "same kind", &e
->where
);
2150 if (et0 (op1
) != BT_LOGICAL
)
2152 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2153 "operand", &op1
->where
);
2162 case INTRINSIC_NEQV
:
2163 if ((*check_function
) (op2
) == FAILURE
)
2166 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2168 gfc_error ("LOGICAL operands are required in expression at %L",
2175 case INTRINSIC_PARENTHESES
:
2179 gfc_error ("Only intrinsic operators can be used in expression at %L",
2187 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2192 /* F2003, 7.1.7 (3): In init expression, allocatable components
2193 must not be data-initialized. */
2195 check_alloc_comp_init (gfc_expr
*e
)
2197 gfc_component
*comp
;
2198 gfc_constructor
*ctor
;
2200 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2201 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2203 for (comp
= e
->ts
.u
.derived
->components
,
2204 ctor
= gfc_constructor_first (e
->value
.constructor
);
2205 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2207 if (comp
->attr
.allocatable
2208 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2210 gfc_error("Invalid initialization expression for ALLOCATABLE "
2211 "component '%s' in structure constructor at %L",
2212 comp
->name
, &ctor
->expr
->where
);
2221 check_init_expr_arguments (gfc_expr
*e
)
2223 gfc_actual_arglist
*ap
;
2225 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2226 if (gfc_check_init_expr (ap
->expr
) == FAILURE
)
2232 static gfc_try
check_restricted (gfc_expr
*);
2234 /* F95, 7.1.6.1, Initialization expressions, (7)
2235 F2003, 7.1.7 Initialization expression, (8) */
2238 check_inquiry (gfc_expr
*e
, int not_restricted
)
2241 const char *const *functions
;
2243 static const char *const inquiry_func_f95
[] = {
2244 "lbound", "shape", "size", "ubound",
2245 "bit_size", "len", "kind",
2246 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2247 "precision", "radix", "range", "tiny",
2251 static const char *const inquiry_func_f2003
[] = {
2252 "lbound", "shape", "size", "ubound",
2253 "bit_size", "len", "kind",
2254 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2255 "precision", "radix", "range", "tiny",
2260 gfc_actual_arglist
*ap
;
2262 if (!e
->value
.function
.isym
2263 || !e
->value
.function
.isym
->inquiry
)
2266 /* An undeclared parameter will get us here (PR25018). */
2267 if (e
->symtree
== NULL
)
2270 name
= e
->symtree
->n
.sym
->name
;
2272 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2273 ? inquiry_func_f2003
: inquiry_func_f95
;
2275 for (i
= 0; functions
[i
]; i
++)
2276 if (strcmp (functions
[i
], name
) == 0)
2279 if (functions
[i
] == NULL
)
2282 /* At this point we have an inquiry function with a variable argument. The
2283 type of the variable might be undefined, but we need it now, because the
2284 arguments of these functions are not allowed to be undefined. */
2286 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2291 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2293 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2294 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2298 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2301 /* Assumed character length will not reduce to a constant expression
2302 with LEN, as required by the standard. */
2303 if (i
== 5 && not_restricted
2304 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2305 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2306 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2308 gfc_error ("Assumed or deferred character length variable '%s' "
2309 " in constant expression at %L",
2310 ap
->expr
->symtree
->n
.sym
->name
,
2314 else if (not_restricted
&& gfc_check_init_expr (ap
->expr
) == FAILURE
)
2317 if (not_restricted
== 0
2318 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2319 && check_restricted (ap
->expr
) == FAILURE
)
2322 if (not_restricted
== 0
2323 && ap
->expr
->expr_type
== EXPR_VARIABLE
2324 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2325 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2333 /* F95, 7.1.6.1, Initialization expressions, (5)
2334 F2003, 7.1.7 Initialization expression, (5) */
2337 check_transformational (gfc_expr
*e
)
2339 static const char * const trans_func_f95
[] = {
2340 "repeat", "reshape", "selected_int_kind",
2341 "selected_real_kind", "transfer", "trim", NULL
2344 static const char * const trans_func_f2003
[] = {
2345 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2346 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2347 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2348 "trim", "unpack", NULL
2353 const char *const *functions
;
2355 if (!e
->value
.function
.isym
2356 || !e
->value
.function
.isym
->transformational
)
2359 name
= e
->symtree
->n
.sym
->name
;
2361 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2362 ? trans_func_f2003
: trans_func_f95
;
2364 /* NULL() is dealt with below. */
2365 if (strcmp ("null", name
) == 0)
2368 for (i
= 0; functions
[i
]; i
++)
2369 if (strcmp (functions
[i
], name
) == 0)
2372 if (functions
[i
] == NULL
)
2374 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2375 "in an initialization expression", name
, &e
->where
);
2379 return check_init_expr_arguments (e
);
2383 /* F95, 7.1.6.1, Initialization expressions, (6)
2384 F2003, 7.1.7 Initialization expression, (6) */
2387 check_null (gfc_expr
*e
)
2389 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2392 return check_init_expr_arguments (e
);
2397 check_elemental (gfc_expr
*e
)
2399 if (!e
->value
.function
.isym
2400 || !e
->value
.function
.isym
->elemental
)
2403 if (e
->ts
.type
!= BT_INTEGER
2404 && e
->ts
.type
!= BT_CHARACTER
2405 && gfc_notify_std (GFC_STD_F2003
, "Evaluation of "
2406 "nonstandard initialization expression at %L",
2407 &e
->where
) == FAILURE
)
2410 return check_init_expr_arguments (e
);
2415 check_conversion (gfc_expr
*e
)
2417 if (!e
->value
.function
.isym
2418 || !e
->value
.function
.isym
->conversion
)
2421 return check_init_expr_arguments (e
);
2425 /* Verify that an expression is an initialization expression. A side
2426 effect is that the expression tree is reduced to a single constant
2427 node if all goes well. This would normally happen when the
2428 expression is constructed but function references are assumed to be
2429 intrinsics in the context of initialization expressions. If
2430 FAILURE is returned an error message has been generated. */
2433 gfc_check_init_expr (gfc_expr
*e
)
2441 switch (e
->expr_type
)
2444 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2446 t
= gfc_simplify_expr (e
, 0);
2454 gfc_intrinsic_sym
* isym
;
2457 sym
= e
->symtree
->n
.sym
;
2458 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2459 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2461 gfc_error ("Function '%s' in initialization expression at %L "
2462 "must be an intrinsic function",
2463 e
->symtree
->n
.sym
->name
, &e
->where
);
2467 if ((m
= check_conversion (e
)) == MATCH_NO
2468 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2469 && (m
= check_null (e
)) == MATCH_NO
2470 && (m
= check_transformational (e
)) == MATCH_NO
2471 && (m
= check_elemental (e
)) == MATCH_NO
)
2473 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2474 "in an initialization expression",
2475 e
->symtree
->n
.sym
->name
, &e
->where
);
2479 if (m
== MATCH_ERROR
)
2482 /* Try to scalarize an elemental intrinsic function that has an
2484 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2485 if (isym
&& isym
->elemental
2486 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2491 t
= gfc_simplify_expr (e
, 0);
2498 if (gfc_check_iter_variable (e
) == SUCCESS
)
2501 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2503 /* A PARAMETER shall not be used to define itself, i.e.
2504 REAL, PARAMETER :: x = transfer(0, x)
2506 if (!e
->symtree
->n
.sym
->value
)
2508 gfc_error("PARAMETER '%s' is used at %L before its definition "
2509 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2513 t
= simplify_parameter_variable (e
, 0);
2518 if (gfc_in_match_data ())
2523 if (e
->symtree
->n
.sym
->as
)
2525 switch (e
->symtree
->n
.sym
->as
->type
)
2527 case AS_ASSUMED_SIZE
:
2528 gfc_error ("Assumed size array '%s' at %L is not permitted "
2529 "in an initialization expression",
2530 e
->symtree
->n
.sym
->name
, &e
->where
);
2533 case AS_ASSUMED_SHAPE
:
2534 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2535 "in an initialization expression",
2536 e
->symtree
->n
.sym
->name
, &e
->where
);
2540 gfc_error ("Deferred array '%s' at %L is not permitted "
2541 "in an initialization expression",
2542 e
->symtree
->n
.sym
->name
, &e
->where
);
2546 gfc_error ("Array '%s' at %L is a variable, which does "
2547 "not reduce to a constant expression",
2548 e
->symtree
->n
.sym
->name
, &e
->where
);
2556 gfc_error ("Parameter '%s' at %L has not been declared or is "
2557 "a variable, which does not reduce to a constant "
2558 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2567 case EXPR_SUBSTRING
:
2568 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2572 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2574 t
= gfc_simplify_expr (e
, 0);
2578 case EXPR_STRUCTURE
:
2579 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2583 t
= check_alloc_comp_init (e
);
2587 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2594 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2598 t
= gfc_expand_constructor (e
, true);
2602 t
= gfc_check_constructor_type (e
);
2606 gfc_internal_error ("check_init_expr(): Unknown expression type");
2612 /* Reduces a general expression to an initialization expression (a constant).
2613 This used to be part of gfc_match_init_expr.
2614 Note that this function doesn't free the given expression on FAILURE. */
2617 gfc_reduce_init_expr (gfc_expr
*expr
)
2621 gfc_init_expr_flag
= true;
2622 t
= gfc_resolve_expr (expr
);
2624 t
= gfc_check_init_expr (expr
);
2625 gfc_init_expr_flag
= false;
2630 if (expr
->expr_type
== EXPR_ARRAY
)
2632 if (gfc_check_constructor_type (expr
) == FAILURE
)
2634 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2642 /* Match an initialization expression. We work by first matching an
2643 expression, then reducing it to a constant. */
2646 gfc_match_init_expr (gfc_expr
**result
)
2654 gfc_init_expr_flag
= true;
2656 m
= gfc_match_expr (&expr
);
2659 gfc_init_expr_flag
= false;
2663 t
= gfc_reduce_init_expr (expr
);
2666 gfc_free_expr (expr
);
2667 gfc_init_expr_flag
= false;
2672 gfc_init_expr_flag
= false;
2678 /* Given an actual argument list, test to see that each argument is a
2679 restricted expression and optionally if the expression type is
2680 integer or character. */
2683 restricted_args (gfc_actual_arglist
*a
)
2685 for (; a
; a
= a
->next
)
2687 if (check_restricted (a
->expr
) == FAILURE
)
2695 /************* Restricted/specification expressions *************/
2698 /* Make sure a non-intrinsic function is a specification function. */
2701 external_spec_function (gfc_expr
*e
)
2705 f
= e
->value
.function
.esym
;
2707 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2709 gfc_error ("Specification function '%s' at %L cannot be a statement "
2710 "function", f
->name
, &e
->where
);
2714 if (f
->attr
.proc
== PROC_INTERNAL
)
2716 gfc_error ("Specification function '%s' at %L cannot be an internal "
2717 "function", f
->name
, &e
->where
);
2721 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2723 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2728 if (f
->attr
.recursive
)
2730 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2731 f
->name
, &e
->where
);
2735 return restricted_args (e
->value
.function
.actual
);
2739 /* Check to see that a function reference to an intrinsic is a
2740 restricted expression. */
2743 restricted_intrinsic (gfc_expr
*e
)
2745 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2746 if (check_inquiry (e
, 0) == MATCH_YES
)
2749 return restricted_args (e
->value
.function
.actual
);
2753 /* Check the expressions of an actual arglist. Used by check_restricted. */
2756 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2758 for (; arg
; arg
= arg
->next
)
2759 if (checker (arg
->expr
) == FAILURE
)
2766 /* Check the subscription expressions of a reference chain with a checking
2767 function; used by check_restricted. */
2770 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2780 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2782 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2784 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2786 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2792 /* Nothing needed, just proceed to next reference. */
2796 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2798 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2807 return check_references (ref
->next
, checker
);
2811 /* Verify that an expression is a restricted expression. Like its
2812 cousin check_init_expr(), an error message is generated if we
2816 check_restricted (gfc_expr
*e
)
2824 switch (e
->expr_type
)
2827 t
= check_intrinsic_op (e
, check_restricted
);
2829 t
= gfc_simplify_expr (e
, 0);
2834 if (e
->value
.function
.esym
)
2836 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2838 t
= external_spec_function (e
);
2842 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2845 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2848 t
= restricted_intrinsic (e
);
2853 sym
= e
->symtree
->n
.sym
;
2856 /* If a dummy argument appears in a context that is valid for a
2857 restricted expression in an elemental procedure, it will have
2858 already been simplified away once we get here. Therefore we
2859 don't need to jump through hoops to distinguish valid from
2861 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2862 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2864 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2865 sym
->name
, &e
->where
);
2869 if (sym
->attr
.optional
)
2871 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2872 sym
->name
, &e
->where
);
2876 if (sym
->attr
.intent
== INTENT_OUT
)
2878 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2879 sym
->name
, &e
->where
);
2883 /* Check reference chain if any. */
2884 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2887 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2888 processed in resolve.c(resolve_formal_arglist). This is done so
2889 that host associated dummy array indices are accepted (PR23446).
2890 This mechanism also does the same for the specification expressions
2891 of array-valued functions. */
2893 || sym
->attr
.in_common
2894 || sym
->attr
.use_assoc
2896 || sym
->attr
.implied_index
2897 || sym
->attr
.flavor
== FL_PARAMETER
2898 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2899 || (sym
->ns
&& gfc_current_ns
->parent
2900 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2901 || (sym
->ns
->proc_name
!= NULL
2902 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2903 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2909 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2910 sym
->name
, &e
->where
);
2911 /* Prevent a repetition of the error. */
2920 case EXPR_SUBSTRING
:
2921 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2925 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2927 t
= gfc_simplify_expr (e
, 0);
2931 case EXPR_STRUCTURE
:
2932 t
= gfc_check_constructor (e
, check_restricted
);
2936 t
= gfc_check_constructor (e
, check_restricted
);
2940 gfc_internal_error ("check_restricted(): Unknown expression type");
2947 /* Check to see that an expression is a specification expression. If
2948 we return FAILURE, an error has been generated. */
2951 gfc_specification_expr (gfc_expr
*e
)
2953 gfc_component
*comp
;
2958 if (e
->ts
.type
!= BT_INTEGER
)
2960 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2961 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2965 comp
= gfc_get_proc_ptr_comp (e
);
2966 if (e
->expr_type
== EXPR_FUNCTION
2967 && !e
->value
.function
.isym
2968 && !e
->value
.function
.esym
2969 && !gfc_pure (e
->symtree
->n
.sym
)
2970 && (!comp
|| !comp
->attr
.pure
))
2972 gfc_error ("Function '%s' at %L must be PURE",
2973 e
->symtree
->n
.sym
->name
, &e
->where
);
2974 /* Prevent repeat error messages. */
2975 e
->symtree
->n
.sym
->attr
.pure
= 1;
2981 gfc_error ("Expression at %L must be scalar", &e
->where
);
2985 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2988 return check_restricted (e
);
2992 /************** Expression conformance checks. *************/
2994 /* Given two expressions, make sure that the arrays are conformable. */
2997 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
2999 int op1_flag
, op2_flag
, d
;
3000 mpz_t op1_size
, op2_size
;
3006 if (op1
->rank
== 0 || op2
->rank
== 0)
3009 va_start (argp
, optype_msgid
);
3010 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3013 if (op1
->rank
!= op2
->rank
)
3015 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3016 op1
->rank
, op2
->rank
, &op1
->where
);
3022 for (d
= 0; d
< op1
->rank
; d
++)
3024 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3025 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3027 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3029 gfc_error ("Different shape for %s at %L on dimension %d "
3030 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3031 (int) mpz_get_si (op1_size
),
3032 (int) mpz_get_si (op2_size
));
3038 mpz_clear (op1_size
);
3040 mpz_clear (op2_size
);
3050 /* Given an assignable expression and an arbitrary expression, make
3051 sure that the assignment can take place. */
3054 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3060 sym
= lvalue
->symtree
->n
.sym
;
3062 /* See if this is the component or subcomponent of a pointer. */
3063 has_pointer
= sym
->attr
.pointer
;
3064 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3065 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3071 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3072 variable local to a function subprogram. Its existence begins when
3073 execution of the function is initiated and ends when execution of the
3074 function is terminated...
3075 Therefore, the left hand side is no longer a variable, when it is: */
3076 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3077 && !sym
->attr
.external
)
3082 /* (i) Use associated; */
3083 if (sym
->attr
.use_assoc
)
3086 /* (ii) The assignment is in the main program; or */
3087 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3090 /* (iii) A module or internal procedure... */
3091 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3092 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3093 && gfc_current_ns
->parent
3094 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3095 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3096 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3098 /* ... that is not a function... */
3099 if (!gfc_current_ns
->proc_name
->attr
.function
)
3102 /* ... or is not an entry and has a different name. */
3103 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3107 /* (iv) Host associated and not the function symbol or the
3108 parent result. This picks up sibling references, which
3109 cannot be entries. */
3110 if (!sym
->attr
.entry
3111 && sym
->ns
== gfc_current_ns
->parent
3112 && sym
!= gfc_current_ns
->proc_name
3113 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3118 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3123 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3125 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3126 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3130 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3132 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3137 if (rvalue
->expr_type
== EXPR_NULL
)
3139 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3140 && lvalue
->symtree
->n
.sym
->attr
.data
)
3144 gfc_error ("NULL appears on right-hand side in assignment at %L",
3150 /* This is possibly a typo: x = f() instead of x => f(). */
3151 if (gfc_option
.warn_surprising
3152 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3153 gfc_warning ("POINTER-valued function appears on right-hand side of "
3154 "assignment at %L", &rvalue
->where
);
3156 /* Check size of array assignments. */
3157 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3158 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3161 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3162 && lvalue
->symtree
->n
.sym
->attr
.data
3163 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3164 "initialize non-integer variable '%s'",
3165 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3168 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3169 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3170 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3171 &rvalue
->where
) == FAILURE
)
3174 /* Handle the case of a BOZ literal on the RHS. */
3175 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3178 if (gfc_option
.warn_surprising
)
3179 gfc_warning ("BOZ literal at %L is bitwise transferred "
3180 "non-integer symbol '%s'", &rvalue
->where
,
3181 lvalue
->symtree
->n
.sym
->name
);
3182 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3184 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3186 if (rc
== ARITH_UNDERFLOW
)
3187 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3188 ". This check can be disabled with the option "
3189 "-fno-range-check", &rvalue
->where
);
3190 else if (rc
== ARITH_OVERFLOW
)
3191 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3192 ". This check can be disabled with the option "
3193 "-fno-range-check", &rvalue
->where
);
3194 else if (rc
== ARITH_NAN
)
3195 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3196 ". This check can be disabled with the option "
3197 "-fno-range-check", &rvalue
->where
);
3202 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3203 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3204 will warn anyway, so there is no need to to so here. */
3206 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3207 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3209 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3211 /* As a special bonus, don't warn about REAL rvalues which are not
3212 changed by the conversion if -Wconversion is specified. */
3213 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3215 /* Calculate the difference between the constant and the rounded
3216 value and check it against zero. */
3218 gfc_set_model_kind (lvalue
->ts
.kind
);
3220 gfc_set_model_kind (rvalue
->ts
.kind
);
3223 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3224 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3226 if (!mpfr_zero_p (diff
))
3227 gfc_warning ("Change of value in conversion from "
3228 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3229 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3235 gfc_warning ("Possible change of value in conversion from %s "
3236 "to %s at %L",gfc_typename (&rvalue
->ts
),
3237 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3240 else if (gfc_option
.warn_conversion_extra
3241 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3243 gfc_warning ("Conversion from %s to %s at %L",
3244 gfc_typename (&rvalue
->ts
),
3245 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3249 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3252 /* Only DATA Statements come here. */
3255 /* Numeric can be converted to any other numeric. And Hollerith can be
3256 converted to any other type. */
3257 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3258 || rvalue
->ts
.type
== BT_HOLLERITH
)
3261 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3264 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3265 "conversion of %s to %s", &lvalue
->where
,
3266 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3271 /* Assignment is the only case where character variables of different
3272 kind values can be converted into one another. */
3273 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3275 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3276 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3281 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3285 /* Check that a pointer assignment is OK. We first check lvalue, and
3286 we only check rvalue if it's not an assignment to NULL() or a
3287 NULLIFY statement. */
3290 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3292 symbol_attribute attr
, lhs_attr
;
3294 bool is_pure
, is_implicit_pure
, rank_remap
;
3297 lhs_attr
= gfc_expr_attr (lvalue
);
3298 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3300 gfc_error ("Pointer assignment target is not a POINTER at %L",
3305 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3306 && !lhs_attr
.proc_pointer
)
3308 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3309 "l-value since it is a procedure",
3310 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3314 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3317 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3319 if (ref
->type
== REF_COMPONENT
)
3320 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3322 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3326 if (ref
->u
.ar
.type
== AR_FULL
)
3329 if (ref
->u
.ar
.type
!= AR_SECTION
)
3331 gfc_error ("Expected bounds specification for '%s' at %L",
3332 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3336 if (gfc_notify_std (GFC_STD_F2003
,"Bounds "
3337 "specification for '%s' in pointer assignment "
3338 "at %L", lvalue
->symtree
->n
.sym
->name
,
3339 &lvalue
->where
) == FAILURE
)
3342 /* When bounds are given, all lbounds are necessary and either all
3343 or none of the upper bounds; no strides are allowed. If the
3344 upper bounds are present, we may do rank remapping. */
3345 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3347 if (!ref
->u
.ar
.start
[dim
]
3348 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3350 gfc_error ("Lower bound has to be present at %L",
3354 if (ref
->u
.ar
.stride
[dim
])
3356 gfc_error ("Stride must not be present at %L",
3362 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3365 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3366 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3368 gfc_error ("Either all or none of the upper bounds"
3369 " must be specified at %L", &lvalue
->where
);
3377 is_pure
= gfc_pure (NULL
);
3378 is_implicit_pure
= gfc_implicit_pure (NULL
);
3380 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3381 kind, etc for lvalue and rvalue must match, and rvalue must be a
3382 pure variable if we're in a pure function. */
3383 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3386 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3387 if (lvalue
->expr_type
== EXPR_VARIABLE
3388 && gfc_is_coindexed (lvalue
))
3391 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3392 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3394 gfc_error ("Pointer object at %L shall not have a coindex",
3400 /* Checks on rvalue for procedure pointer assignments. */
3405 gfc_component
*comp
;
3408 attr
= gfc_expr_attr (rvalue
);
3409 if (!((rvalue
->expr_type
== EXPR_NULL
)
3410 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3411 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3412 || (rvalue
->expr_type
== EXPR_VARIABLE
3413 && attr
.flavor
== FL_PROCEDURE
)))
3415 gfc_error ("Invalid procedure pointer assignment at %L",
3419 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3421 /* Check for intrinsics. */
3422 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3423 if (!sym
->attr
.intrinsic
3424 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3425 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3427 sym
->attr
.intrinsic
= 1;
3428 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3429 attr
= gfc_expr_attr (rvalue
);
3431 /* Check for result of embracing function. */
3432 if (sym
== gfc_current_ns
->proc_name
3433 && sym
->attr
.function
&& sym
->result
== sym
)
3435 gfc_error ("Function result '%s' is invalid as proc-target "
3436 "in procedure pointer assignment at %L",
3437 sym
->name
, &rvalue
->where
);
3443 gfc_error ("Abstract interface '%s' is invalid "
3444 "in procedure pointer assignment at %L",
3445 rvalue
->symtree
->name
, &rvalue
->where
);
3448 /* Check for F08:C729. */
3449 if (attr
.flavor
== FL_PROCEDURE
)
3451 if (attr
.proc
== PROC_ST_FUNCTION
)
3453 gfc_error ("Statement function '%s' is invalid "
3454 "in procedure pointer assignment at %L",
3455 rvalue
->symtree
->name
, &rvalue
->where
);
3458 if (attr
.proc
== PROC_INTERNAL
&&
3459 gfc_notify_std (GFC_STD_F2008
, "Internal procedure "
3460 "'%s' is invalid in procedure pointer assignment "
3461 "at %L", rvalue
->symtree
->name
, &rvalue
->where
)
3464 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3465 attr
.subroutine
) == 0)
3467 gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
3468 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3472 /* Check for F08:C730. */
3473 if (attr
.elemental
&& !attr
.intrinsic
)
3475 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3476 "in procedure pointer assignment at %L",
3477 rvalue
->symtree
->name
, &rvalue
->where
);
3481 /* Ensure that the calling convention is the same. As other attributes
3482 such as DLLEXPORT may differ, one explicitly only tests for the
3483 calling conventions. */
3484 if (rvalue
->expr_type
== EXPR_VARIABLE
3485 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3486 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3488 symbol_attribute calls
;
3491 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3492 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3493 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3495 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3496 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3498 gfc_error ("Mismatch in the procedure pointer assignment "
3499 "at %L: mismatch in the calling convention",
3505 comp
= gfc_get_proc_ptr_comp (lvalue
);
3507 s1
= comp
->ts
.interface
;
3510 s1
= lvalue
->symtree
->n
.sym
;
3511 if (s1
->ts
.interface
)
3512 s1
= s1
->ts
.interface
;
3515 comp
= gfc_get_proc_ptr_comp (rvalue
);
3518 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3520 s2
= comp
->ts
.interface
->result
;
3525 s2
= comp
->ts
.interface
;
3529 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3531 s2
= rvalue
->symtree
->n
.sym
->result
;
3536 s2
= rvalue
->symtree
->n
.sym
;
3540 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3541 s2
= s2
->ts
.interface
;
3543 if (s1
== s2
|| !s1
|| !s2
)
3546 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3547 err
, sizeof(err
), NULL
, NULL
))
3549 gfc_error ("Interface mismatch in procedure pointer assignment "
3550 "at %L: %s", &rvalue
->where
, err
);
3554 if (!gfc_compare_interfaces (s2
, s1
, name
, 0, 1,
3555 err
, sizeof(err
), NULL
, NULL
))
3557 gfc_error ("Interface mismatch in procedure pointer assignment "
3558 "at %L: %s", &rvalue
->where
, err
);
3565 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3567 /* Check for F03:C717. */
3568 if (UNLIMITED_POLY (rvalue
)
3569 && !(UNLIMITED_POLY (lvalue
)
3570 || (lvalue
->ts
.type
== BT_DERIVED
3571 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3572 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3573 gfc_error ("Data-pointer-object &L must be unlimited "
3574 "polymorphic, a sequence derived type or of a "
3575 "type with the BIND attribute assignment at %L "
3576 "to be compatible with an unlimited polymorphic "
3577 "target", &lvalue
->where
);
3579 gfc_error ("Different types in pointer assignment at %L; "
3580 "attempted assignment of %s to %s", &lvalue
->where
,
3581 gfc_typename (&rvalue
->ts
),
3582 gfc_typename (&lvalue
->ts
));
3586 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3588 gfc_error ("Different kind type parameters in pointer "
3589 "assignment at %L", &lvalue
->where
);
3593 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3595 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3599 /* Make sure the vtab is present. */
3600 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3601 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3602 else if (UNLIMITED_POLY (lvalue
) && !UNLIMITED_POLY (rvalue
))
3603 gfc_find_intrinsic_vtab (&rvalue
->ts
);
3605 /* Check rank remapping. */
3610 /* If this can be determined, check that the target must be at least as
3611 large as the pointer assigned to it is. */
3612 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3613 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3614 && mpz_cmp (rsize
, lsize
) < 0)
3616 gfc_error ("Rank remapping target is smaller than size of the"
3617 " pointer (%ld < %ld) at %L",
3618 mpz_get_si (rsize
), mpz_get_si (lsize
),
3623 /* The target must be either rank one or it must be simply contiguous
3624 and F2008 must be allowed. */
3625 if (rvalue
->rank
!= 1)
3627 if (!gfc_is_simply_contiguous (rvalue
, true))
3629 gfc_error ("Rank remapping target must be rank 1 or"
3630 " simply contiguous at %L", &rvalue
->where
);
3633 if (gfc_notify_std (GFC_STD_F2008
, "Rank remapping"
3634 " target is not rank 1 at %L", &rvalue
->where
)
3640 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3641 if (rvalue
->expr_type
== EXPR_NULL
)
3644 if (lvalue
->ts
.type
== BT_CHARACTER
)
3646 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3651 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3652 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3654 attr
= gfc_expr_attr (rvalue
);
3656 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3658 gfc_error ("Target expression in pointer assignment "
3659 "at %L must deliver a pointer result",
3664 if (!attr
.target
&& !attr
.pointer
)
3666 gfc_error ("Pointer assignment target is neither TARGET "
3667 "nor POINTER at %L", &rvalue
->where
);
3671 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3673 gfc_error ("Bad target in pointer assignment in PURE "
3674 "procedure at %L", &rvalue
->where
);
3677 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3678 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3681 if (gfc_has_vector_index (rvalue
))
3683 gfc_error ("Pointer assignment with vector subscript "
3684 "on rhs at %L", &rvalue
->where
);
3688 if (attr
.is_protected
&& attr
.use_assoc
3689 && !(attr
.pointer
|| attr
.proc_pointer
))
3691 gfc_error ("Pointer assignment target has PROTECTED "
3692 "attribute at %L", &rvalue
->where
);
3696 /* F2008, C725. For PURE also C1283. */
3697 if (rvalue
->expr_type
== EXPR_VARIABLE
3698 && gfc_is_coindexed (rvalue
))
3701 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3702 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3704 gfc_error ("Data target at %L shall not have a coindex",
3710 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3711 if (gfc_option
.warn_target_lifetime
3712 && rvalue
->expr_type
== EXPR_VARIABLE
3713 && !rvalue
->symtree
->n
.sym
->attr
.save
3714 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3715 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3716 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3717 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3722 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3723 || lvalue
->symtree
->n
.sym
->attr
.result
3724 || lvalue
->symtree
->n
.sym
->attr
.function
3725 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3726 && lvalue
->symtree
->n
.sym
->ns
3727 != rvalue
->symtree
->n
.sym
->ns
)
3728 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3729 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3731 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3732 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3733 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3734 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3735 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3737 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3741 gfc_warning ("Pointer at %L in pointer assignment might outlive the "
3742 "pointer target", &lvalue
->where
);
3749 /* Relative of gfc_check_assign() except that the lvalue is a single
3750 symbol. Used for initialization assignments. */
3753 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3757 bool pointer
, proc_pointer
;
3759 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3761 lvalue
.expr_type
= EXPR_VARIABLE
;
3762 lvalue
.ts
= sym
->ts
;
3764 lvalue
.rank
= sym
->as
->rank
;
3765 lvalue
.symtree
= XCNEW (gfc_symtree
);
3766 lvalue
.symtree
->n
.sym
= sym
;
3767 lvalue
.where
= sym
->declared_at
;
3771 lvalue
.ref
= gfc_get_ref ();
3772 lvalue
.ref
->type
= REF_COMPONENT
;
3773 lvalue
.ref
->u
.c
.component
= comp
;
3774 lvalue
.ref
->u
.c
.sym
= sym
;
3775 lvalue
.ts
= comp
->ts
;
3776 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3777 lvalue
.where
= comp
->loc
;
3778 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3779 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3780 proc_pointer
= comp
->attr
.proc_pointer
;
3784 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3785 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3786 proc_pointer
= sym
->attr
.proc_pointer
;
3789 if (pointer
|| proc_pointer
)
3790 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3792 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3794 free (lvalue
.symtree
);
3799 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3801 /* F08:C461. Additional checks for pointer initialization. */
3802 symbol_attribute attr
;
3803 attr
= gfc_expr_attr (rvalue
);
3804 if (attr
.allocatable
)
3806 gfc_error ("Pointer initialization target at %L "
3807 "must not be ALLOCATABLE", &rvalue
->where
);
3810 if (!attr
.target
|| attr
.pointer
)
3812 gfc_error ("Pointer initialization target at %L "
3813 "must have the TARGET attribute", &rvalue
->where
);
3817 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3818 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3819 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3821 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3822 attr
.save
= SAVE_IMPLICIT
;
3827 gfc_error ("Pointer initialization target at %L "
3828 "must have the SAVE attribute", &rvalue
->where
);
3833 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3835 /* F08:C1220. Additional checks for procedure pointer initialization. */
3836 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3837 if (attr
.proc_pointer
)
3839 gfc_error ("Procedure pointer initialization target at %L "
3840 "may not be a procedure pointer", &rvalue
->where
);
3849 /* Check for default initializer; sym->value is not enough
3850 as it is also set for EXPR_NULL of allocatables. */
3853 gfc_has_default_initializer (gfc_symbol
*der
)
3857 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3858 for (c
= der
->components
; c
; c
= c
->next
)
3859 if (c
->ts
.type
== BT_DERIVED
)
3861 if (!c
->attr
.pointer
3862 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3864 if (c
->attr
.pointer
&& c
->initializer
)
3877 /* Get an expression for a default initializer. */
3880 gfc_default_initializer (gfc_typespec
*ts
)
3883 gfc_component
*comp
;
3885 /* See if we have a default initializer in this, but not in nested
3886 types (otherwise we could use gfc_has_default_initializer()). */
3887 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3888 if (comp
->initializer
|| comp
->attr
.allocatable
3889 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3890 && CLASS_DATA (comp
)->attr
.allocatable
))
3896 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3897 &ts
->u
.derived
->declared_at
);
3900 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3902 gfc_constructor
*ctor
= gfc_constructor_get();
3904 if (comp
->initializer
)
3906 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3907 if ((comp
->ts
.type
!= comp
->initializer
->ts
.type
3908 || comp
->ts
.kind
!= comp
->initializer
->ts
.kind
)
3909 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
3910 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
3913 if (comp
->attr
.allocatable
3914 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3916 ctor
->expr
= gfc_get_expr ();
3917 ctor
->expr
->expr_type
= EXPR_NULL
;
3918 ctor
->expr
->ts
= comp
->ts
;
3921 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3928 /* Given a symbol, create an expression node with that symbol as a
3929 variable. If the symbol is array valued, setup a reference of the
3933 gfc_get_variable_expr (gfc_symtree
*var
)
3937 e
= gfc_get_expr ();
3938 e
->expr_type
= EXPR_VARIABLE
;
3940 e
->ts
= var
->n
.sym
->ts
;
3942 if ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
3943 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
3944 && CLASS_DATA (var
->n
.sym
)->as
))
3946 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
3947 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
3948 e
->ref
= gfc_get_ref ();
3949 e
->ref
->type
= REF_ARRAY
;
3950 e
->ref
->u
.ar
.type
= AR_FULL
;
3951 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
3952 ? CLASS_DATA (var
->n
.sym
)->as
3960 /* Adds a full array reference to an expression, as needed. */
3963 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
3966 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3971 ref
->next
= gfc_get_ref ();
3976 e
->ref
= gfc_get_ref ();
3979 ref
->type
= REF_ARRAY
;
3980 ref
->u
.ar
.type
= AR_FULL
;
3981 ref
->u
.ar
.dimen
= e
->rank
;
3982 ref
->u
.ar
.where
= e
->where
;
3988 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3991 lval
= gfc_get_expr ();
3992 lval
->expr_type
= EXPR_VARIABLE
;
3993 lval
->where
= sym
->declared_at
;
3995 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3997 /* It will always be a full array. */
3998 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
4000 gfc_add_full_array_ref (lval
, sym
->ts
.type
== BT_CLASS
?
4001 CLASS_DATA (sym
)->as
: sym
->as
);
4006 /* Returns the array_spec of a full array expression. A NULL is
4007 returned otherwise. */
4009 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4014 if (expr
->rank
== 0)
4017 /* Follow any component references. */
4018 if (expr
->expr_type
== EXPR_VARIABLE
4019 || expr
->expr_type
== EXPR_CONSTANT
)
4021 as
= expr
->symtree
->n
.sym
->as
;
4022 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4027 as
= ref
->u
.c
.component
->as
;
4035 switch (ref
->u
.ar
.type
)
4058 /* General expression traversal function. */
4061 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4062 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4067 gfc_actual_arglist
*args
;
4074 if ((*func
) (expr
, sym
, &f
))
4077 if (expr
->ts
.type
== BT_CHARACTER
4079 && expr
->ts
.u
.cl
->length
4080 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4081 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4084 switch (expr
->expr_type
)
4089 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4091 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4099 case EXPR_SUBSTRING
:
4102 case EXPR_STRUCTURE
:
4104 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4105 c
; c
= gfc_constructor_next (c
))
4107 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4111 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4113 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4115 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4117 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4124 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4126 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4142 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4144 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4146 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4148 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4154 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4156 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4161 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4162 && ref
->u
.c
.component
->ts
.u
.cl
4163 && ref
->u
.c
.component
->ts
.u
.cl
->length
4164 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4166 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4170 if (ref
->u
.c
.component
->as
)
4171 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4172 + ref
->u
.c
.component
->as
->corank
; i
++)
4174 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4177 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4191 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4194 expr_set_symbols_referenced (gfc_expr
*expr
,
4195 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4196 int *f ATTRIBUTE_UNUSED
)
4198 if (expr
->expr_type
!= EXPR_VARIABLE
)
4200 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4205 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4207 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4211 /* Determine if an expression is a procedure pointer component and return
4212 the component in that case. Otherwise return NULL. */
4215 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4219 if (!expr
|| !expr
->ref
)
4226 if (ref
->type
== REF_COMPONENT
4227 && ref
->u
.c
.component
->attr
.proc_pointer
)
4228 return ref
->u
.c
.component
;
4234 /* Determine if an expression is a procedure pointer component. */
4237 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4239 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4243 /* Walk an expression tree and check each variable encountered for being typed.
4244 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4245 mode as is a basic arithmetic expression using those; this is for things in
4248 INTEGER :: arr(n), n
4249 INTEGER :: arr(n + 1), n
4251 The namespace is needed for IMPLICIT typing. */
4253 static gfc_namespace
* check_typed_ns
;
4256 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4257 int* f ATTRIBUTE_UNUSED
)
4261 if (e
->expr_type
!= EXPR_VARIABLE
)
4264 gcc_assert (e
->symtree
);
4265 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4268 return (t
== FAILURE
);
4272 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4276 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4280 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4281 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4283 if (e
->expr_type
== EXPR_OP
)
4285 gfc_try t
= SUCCESS
;
4287 gcc_assert (e
->value
.op
.op1
);
4288 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4290 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4291 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4297 /* Otherwise, walk the expression and do it strictly. */
4298 check_typed_ns
= ns
;
4299 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4301 return error_found
? FAILURE
: SUCCESS
;
4306 gfc_ref_this_image (gfc_ref
*ref
)
4310 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4312 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4313 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4321 gfc_is_coindexed (gfc_expr
*e
)
4325 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4326 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4327 return !gfc_ref_this_image (ref
);
4333 /* Coarrays are variables with a corank but not being coindexed. However, also
4334 the following is a coarray: A subobject of a coarray is a coarray if it does
4335 not have any cosubscripts, vector subscripts, allocatable component
4336 selection, or pointer component selection. (F2008, 2.4.7) */
4339 gfc_is_coarray (gfc_expr
*e
)
4343 gfc_component
*comp
;
4348 if (e
->expr_type
!= EXPR_VARIABLE
)
4352 sym
= e
->symtree
->n
.sym
;
4354 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4355 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4357 coarray
= sym
->attr
.codimension
;
4359 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4363 comp
= ref
->u
.c
.component
;
4364 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4365 && (CLASS_DATA (comp
)->attr
.class_pointer
4366 || CLASS_DATA (comp
)->attr
.allocatable
))
4369 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4371 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4374 coarray
= comp
->attr
.codimension
;
4382 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4388 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4389 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4400 return coarray
&& !coindexed
;
4405 gfc_get_corank (gfc_expr
*e
)
4410 if (!gfc_is_coarray (e
))
4413 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4414 corank
= e
->ts
.u
.derived
->components
->as
4415 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4417 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4419 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4421 if (ref
->type
== REF_ARRAY
)
4422 corank
= ref
->u
.ar
.as
->corank
;
4423 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4430 /* Check whether the expression has an ultimate allocatable component.
4431 Being itself allocatable does not count. */
4433 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4435 gfc_ref
*ref
, *last
= NULL
;
4437 if (e
->expr_type
!= EXPR_VARIABLE
)
4440 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4441 if (ref
->type
== REF_COMPONENT
)
4444 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4445 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4446 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4447 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4451 if (e
->ts
.type
== BT_CLASS
)
4452 return CLASS_DATA (e
)->attr
.alloc_comp
;
4453 else if (e
->ts
.type
== BT_DERIVED
)
4454 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4460 /* Check whether the expression has an pointer component.
4461 Being itself a pointer does not count. */
4463 gfc_has_ultimate_pointer (gfc_expr
*e
)
4465 gfc_ref
*ref
, *last
= NULL
;
4467 if (e
->expr_type
!= EXPR_VARIABLE
)
4470 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4471 if (ref
->type
== REF_COMPONENT
)
4474 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4475 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4476 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4477 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4481 if (e
->ts
.type
== BT_CLASS
)
4482 return CLASS_DATA (e
)->attr
.pointer_comp
;
4483 else if (e
->ts
.type
== BT_DERIVED
)
4484 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4490 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4491 Note: A scalar is not regarded as "simply contiguous" by the standard.
4492 if bool is not strict, some further checks are done - for instance,
4493 a "(::1)" is accepted. */
4496 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4500 gfc_array_ref
*ar
= NULL
;
4501 gfc_ref
*ref
, *part_ref
= NULL
;
4504 if (expr
->expr_type
== EXPR_FUNCTION
)
4505 return expr
->value
.function
.esym
4506 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4507 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4510 if (expr
->rank
== 0)
4513 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4516 return false; /* Array shall be last part-ref. */
4518 if (ref
->type
== REF_COMPONENT
)
4520 else if (ref
->type
== REF_SUBSTRING
)
4522 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4526 sym
= expr
->symtree
->n
.sym
;
4527 if (expr
->ts
.type
!= BT_CLASS
4529 && !part_ref
->u
.c
.component
->attr
.contiguous
4530 && part_ref
->u
.c
.component
->attr
.pointer
)
4532 && !sym
->attr
.contiguous
4533 && (sym
->attr
.pointer
4534 || sym
->as
->type
== AS_ASSUMED_RANK
4535 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
4538 if (!ar
|| ar
->type
== AR_FULL
)
4541 gcc_assert (ar
->type
== AR_SECTION
);
4543 /* Check for simply contiguous array */
4545 for (i
= 0; i
< ar
->dimen
; i
++)
4547 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4550 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4556 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4559 /* If the previous section was not contiguous, that's an error,
4560 unless we have effective only one element and checking is not
4562 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4563 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4564 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4565 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4566 ar
->end
[i
]->value
.integer
) != 0))
4569 /* Following the standard, "(::1)" or - if known at compile time -
4570 "(lbound:ubound)" are not simply contiguous; if strict
4571 is false, they are regarded as simply contiguous. */
4572 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4573 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4574 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4578 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4579 || !ar
->as
->lower
[i
]
4580 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4581 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4582 ar
->as
->lower
[i
]->value
.integer
) != 0))
4586 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4587 || !ar
->as
->upper
[i
]
4588 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4589 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4590 ar
->as
->upper
[i
]->value
.integer
) != 0))
4598 /* Build call to an intrinsic procedure. The number of arguments has to be
4599 passed (rather than ending the list with a NULL value) because we may
4600 want to add arguments but with a NULL-expression. */
4603 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
4604 locus where
, unsigned numarg
, ...)
4607 gfc_actual_arglist
* atail
;
4608 gfc_intrinsic_sym
* isym
;
4611 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
4613 isym
= gfc_intrinsic_function_by_id (id
);
4616 result
= gfc_get_expr ();
4617 result
->expr_type
= EXPR_FUNCTION
;
4618 result
->ts
= isym
->ts
;
4619 result
->where
= where
;
4620 result
->value
.function
.name
= mangled_name
;
4621 result
->value
.function
.isym
= isym
;
4623 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
4624 gfc_commit_symbol (result
->symtree
->n
.sym
);
4625 gcc_assert (result
->symtree
4626 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
4627 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
4628 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
4629 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4630 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
4632 va_start (ap
, numarg
);
4634 for (i
= 0; i
< numarg
; ++i
)
4638 atail
->next
= gfc_get_actual_arglist ();
4639 atail
= atail
->next
;
4642 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4644 atail
->expr
= va_arg (ap
, gfc_expr
*);
4652 /* Check if an expression may appear in a variable definition context
4653 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4654 This is called from the various places when resolving
4655 the pieces that make up such a context.
4656 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
4657 variables), some checks are not performed.
4659 Optionally, a possible error message can be suppressed if context is NULL
4660 and just the return status (SUCCESS / FAILURE) be requested. */
4663 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4664 bool own_scope
, const char* context
)
4666 gfc_symbol
* sym
= NULL
;
4668 bool check_intentin
;
4671 symbol_attribute attr
;
4674 if (e
->expr_type
== EXPR_VARIABLE
)
4676 gcc_assert (e
->symtree
);
4677 sym
= e
->symtree
->n
.sym
;
4679 else if (e
->expr_type
== EXPR_FUNCTION
)
4681 gcc_assert (e
->symtree
);
4682 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4685 unlimited
= e
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (sym
);
4687 attr
= gfc_expr_attr (e
);
4688 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4690 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4693 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4694 " context (%s) at %L", context
, &e
->where
);
4698 else if (e
->expr_type
!= EXPR_VARIABLE
)
4701 gfc_error ("Non-variable expression in variable definition context (%s)"
4702 " at %L", context
, &e
->where
);
4706 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4709 gfc_error ("Named constant '%s' in variable definition context (%s)"
4710 " at %L", sym
->name
, context
, &e
->where
);
4713 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4714 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4715 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4718 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4719 " a variable", sym
->name
, context
, &e
->where
);
4723 /* Find out whether the expr is a pointer; this also means following
4724 component references to the last one. */
4725 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4726 if (pointer
&& !is_pointer
&& !unlimited
)
4729 gfc_error ("Non-POINTER in pointer association context (%s)"
4730 " at %L", context
, &e
->where
);
4737 || (e
->ts
.type
== BT_DERIVED
4738 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4739 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4742 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4743 context
, &e
->where
);
4747 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
4748 component of sub-component of a pointer; we need to distinguish
4749 assignment to a pointer component from pointer-assignment to a pointer
4750 component. Note that (normal) assignment to procedure pointers is not
4752 check_intentin
= !own_scope
;
4753 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4754 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4755 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4757 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4758 check_intentin
= false;
4759 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4761 ptr_component
= true;
4763 check_intentin
= false;
4766 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4768 if (pointer
&& is_pointer
)
4771 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4772 " association context (%s) at %L",
4773 sym
->name
, context
, &e
->where
);
4776 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
4779 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4780 " definition context (%s) at %L",
4781 sym
->name
, context
, &e
->where
);
4786 /* PROTECTED and use-associated. */
4787 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4789 if (pointer
&& is_pointer
)
4792 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4793 " pointer association context (%s) at %L",
4794 sym
->name
, context
, &e
->where
);
4797 if (!pointer
&& !is_pointer
)
4800 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4801 " variable definition context (%s) at %L",
4802 sym
->name
, context
, &e
->where
);
4807 /* Variable not assignable from a PURE procedure but appears in
4808 variable definition context. */
4809 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4812 gfc_error ("Variable '%s' can not appear in a variable definition"
4813 " context (%s) at %L in PURE procedure",
4814 sym
->name
, context
, &e
->where
);
4818 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
4819 && gfc_impure_variable (sym
))
4824 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4826 sym
= ns
->proc_name
;
4829 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4831 sym
->attr
.implicit_pure
= 0;
4836 /* Check variable definition context for associate-names. */
4837 if (!pointer
&& sym
->assoc
)
4840 gfc_association_list
* assoc
;
4842 gcc_assert (sym
->assoc
->target
);
4844 /* If this is a SELECT TYPE temporary (the association is used internally
4845 for SELECT TYPE), silently go over to the target. */
4846 if (sym
->attr
.select_type_temporary
)
4848 gfc_expr
* t
= sym
->assoc
->target
;
4850 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4851 name
= t
->symtree
->name
;
4853 if (t
->symtree
->n
.sym
->assoc
)
4854 assoc
= t
->symtree
->n
.sym
->assoc
;
4863 gcc_assert (name
&& assoc
);
4865 /* Is association to a valid variable? */
4866 if (!assoc
->variable
)
4870 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4871 gfc_error ("'%s' at %L associated to vector-indexed target can"
4872 " not be used in a variable definition context (%s)",
4873 name
, &e
->where
, context
);
4875 gfc_error ("'%s' at %L associated to expression can"
4876 " not be used in a variable definition context (%s)",
4877 name
, &e
->where
, context
);
4882 /* Target must be allowed to appear in a variable definition context. */
4883 if (gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
)
4887 gfc_error ("Associate-name '%s' can not appear in a variable"
4888 " definition context (%s) at %L because its target"
4889 " at %L can not, either",
4890 name
, context
, &e
->where
,
4891 &assoc
->target
->where
);