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 true or false, 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
))
1023 if (!gfc_simplify_expr (op2
, type
))
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
)
1154 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1155 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
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
))
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
])
1205 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
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
, &cons
))
1630 remove_subobject_ref (p
, cons
);
1634 if (!find_array_section (p
, p
->ref
))
1636 p
->ref
->u
.ar
.type
= AR_FULL
;
1641 if (p
->ref
->next
!= NULL
1642 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1644 for (c
= gfc_constructor_first (p
->value
.constructor
);
1645 c
; c
= gfc_constructor_next (c
))
1647 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1648 if (!simplify_const_ref (c
->expr
))
1652 if (p
->ts
.type
== BT_DERIVED
1654 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1656 /* There may have been component references. */
1657 p
->ts
= c
->expr
->ts
;
1661 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1663 if (p
->ts
.type
== BT_CHARACTER
1664 && last_ref
->type
== REF_SUBSTRING
)
1666 /* If this is a CHARACTER array and we possibly took
1667 a substring out of it, update the type-spec's
1668 character length according to the first element
1669 (as all should have the same length). */
1671 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1673 const gfc_expr
* first
= c
->expr
;
1674 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1675 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1676 string_len
= first
->value
.character
.length
;
1682 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1685 gfc_free_expr (p
->ts
.u
.cl
->length
);
1688 = gfc_get_int_expr (gfc_default_integer_kind
,
1692 gfc_free_ref_list (p
->ref
);
1703 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1704 remove_subobject_ref (p
, cons
);
1708 if (!find_substring_ref (p
, &newp
))
1711 gfc_replace_expr (p
, newp
);
1712 gfc_free_ref_list (p
->ref
);
1722 /* Simplify a chain of references. */
1725 simplify_ref_chain (gfc_ref
*ref
, int type
)
1729 for (; ref
; ref
= ref
->next
)
1734 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1736 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1738 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1740 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1746 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1748 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1760 /* Try to substitute the value of a parameter variable. */
1763 simplify_parameter_variable (gfc_expr
*p
, int type
)
1768 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1774 /* Do not copy subobject refs for constant. */
1775 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1776 e
->ref
= gfc_copy_ref (p
->ref
);
1777 t
= gfc_simplify_expr (e
, type
);
1779 /* Only use the simplification if it eliminated all subobject references. */
1781 gfc_replace_expr (p
, e
);
1788 /* Given an expression, simplify it by collapsing constant
1789 expressions. Most simplification takes place when the expression
1790 tree is being constructed. If an intrinsic function is simplified
1791 at some point, we get called again to collapse the result against
1794 We work by recursively simplifying expression nodes, simplifying
1795 intrinsic functions where possible, which can lead to further
1796 constant collapsing. If an operator has constant operand(s), we
1797 rip the expression apart, and rebuild it, hoping that it becomes
1800 The expression type is defined for:
1801 0 Basic expression parsing
1802 1 Simplifying array constructors -- will substitute
1804 Returns false on error, true otherwise.
1805 NOTE: Will return true even if the expression can not be simplified. */
1808 gfc_simplify_expr (gfc_expr
*p
, int type
)
1810 gfc_actual_arglist
*ap
;
1815 switch (p
->expr_type
)
1822 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1823 if (!gfc_simplify_expr (ap
->expr
, type
))
1826 if (p
->value
.function
.isym
!= NULL
1827 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1832 case EXPR_SUBSTRING
:
1833 if (!simplify_ref_chain (p
->ref
, type
))
1836 if (gfc_is_constant_expr (p
))
1842 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1844 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1845 start
--; /* Convert from one-based to zero-based. */
1848 end
= p
->value
.character
.length
;
1849 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1850 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1855 s
= gfc_get_wide_string (end
- start
+ 2);
1856 memcpy (s
, p
->value
.character
.string
+ start
,
1857 (end
- start
) * sizeof (gfc_char_t
));
1858 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1859 free (p
->value
.character
.string
);
1860 p
->value
.character
.string
= s
;
1861 p
->value
.character
.length
= end
- start
;
1862 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1863 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1865 p
->value
.character
.length
);
1866 gfc_free_ref_list (p
->ref
);
1868 p
->expr_type
= EXPR_CONSTANT
;
1873 if (!simplify_intrinsic_op (p
, type
))
1878 /* Only substitute array parameter variables if we are in an
1879 initialization expression, or we want a subsection. */
1880 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1881 && (gfc_init_expr_flag
|| p
->ref
1882 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1884 if (!simplify_parameter_variable (p
, type
))
1891 gfc_simplify_iterator_var (p
);
1894 /* Simplify subcomponent references. */
1895 if (!simplify_ref_chain (p
->ref
, type
))
1900 case EXPR_STRUCTURE
:
1902 if (!simplify_ref_chain (p
->ref
, type
))
1905 if (!simplify_constructor (p
->value
.constructor
, type
))
1908 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1909 && p
->ref
->u
.ar
.type
== AR_FULL
)
1910 gfc_expand_constructor (p
, false);
1912 if (!simplify_const_ref (p
))
1927 /* Returns the type of an expression with the exception that iterator
1928 variables are automatically integers no matter what else they may
1934 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1941 /* Scalarize an expression for an elemental intrinsic call. */
1944 scalarize_intrinsic_call (gfc_expr
*e
)
1946 gfc_actual_arglist
*a
, *b
;
1947 gfc_constructor_base ctor
;
1948 gfc_constructor
*args
[5];
1949 gfc_constructor
*ci
, *new_ctor
;
1950 gfc_expr
*expr
, *old
;
1951 int n
, i
, rank
[5], array_arg
;
1953 /* Find which, if any, arguments are arrays. Assume that the old
1954 expression carries the type information and that the first arg
1955 that is an array expression carries all the shape information.*/
1957 a
= e
->value
.function
.actual
;
1958 for (; a
; a
= a
->next
)
1961 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1964 expr
= gfc_copy_expr (a
->expr
);
1971 old
= gfc_copy_expr (e
);
1973 gfc_constructor_free (expr
->value
.constructor
);
1974 expr
->value
.constructor
= NULL
;
1976 expr
->where
= old
->where
;
1977 expr
->expr_type
= EXPR_ARRAY
;
1979 /* Copy the array argument constructors into an array, with nulls
1982 a
= old
->value
.function
.actual
;
1983 for (; a
; a
= a
->next
)
1985 /* Check that this is OK for an initialization expression. */
1986 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
1990 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1992 rank
[n
] = a
->expr
->rank
;
1993 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1994 args
[n
] = gfc_constructor_first (ctor
);
1996 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1999 rank
[n
] = a
->expr
->rank
;
2002 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2003 args
[n
] = gfc_constructor_first (ctor
);
2012 /* Using the array argument as the master, step through the array
2013 calling the function for each element and advancing the array
2014 constructors together. */
2015 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2017 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2018 gfc_copy_expr (old
), NULL
);
2020 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2022 b
= old
->value
.function
.actual
;
2023 for (i
= 0; i
< n
; i
++)
2026 new_ctor
->expr
->value
.function
.actual
2027 = a
= gfc_get_actual_arglist ();
2030 a
->next
= gfc_get_actual_arglist ();
2035 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2037 a
->expr
= gfc_copy_expr (b
->expr
);
2042 /* Simplify the function calls. If the simplification fails, the
2043 error will be flagged up down-stream or the library will deal
2045 gfc_simplify_expr (new_ctor
->expr
, 0);
2047 for (i
= 0; i
< n
; i
++)
2049 args
[i
] = gfc_constructor_next (args
[i
]);
2051 for (i
= 1; i
< n
; i
++)
2052 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2053 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2059 /* Free "expr" but not the pointers it contains. */
2061 gfc_free_expr (old
);
2065 gfc_error_now ("elemental function arguments at %C are not compliant");
2068 gfc_free_expr (expr
);
2069 gfc_free_expr (old
);
2075 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2077 gfc_expr
*op1
= e
->value
.op
.op1
;
2078 gfc_expr
*op2
= e
->value
.op
.op2
;
2080 if (!(*check_function
)(op1
))
2083 switch (e
->value
.op
.op
)
2085 case INTRINSIC_UPLUS
:
2086 case INTRINSIC_UMINUS
:
2087 if (!numeric_type (et0 (op1
)))
2092 case INTRINSIC_EQ_OS
:
2094 case INTRINSIC_NE_OS
:
2096 case INTRINSIC_GT_OS
:
2098 case INTRINSIC_GE_OS
:
2100 case INTRINSIC_LT_OS
:
2102 case INTRINSIC_LE_OS
:
2103 if (!(*check_function
)(op2
))
2106 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2107 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2109 gfc_error ("Numeric or CHARACTER operands are required in "
2110 "expression at %L", &e
->where
);
2115 case INTRINSIC_PLUS
:
2116 case INTRINSIC_MINUS
:
2117 case INTRINSIC_TIMES
:
2118 case INTRINSIC_DIVIDE
:
2119 case INTRINSIC_POWER
:
2120 if (!(*check_function
)(op2
))
2123 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2128 case INTRINSIC_CONCAT
:
2129 if (!(*check_function
)(op2
))
2132 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2134 gfc_error ("Concatenation operator in expression at %L "
2135 "must have two CHARACTER operands", &op1
->where
);
2139 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2141 gfc_error ("Concat operator at %L must concatenate strings of the "
2142 "same kind", &e
->where
);
2149 if (et0 (op1
) != BT_LOGICAL
)
2151 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2152 "operand", &op1
->where
);
2161 case INTRINSIC_NEQV
:
2162 if (!(*check_function
)(op2
))
2165 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2167 gfc_error ("LOGICAL operands are required in expression at %L",
2174 case INTRINSIC_PARENTHESES
:
2178 gfc_error ("Only intrinsic operators can be used in expression at %L",
2186 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2191 /* F2003, 7.1.7 (3): In init expression, allocatable components
2192 must not be data-initialized. */
2194 check_alloc_comp_init (gfc_expr
*e
)
2196 gfc_component
*comp
;
2197 gfc_constructor
*ctor
;
2199 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2200 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2202 for (comp
= e
->ts
.u
.derived
->components
,
2203 ctor
= gfc_constructor_first (e
->value
.constructor
);
2204 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2206 if (comp
->attr
.allocatable
2207 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2209 gfc_error("Invalid initialization expression for ALLOCATABLE "
2210 "component '%s' in structure constructor at %L",
2211 comp
->name
, &ctor
->expr
->where
);
2220 check_init_expr_arguments (gfc_expr
*e
)
2222 gfc_actual_arglist
*ap
;
2224 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2225 if (!gfc_check_init_expr (ap
->expr
))
2231 static bool check_restricted (gfc_expr
*);
2233 /* F95, 7.1.6.1, Initialization expressions, (7)
2234 F2003, 7.1.7 Initialization expression, (8) */
2237 check_inquiry (gfc_expr
*e
, int not_restricted
)
2240 const char *const *functions
;
2242 static const char *const inquiry_func_f95
[] = {
2243 "lbound", "shape", "size", "ubound",
2244 "bit_size", "len", "kind",
2245 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2246 "precision", "radix", "range", "tiny",
2250 static const char *const inquiry_func_f2003
[] = {
2251 "lbound", "shape", "size", "ubound",
2252 "bit_size", "len", "kind",
2253 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2254 "precision", "radix", "range", "tiny",
2259 gfc_actual_arglist
*ap
;
2261 if (!e
->value
.function
.isym
2262 || !e
->value
.function
.isym
->inquiry
)
2265 /* An undeclared parameter will get us here (PR25018). */
2266 if (e
->symtree
== NULL
)
2269 if (e
->symtree
->n
.sym
->from_intmod
)
2271 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2272 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2273 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2276 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2277 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2282 name
= e
->symtree
->n
.sym
->name
;
2284 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2285 ? inquiry_func_f2003
: inquiry_func_f95
;
2287 for (i
= 0; functions
[i
]; i
++)
2288 if (strcmp (functions
[i
], name
) == 0)
2291 if (functions
[i
] == NULL
)
2295 /* At this point we have an inquiry function with a variable argument. The
2296 type of the variable might be undefined, but we need it now, because the
2297 arguments of these functions are not allowed to be undefined. */
2299 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2304 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2306 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2307 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2310 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2313 /* Assumed character length will not reduce to a constant expression
2314 with LEN, as required by the standard. */
2315 if (i
== 5 && not_restricted
2316 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2317 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2318 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2320 gfc_error ("Assumed or deferred character length variable '%s' "
2321 " in constant expression at %L",
2322 ap
->expr
->symtree
->n
.sym
->name
,
2326 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2329 if (not_restricted
== 0
2330 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2331 && !check_restricted (ap
->expr
))
2334 if (not_restricted
== 0
2335 && ap
->expr
->expr_type
== EXPR_VARIABLE
2336 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2337 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2345 /* F95, 7.1.6.1, Initialization expressions, (5)
2346 F2003, 7.1.7 Initialization expression, (5) */
2349 check_transformational (gfc_expr
*e
)
2351 static const char * const trans_func_f95
[] = {
2352 "repeat", "reshape", "selected_int_kind",
2353 "selected_real_kind", "transfer", "trim", NULL
2356 static const char * const trans_func_f2003
[] = {
2357 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2358 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2359 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2360 "trim", "unpack", NULL
2365 const char *const *functions
;
2367 if (!e
->value
.function
.isym
2368 || !e
->value
.function
.isym
->transformational
)
2371 name
= e
->symtree
->n
.sym
->name
;
2373 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2374 ? trans_func_f2003
: trans_func_f95
;
2376 /* NULL() is dealt with below. */
2377 if (strcmp ("null", name
) == 0)
2380 for (i
= 0; functions
[i
]; i
++)
2381 if (strcmp (functions
[i
], name
) == 0)
2384 if (functions
[i
] == NULL
)
2386 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2387 "in an initialization expression", name
, &e
->where
);
2391 return check_init_expr_arguments (e
);
2395 /* F95, 7.1.6.1, Initialization expressions, (6)
2396 F2003, 7.1.7 Initialization expression, (6) */
2399 check_null (gfc_expr
*e
)
2401 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2404 return check_init_expr_arguments (e
);
2409 check_elemental (gfc_expr
*e
)
2411 if (!e
->value
.function
.isym
2412 || !e
->value
.function
.isym
->elemental
)
2415 if (e
->ts
.type
!= BT_INTEGER
2416 && e
->ts
.type
!= BT_CHARACTER
2417 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2418 "initialization expression at %L", &e
->where
))
2421 return check_init_expr_arguments (e
);
2426 check_conversion (gfc_expr
*e
)
2428 if (!e
->value
.function
.isym
2429 || !e
->value
.function
.isym
->conversion
)
2432 return check_init_expr_arguments (e
);
2436 /* Verify that an expression is an initialization expression. A side
2437 effect is that the expression tree is reduced to a single constant
2438 node if all goes well. This would normally happen when the
2439 expression is constructed but function references are assumed to be
2440 intrinsics in the context of initialization expressions. If
2441 false is returned an error message has been generated. */
2444 gfc_check_init_expr (gfc_expr
*e
)
2452 switch (e
->expr_type
)
2455 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2457 t
= gfc_simplify_expr (e
, 0);
2465 gfc_intrinsic_sym
* isym
;
2468 sym
= e
->symtree
->n
.sym
;
2469 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2470 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2472 gfc_error ("Function '%s' in initialization expression at %L "
2473 "must be an intrinsic function",
2474 e
->symtree
->n
.sym
->name
, &e
->where
);
2478 if ((m
= check_conversion (e
)) == MATCH_NO
2479 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2480 && (m
= check_null (e
)) == MATCH_NO
2481 && (m
= check_transformational (e
)) == MATCH_NO
2482 && (m
= check_elemental (e
)) == MATCH_NO
)
2484 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2485 "in an initialization expression",
2486 e
->symtree
->n
.sym
->name
, &e
->where
);
2490 if (m
== MATCH_ERROR
)
2493 /* Try to scalarize an elemental intrinsic function that has an
2495 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2496 if (isym
&& isym
->elemental
2497 && (t
= scalarize_intrinsic_call(e
)))
2502 t
= gfc_simplify_expr (e
, 0);
2509 if (gfc_check_iter_variable (e
))
2512 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2514 /* A PARAMETER shall not be used to define itself, i.e.
2515 REAL, PARAMETER :: x = transfer(0, x)
2517 if (!e
->symtree
->n
.sym
->value
)
2519 gfc_error("PARAMETER '%s' is used at %L before its definition "
2520 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2524 t
= simplify_parameter_variable (e
, 0);
2529 if (gfc_in_match_data ())
2534 if (e
->symtree
->n
.sym
->as
)
2536 switch (e
->symtree
->n
.sym
->as
->type
)
2538 case AS_ASSUMED_SIZE
:
2539 gfc_error ("Assumed size array '%s' at %L is not permitted "
2540 "in an initialization expression",
2541 e
->symtree
->n
.sym
->name
, &e
->where
);
2544 case AS_ASSUMED_SHAPE
:
2545 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2546 "in an initialization expression",
2547 e
->symtree
->n
.sym
->name
, &e
->where
);
2551 gfc_error ("Deferred array '%s' at %L is not permitted "
2552 "in an initialization expression",
2553 e
->symtree
->n
.sym
->name
, &e
->where
);
2557 gfc_error ("Array '%s' at %L is a variable, which does "
2558 "not reduce to a constant expression",
2559 e
->symtree
->n
.sym
->name
, &e
->where
);
2567 gfc_error ("Parameter '%s' at %L has not been declared or is "
2568 "a variable, which does not reduce to a constant "
2569 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2578 case EXPR_SUBSTRING
:
2579 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2583 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2585 t
= gfc_simplify_expr (e
, 0);
2589 case EXPR_STRUCTURE
:
2590 t
= e
->ts
.is_iso_c
? true : false;
2594 t
= check_alloc_comp_init (e
);
2598 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2605 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2609 t
= gfc_expand_constructor (e
, true);
2613 t
= gfc_check_constructor_type (e
);
2617 gfc_internal_error ("check_init_expr(): Unknown expression type");
2623 /* Reduces a general expression to an initialization expression (a constant).
2624 This used to be part of gfc_match_init_expr.
2625 Note that this function doesn't free the given expression on false. */
2628 gfc_reduce_init_expr (gfc_expr
*expr
)
2632 gfc_init_expr_flag
= true;
2633 t
= gfc_resolve_expr (expr
);
2635 t
= gfc_check_init_expr (expr
);
2636 gfc_init_expr_flag
= false;
2641 if (expr
->expr_type
== EXPR_ARRAY
)
2643 if (!gfc_check_constructor_type (expr
))
2645 if (!gfc_expand_constructor (expr
, true))
2653 /* Match an initialization expression. We work by first matching an
2654 expression, then reducing it to a constant. */
2657 gfc_match_init_expr (gfc_expr
**result
)
2665 gfc_init_expr_flag
= true;
2667 m
= gfc_match_expr (&expr
);
2670 gfc_init_expr_flag
= false;
2674 t
= gfc_reduce_init_expr (expr
);
2677 gfc_free_expr (expr
);
2678 gfc_init_expr_flag
= false;
2683 gfc_init_expr_flag
= false;
2689 /* Given an actual argument list, test to see that each argument is a
2690 restricted expression and optionally if the expression type is
2691 integer or character. */
2694 restricted_args (gfc_actual_arglist
*a
)
2696 for (; a
; a
= a
->next
)
2698 if (!check_restricted (a
->expr
))
2706 /************* Restricted/specification expressions *************/
2709 /* Make sure a non-intrinsic function is a specification function. */
2712 external_spec_function (gfc_expr
*e
)
2716 f
= e
->value
.function
.esym
;
2718 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2720 gfc_error ("Specification function '%s' at %L cannot be a statement "
2721 "function", f
->name
, &e
->where
);
2725 if (f
->attr
.proc
== PROC_INTERNAL
)
2727 gfc_error ("Specification function '%s' at %L cannot be an internal "
2728 "function", f
->name
, &e
->where
);
2732 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2734 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2739 if (f
->attr
.recursive
)
2741 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2742 f
->name
, &e
->where
);
2746 return restricted_args (e
->value
.function
.actual
);
2750 /* Check to see that a function reference to an intrinsic is a
2751 restricted expression. */
2754 restricted_intrinsic (gfc_expr
*e
)
2756 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2757 if (check_inquiry (e
, 0) == MATCH_YES
)
2760 return restricted_args (e
->value
.function
.actual
);
2764 /* Check the expressions of an actual arglist. Used by check_restricted. */
2767 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2769 for (; arg
; arg
= arg
->next
)
2770 if (!checker (arg
->expr
))
2777 /* Check the subscription expressions of a reference chain with a checking
2778 function; used by check_restricted. */
2781 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2791 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2793 if (!checker (ref
->u
.ar
.start
[dim
]))
2795 if (!checker (ref
->u
.ar
.end
[dim
]))
2797 if (!checker (ref
->u
.ar
.stride
[dim
]))
2803 /* Nothing needed, just proceed to next reference. */
2807 if (!checker (ref
->u
.ss
.start
))
2809 if (!checker (ref
->u
.ss
.end
))
2818 return check_references (ref
->next
, checker
);
2822 /* Verify that an expression is a restricted expression. Like its
2823 cousin check_init_expr(), an error message is generated if we
2827 check_restricted (gfc_expr
*e
)
2835 switch (e
->expr_type
)
2838 t
= check_intrinsic_op (e
, check_restricted
);
2840 t
= gfc_simplify_expr (e
, 0);
2845 if (e
->value
.function
.esym
)
2847 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2849 t
= external_spec_function (e
);
2853 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2856 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2859 t
= restricted_intrinsic (e
);
2864 sym
= e
->symtree
->n
.sym
;
2867 /* If a dummy argument appears in a context that is valid for a
2868 restricted expression in an elemental procedure, it will have
2869 already been simplified away once we get here. Therefore we
2870 don't need to jump through hoops to distinguish valid from
2872 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2873 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2875 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2876 sym
->name
, &e
->where
);
2880 if (sym
->attr
.optional
)
2882 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2883 sym
->name
, &e
->where
);
2887 if (sym
->attr
.intent
== INTENT_OUT
)
2889 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2890 sym
->name
, &e
->where
);
2894 /* Check reference chain if any. */
2895 if (!check_references (e
->ref
, &check_restricted
))
2898 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2899 processed in resolve.c(resolve_formal_arglist). This is done so
2900 that host associated dummy array indices are accepted (PR23446).
2901 This mechanism also does the same for the specification expressions
2902 of array-valued functions. */
2904 || sym
->attr
.in_common
2905 || sym
->attr
.use_assoc
2907 || sym
->attr
.implied_index
2908 || sym
->attr
.flavor
== FL_PARAMETER
2909 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2910 || (sym
->ns
&& gfc_current_ns
->parent
2911 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2912 || (sym
->ns
->proc_name
!= NULL
2913 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2914 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2920 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2921 sym
->name
, &e
->where
);
2922 /* Prevent a repetition of the error. */
2931 case EXPR_SUBSTRING
:
2932 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2936 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2938 t
= gfc_simplify_expr (e
, 0);
2942 case EXPR_STRUCTURE
:
2943 t
= gfc_check_constructor (e
, check_restricted
);
2947 t
= gfc_check_constructor (e
, check_restricted
);
2951 gfc_internal_error ("check_restricted(): Unknown expression type");
2958 /* Check to see that an expression is a specification expression. If
2959 we return false, an error has been generated. */
2962 gfc_specification_expr (gfc_expr
*e
)
2964 gfc_component
*comp
;
2969 if (e
->ts
.type
!= BT_INTEGER
)
2971 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2972 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2976 comp
= gfc_get_proc_ptr_comp (e
);
2977 if (e
->expr_type
== EXPR_FUNCTION
2978 && !e
->value
.function
.isym
2979 && !e
->value
.function
.esym
2980 && !gfc_pure (e
->symtree
->n
.sym
)
2981 && (!comp
|| !comp
->attr
.pure
))
2983 gfc_error ("Function '%s' at %L must be PURE",
2984 e
->symtree
->n
.sym
->name
, &e
->where
);
2985 /* Prevent repeat error messages. */
2986 e
->symtree
->n
.sym
->attr
.pure
= 1;
2992 gfc_error ("Expression at %L must be scalar", &e
->where
);
2996 if (!gfc_simplify_expr (e
, 0))
2999 return check_restricted (e
);
3003 /************** Expression conformance checks. *************/
3005 /* Given two expressions, make sure that the arrays are conformable. */
3008 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3010 int op1_flag
, op2_flag
, d
;
3011 mpz_t op1_size
, op2_size
;
3017 if (op1
->rank
== 0 || op2
->rank
== 0)
3020 va_start (argp
, optype_msgid
);
3021 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3024 if (op1
->rank
!= op2
->rank
)
3026 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3027 op1
->rank
, op2
->rank
, &op1
->where
);
3033 for (d
= 0; d
< op1
->rank
; d
++)
3035 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3036 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3038 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3040 gfc_error ("Different shape for %s at %L on dimension %d "
3041 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3042 (int) mpz_get_si (op1_size
),
3043 (int) mpz_get_si (op2_size
));
3049 mpz_clear (op1_size
);
3051 mpz_clear (op2_size
);
3061 /* Given an assignable expression and an arbitrary expression, make
3062 sure that the assignment can take place. */
3065 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3071 sym
= lvalue
->symtree
->n
.sym
;
3073 /* See if this is the component or subcomponent of a pointer. */
3074 has_pointer
= sym
->attr
.pointer
;
3075 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3076 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3082 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3083 variable local to a function subprogram. Its existence begins when
3084 execution of the function is initiated and ends when execution of the
3085 function is terminated...
3086 Therefore, the left hand side is no longer a variable, when it is: */
3087 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3088 && !sym
->attr
.external
)
3093 /* (i) Use associated; */
3094 if (sym
->attr
.use_assoc
)
3097 /* (ii) The assignment is in the main program; or */
3098 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3101 /* (iii) A module or internal procedure... */
3102 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3103 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3104 && gfc_current_ns
->parent
3105 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3106 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3107 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3109 /* ... that is not a function... */
3110 if (!gfc_current_ns
->proc_name
->attr
.function
)
3113 /* ... or is not an entry and has a different name. */
3114 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3118 /* (iv) Host associated and not the function symbol or the
3119 parent result. This picks up sibling references, which
3120 cannot be entries. */
3121 if (!sym
->attr
.entry
3122 && sym
->ns
== gfc_current_ns
->parent
3123 && sym
!= gfc_current_ns
->proc_name
3124 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3129 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3134 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3136 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3137 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3141 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3143 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3148 if (rvalue
->expr_type
== EXPR_NULL
)
3150 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3151 && lvalue
->symtree
->n
.sym
->attr
.data
)
3155 gfc_error ("NULL appears on right-hand side in assignment at %L",
3161 /* This is possibly a typo: x = f() instead of x => f(). */
3162 if (gfc_option
.warn_surprising
3163 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3164 gfc_warning ("POINTER-valued function appears on right-hand side of "
3165 "assignment at %L", &rvalue
->where
);
3167 /* Check size of array assignments. */
3168 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3169 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3172 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3173 && lvalue
->symtree
->n
.sym
->attr
.data
3174 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3175 "initialize non-integer variable '%s'",
3176 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3178 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3179 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3180 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3184 /* Handle the case of a BOZ literal on the RHS. */
3185 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3188 if (gfc_option
.warn_surprising
)
3189 gfc_warning ("BOZ literal at %L is bitwise transferred "
3190 "non-integer symbol '%s'", &rvalue
->where
,
3191 lvalue
->symtree
->n
.sym
->name
);
3192 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3194 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3196 if (rc
== ARITH_UNDERFLOW
)
3197 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3198 ". This check can be disabled with the option "
3199 "-fno-range-check", &rvalue
->where
);
3200 else if (rc
== ARITH_OVERFLOW
)
3201 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3202 ". This check can be disabled with the option "
3203 "-fno-range-check", &rvalue
->where
);
3204 else if (rc
== ARITH_NAN
)
3205 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3206 ". This check can be disabled with the option "
3207 "-fno-range-check", &rvalue
->where
);
3212 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3213 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3214 will warn anyway, so there is no need to to so here. */
3216 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3217 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3219 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3221 /* As a special bonus, don't warn about REAL rvalues which are not
3222 changed by the conversion if -Wconversion is specified. */
3223 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3225 /* Calculate the difference between the constant and the rounded
3226 value and check it against zero. */
3228 gfc_set_model_kind (lvalue
->ts
.kind
);
3230 gfc_set_model_kind (rvalue
->ts
.kind
);
3233 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3234 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3236 if (!mpfr_zero_p (diff
))
3237 gfc_warning ("Change of value in conversion from "
3238 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3239 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3245 gfc_warning ("Possible change of value in conversion from %s "
3246 "to %s at %L",gfc_typename (&rvalue
->ts
),
3247 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3250 else if (gfc_option
.warn_conversion_extra
3251 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3253 gfc_warning ("Conversion from %s to %s at %L",
3254 gfc_typename (&rvalue
->ts
),
3255 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3259 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3262 /* Only DATA Statements come here. */
3265 /* Numeric can be converted to any other numeric. And Hollerith can be
3266 converted to any other type. */
3267 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3268 || rvalue
->ts
.type
== BT_HOLLERITH
)
3271 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3274 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3275 "conversion of %s to %s", &lvalue
->where
,
3276 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3281 /* Assignment is the only case where character variables of different
3282 kind values can be converted into one another. */
3283 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3285 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3286 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3291 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3295 /* Check that a pointer assignment is OK. We first check lvalue, and
3296 we only check rvalue if it's not an assignment to NULL() or a
3297 NULLIFY statement. */
3300 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3302 symbol_attribute attr
, lhs_attr
;
3304 bool is_pure
, is_implicit_pure
, rank_remap
;
3307 lhs_attr
= gfc_expr_attr (lvalue
);
3308 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3310 gfc_error ("Pointer assignment target is not a POINTER at %L",
3315 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3316 && !lhs_attr
.proc_pointer
)
3318 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3319 "l-value since it is a procedure",
3320 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3324 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3327 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3329 if (ref
->type
== REF_COMPONENT
)
3330 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3332 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3336 if (ref
->u
.ar
.type
== AR_FULL
)
3339 if (ref
->u
.ar
.type
!= AR_SECTION
)
3341 gfc_error ("Expected bounds specification for '%s' at %L",
3342 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3346 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3347 "for '%s' in pointer assignment at %L",
3348 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3351 /* When bounds are given, all lbounds are necessary and either all
3352 or none of the upper bounds; no strides are allowed. If the
3353 upper bounds are present, we may do rank remapping. */
3354 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3356 if (!ref
->u
.ar
.start
[dim
]
3357 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3359 gfc_error ("Lower bound has to be present at %L",
3363 if (ref
->u
.ar
.stride
[dim
])
3365 gfc_error ("Stride must not be present at %L",
3371 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3374 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3375 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3377 gfc_error ("Either all or none of the upper bounds"
3378 " must be specified at %L", &lvalue
->where
);
3386 is_pure
= gfc_pure (NULL
);
3387 is_implicit_pure
= gfc_implicit_pure (NULL
);
3389 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3390 kind, etc for lvalue and rvalue must match, and rvalue must be a
3391 pure variable if we're in a pure function. */
3392 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3395 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3396 if (lvalue
->expr_type
== EXPR_VARIABLE
3397 && gfc_is_coindexed (lvalue
))
3400 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3401 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3403 gfc_error ("Pointer object at %L shall not have a coindex",
3409 /* Checks on rvalue for procedure pointer assignments. */
3414 gfc_component
*comp
;
3417 attr
= gfc_expr_attr (rvalue
);
3418 if (!((rvalue
->expr_type
== EXPR_NULL
)
3419 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3420 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3421 || (rvalue
->expr_type
== EXPR_VARIABLE
3422 && attr
.flavor
== FL_PROCEDURE
)))
3424 gfc_error ("Invalid procedure pointer assignment at %L",
3428 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3430 /* Check for intrinsics. */
3431 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3432 if (!sym
->attr
.intrinsic
3433 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3434 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3436 sym
->attr
.intrinsic
= 1;
3437 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3438 attr
= gfc_expr_attr (rvalue
);
3440 /* Check for result of embracing function. */
3441 if (sym
->attr
.function
&& sym
->result
== sym
)
3445 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3446 if (sym
== ns
->proc_name
)
3448 gfc_error ("Function result '%s' is invalid as proc-target "
3449 "in procedure pointer assignment at %L",
3450 sym
->name
, &rvalue
->where
);
3457 gfc_error ("Abstract interface '%s' is invalid "
3458 "in procedure pointer assignment at %L",
3459 rvalue
->symtree
->name
, &rvalue
->where
);
3462 /* Check for F08:C729. */
3463 if (attr
.flavor
== FL_PROCEDURE
)
3465 if (attr
.proc
== PROC_ST_FUNCTION
)
3467 gfc_error ("Statement function '%s' is invalid "
3468 "in procedure pointer assignment at %L",
3469 rvalue
->symtree
->name
, &rvalue
->where
);
3472 if (attr
.proc
== PROC_INTERNAL
&&
3473 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure '%s' "
3474 "is invalid in procedure pointer assignment "
3475 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3477 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3478 attr
.subroutine
) == 0)
3480 gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
3481 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3485 /* Check for F08:C730. */
3486 if (attr
.elemental
&& !attr
.intrinsic
)
3488 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3489 "in procedure pointer assignment at %L",
3490 rvalue
->symtree
->name
, &rvalue
->where
);
3494 /* Ensure that the calling convention is the same. As other attributes
3495 such as DLLEXPORT may differ, one explicitly only tests for the
3496 calling conventions. */
3497 if (rvalue
->expr_type
== EXPR_VARIABLE
3498 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3499 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3501 symbol_attribute calls
;
3504 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3505 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3506 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3508 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3509 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3511 gfc_error ("Mismatch in the procedure pointer assignment "
3512 "at %L: mismatch in the calling convention",
3518 comp
= gfc_get_proc_ptr_comp (lvalue
);
3520 s1
= comp
->ts
.interface
;
3523 s1
= lvalue
->symtree
->n
.sym
;
3524 if (s1
->ts
.interface
)
3525 s1
= s1
->ts
.interface
;
3528 comp
= gfc_get_proc_ptr_comp (rvalue
);
3531 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3533 s2
= comp
->ts
.interface
->result
;
3538 s2
= comp
->ts
.interface
;
3542 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3544 s2
= rvalue
->symtree
->n
.sym
->result
;
3549 s2
= rvalue
->symtree
->n
.sym
;
3553 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3554 s2
= s2
->ts
.interface
;
3556 if (s1
== s2
|| !s1
|| !s2
)
3559 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3560 err
, sizeof(err
), NULL
, NULL
))
3562 gfc_error ("Interface mismatch in procedure pointer assignment "
3563 "at %L: %s", &rvalue
->where
, err
);
3567 if (!gfc_compare_interfaces (s2
, s1
, name
, 0, 1,
3568 err
, sizeof(err
), NULL
, NULL
))
3570 gfc_error ("Interface mismatch in procedure pointer assignment "
3571 "at %L: %s", &rvalue
->where
, err
);
3578 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3580 /* Check for F03:C717. */
3581 if (UNLIMITED_POLY (rvalue
)
3582 && !(UNLIMITED_POLY (lvalue
)
3583 || (lvalue
->ts
.type
== BT_DERIVED
3584 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3585 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3586 gfc_error ("Data-pointer-object &L must be unlimited "
3587 "polymorphic, a sequence derived type or of a "
3588 "type with the BIND attribute assignment at %L "
3589 "to be compatible with an unlimited polymorphic "
3590 "target", &lvalue
->where
);
3592 gfc_error ("Different types in pointer assignment at %L; "
3593 "attempted assignment of %s to %s", &lvalue
->where
,
3594 gfc_typename (&rvalue
->ts
),
3595 gfc_typename (&lvalue
->ts
));
3599 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3601 gfc_error ("Different kind type parameters in pointer "
3602 "assignment at %L", &lvalue
->where
);
3606 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3608 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3612 /* Make sure the vtab is present. */
3613 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3614 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3615 else if (UNLIMITED_POLY (lvalue
) && !UNLIMITED_POLY (rvalue
))
3616 gfc_find_intrinsic_vtab (&rvalue
->ts
);
3618 /* Check rank remapping. */
3623 /* If this can be determined, check that the target must be at least as
3624 large as the pointer assigned to it is. */
3625 if (gfc_array_size (lvalue
, &lsize
)
3626 && gfc_array_size (rvalue
, &rsize
)
3627 && mpz_cmp (rsize
, lsize
) < 0)
3629 gfc_error ("Rank remapping target is smaller than size of the"
3630 " pointer (%ld < %ld) at %L",
3631 mpz_get_si (rsize
), mpz_get_si (lsize
),
3636 /* The target must be either rank one or it must be simply contiguous
3637 and F2008 must be allowed. */
3638 if (rvalue
->rank
!= 1)
3640 if (!gfc_is_simply_contiguous (rvalue
, true))
3642 gfc_error ("Rank remapping target must be rank 1 or"
3643 " simply contiguous at %L", &rvalue
->where
);
3646 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3647 "rank 1 at %L", &rvalue
->where
))
3652 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3653 if (rvalue
->expr_type
== EXPR_NULL
)
3656 if (lvalue
->ts
.type
== BT_CHARACTER
)
3658 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3663 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3664 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3666 attr
= gfc_expr_attr (rvalue
);
3668 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3670 gfc_error ("Target expression in pointer assignment "
3671 "at %L must deliver a pointer result",
3676 if (!attr
.target
&& !attr
.pointer
)
3678 gfc_error ("Pointer assignment target is neither TARGET "
3679 "nor POINTER at %L", &rvalue
->where
);
3683 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3685 gfc_error ("Bad target in pointer assignment in PURE "
3686 "procedure at %L", &rvalue
->where
);
3689 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3690 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3693 if (gfc_has_vector_index (rvalue
))
3695 gfc_error ("Pointer assignment with vector subscript "
3696 "on rhs at %L", &rvalue
->where
);
3700 if (attr
.is_protected
&& attr
.use_assoc
3701 && !(attr
.pointer
|| attr
.proc_pointer
))
3703 gfc_error ("Pointer assignment target has PROTECTED "
3704 "attribute at %L", &rvalue
->where
);
3708 /* F2008, C725. For PURE also C1283. */
3709 if (rvalue
->expr_type
== EXPR_VARIABLE
3710 && gfc_is_coindexed (rvalue
))
3713 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3714 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3716 gfc_error ("Data target at %L shall not have a coindex",
3722 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3723 if (gfc_option
.warn_target_lifetime
3724 && rvalue
->expr_type
== EXPR_VARIABLE
3725 && !rvalue
->symtree
->n
.sym
->attr
.save
3726 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3727 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3728 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3729 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3734 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3735 || lvalue
->symtree
->n
.sym
->attr
.result
3736 || lvalue
->symtree
->n
.sym
->attr
.function
3737 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3738 && lvalue
->symtree
->n
.sym
->ns
3739 != rvalue
->symtree
->n
.sym
->ns
)
3740 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3741 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3743 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3744 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3745 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3746 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3747 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3749 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3753 gfc_warning ("Pointer at %L in pointer assignment might outlive the "
3754 "pointer target", &lvalue
->where
);
3761 /* Relative of gfc_check_assign() except that the lvalue is a single
3762 symbol. Used for initialization assignments. */
3765 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3769 bool pointer
, proc_pointer
;
3771 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3773 lvalue
.expr_type
= EXPR_VARIABLE
;
3774 lvalue
.ts
= sym
->ts
;
3776 lvalue
.rank
= sym
->as
->rank
;
3777 lvalue
.symtree
= XCNEW (gfc_symtree
);
3778 lvalue
.symtree
->n
.sym
= sym
;
3779 lvalue
.where
= sym
->declared_at
;
3783 lvalue
.ref
= gfc_get_ref ();
3784 lvalue
.ref
->type
= REF_COMPONENT
;
3785 lvalue
.ref
->u
.c
.component
= comp
;
3786 lvalue
.ref
->u
.c
.sym
= sym
;
3787 lvalue
.ts
= comp
->ts
;
3788 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3789 lvalue
.where
= comp
->loc
;
3790 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3791 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3792 proc_pointer
= comp
->attr
.proc_pointer
;
3796 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3797 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3798 proc_pointer
= sym
->attr
.proc_pointer
;
3801 if (pointer
|| proc_pointer
)
3802 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3804 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3806 free (lvalue
.symtree
);
3811 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3813 /* F08:C461. Additional checks for pointer initialization. */
3814 symbol_attribute attr
;
3815 attr
= gfc_expr_attr (rvalue
);
3816 if (attr
.allocatable
)
3818 gfc_error ("Pointer initialization target at %L "
3819 "must not be ALLOCATABLE", &rvalue
->where
);
3822 if (!attr
.target
|| attr
.pointer
)
3824 gfc_error ("Pointer initialization target at %L "
3825 "must have the TARGET attribute", &rvalue
->where
);
3829 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3830 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3831 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3833 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3834 attr
.save
= SAVE_IMPLICIT
;
3839 gfc_error ("Pointer initialization target at %L "
3840 "must have the SAVE attribute", &rvalue
->where
);
3845 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3847 /* F08:C1220. Additional checks for procedure pointer initialization. */
3848 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3849 if (attr
.proc_pointer
)
3851 gfc_error ("Procedure pointer initialization target at %L "
3852 "may not be a procedure pointer", &rvalue
->where
);
3861 /* Check for default initializer; sym->value is not enough
3862 as it is also set for EXPR_NULL of allocatables. */
3865 gfc_has_default_initializer (gfc_symbol
*der
)
3869 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3870 for (c
= der
->components
; c
; c
= c
->next
)
3871 if (c
->ts
.type
== BT_DERIVED
)
3873 if (!c
->attr
.pointer
3874 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3876 if (c
->attr
.pointer
&& c
->initializer
)
3889 /* Get an expression for a default initializer. */
3892 gfc_default_initializer (gfc_typespec
*ts
)
3895 gfc_component
*comp
;
3897 /* See if we have a default initializer in this, but not in nested
3898 types (otherwise we could use gfc_has_default_initializer()). */
3899 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3900 if (comp
->initializer
|| comp
->attr
.allocatable
3901 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3902 && CLASS_DATA (comp
)->attr
.allocatable
))
3908 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3909 &ts
->u
.derived
->declared_at
);
3912 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3914 gfc_constructor
*ctor
= gfc_constructor_get();
3916 if (comp
->initializer
)
3918 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3919 if ((comp
->ts
.type
!= comp
->initializer
->ts
.type
3920 || comp
->ts
.kind
!= comp
->initializer
->ts
.kind
)
3921 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
3922 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
3925 if (comp
->attr
.allocatable
3926 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3928 ctor
->expr
= gfc_get_expr ();
3929 ctor
->expr
->expr_type
= EXPR_NULL
;
3930 ctor
->expr
->ts
= comp
->ts
;
3933 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3940 /* Given a symbol, create an expression node with that symbol as a
3941 variable. If the symbol is array valued, setup a reference of the
3945 gfc_get_variable_expr (gfc_symtree
*var
)
3949 e
= gfc_get_expr ();
3950 e
->expr_type
= EXPR_VARIABLE
;
3952 e
->ts
= var
->n
.sym
->ts
;
3954 if ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
3955 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
3956 && CLASS_DATA (var
->n
.sym
)->as
))
3958 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
3959 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
3960 e
->ref
= gfc_get_ref ();
3961 e
->ref
->type
= REF_ARRAY
;
3962 e
->ref
->u
.ar
.type
= AR_FULL
;
3963 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
3964 ? CLASS_DATA (var
->n
.sym
)->as
3972 /* Adds a full array reference to an expression, as needed. */
3975 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
3978 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3983 ref
->next
= gfc_get_ref ();
3988 e
->ref
= gfc_get_ref ();
3991 ref
->type
= REF_ARRAY
;
3992 ref
->u
.ar
.type
= AR_FULL
;
3993 ref
->u
.ar
.dimen
= e
->rank
;
3994 ref
->u
.ar
.where
= e
->where
;
4000 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4003 lval
= gfc_get_expr ();
4004 lval
->expr_type
= EXPR_VARIABLE
;
4005 lval
->where
= sym
->declared_at
;
4007 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4009 /* It will always be a full array. */
4010 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
4012 gfc_add_full_array_ref (lval
, sym
->ts
.type
== BT_CLASS
?
4013 CLASS_DATA (sym
)->as
: sym
->as
);
4018 /* Returns the array_spec of a full array expression. A NULL is
4019 returned otherwise. */
4021 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4026 if (expr
->rank
== 0)
4029 /* Follow any component references. */
4030 if (expr
->expr_type
== EXPR_VARIABLE
4031 || expr
->expr_type
== EXPR_CONSTANT
)
4033 as
= expr
->symtree
->n
.sym
->as
;
4034 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4039 as
= ref
->u
.c
.component
->as
;
4047 switch (ref
->u
.ar
.type
)
4070 /* General expression traversal function. */
4073 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4074 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4079 gfc_actual_arglist
*args
;
4086 if ((*func
) (expr
, sym
, &f
))
4089 if (expr
->ts
.type
== BT_CHARACTER
4091 && expr
->ts
.u
.cl
->length
4092 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4093 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4096 switch (expr
->expr_type
)
4101 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4103 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4111 case EXPR_SUBSTRING
:
4114 case EXPR_STRUCTURE
:
4116 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4117 c
; c
= gfc_constructor_next (c
))
4119 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4123 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4125 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4127 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4129 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4136 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4138 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4154 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4156 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4158 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4160 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4166 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4168 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4173 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4174 && ref
->u
.c
.component
->ts
.u
.cl
4175 && ref
->u
.c
.component
->ts
.u
.cl
->length
4176 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4178 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4182 if (ref
->u
.c
.component
->as
)
4183 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4184 + ref
->u
.c
.component
->as
->corank
; i
++)
4186 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4189 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4203 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4206 expr_set_symbols_referenced (gfc_expr
*expr
,
4207 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4208 int *f ATTRIBUTE_UNUSED
)
4210 if (expr
->expr_type
!= EXPR_VARIABLE
)
4212 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4217 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4219 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4223 /* Determine if an expression is a procedure pointer component and return
4224 the component in that case. Otherwise return NULL. */
4227 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4231 if (!expr
|| !expr
->ref
)
4238 if (ref
->type
== REF_COMPONENT
4239 && ref
->u
.c
.component
->attr
.proc_pointer
)
4240 return ref
->u
.c
.component
;
4246 /* Determine if an expression is a procedure pointer component. */
4249 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4251 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4255 /* Walk an expression tree and check each variable encountered for being typed.
4256 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4257 mode as is a basic arithmetic expression using those; this is for things in
4260 INTEGER :: arr(n), n
4261 INTEGER :: arr(n + 1), n
4263 The namespace is needed for IMPLICIT typing. */
4265 static gfc_namespace
* check_typed_ns
;
4268 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4269 int* f ATTRIBUTE_UNUSED
)
4273 if (e
->expr_type
!= EXPR_VARIABLE
)
4276 gcc_assert (e
->symtree
);
4277 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4284 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4288 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4292 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4293 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4295 if (e
->expr_type
== EXPR_OP
)
4299 gcc_assert (e
->value
.op
.op1
);
4300 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4302 if (t
&& e
->value
.op
.op2
)
4303 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4309 /* Otherwise, walk the expression and do it strictly. */
4310 check_typed_ns
= ns
;
4311 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4313 return error_found
? false : true;
4318 gfc_ref_this_image (gfc_ref
*ref
)
4322 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4324 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4325 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4333 gfc_is_coindexed (gfc_expr
*e
)
4337 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4338 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4339 return !gfc_ref_this_image (ref
);
4345 /* Coarrays are variables with a corank but not being coindexed. However, also
4346 the following is a coarray: A subobject of a coarray is a coarray if it does
4347 not have any cosubscripts, vector subscripts, allocatable component
4348 selection, or pointer component selection. (F2008, 2.4.7) */
4351 gfc_is_coarray (gfc_expr
*e
)
4355 gfc_component
*comp
;
4360 if (e
->expr_type
!= EXPR_VARIABLE
)
4364 sym
= e
->symtree
->n
.sym
;
4366 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4367 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4369 coarray
= sym
->attr
.codimension
;
4371 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4375 comp
= ref
->u
.c
.component
;
4376 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4377 && (CLASS_DATA (comp
)->attr
.class_pointer
4378 || CLASS_DATA (comp
)->attr
.allocatable
))
4381 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4383 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4386 coarray
= comp
->attr
.codimension
;
4394 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4400 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4401 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4412 return coarray
&& !coindexed
;
4417 gfc_get_corank (gfc_expr
*e
)
4422 if (!gfc_is_coarray (e
))
4425 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4426 corank
= e
->ts
.u
.derived
->components
->as
4427 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4429 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4431 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4433 if (ref
->type
== REF_ARRAY
)
4434 corank
= ref
->u
.ar
.as
->corank
;
4435 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4442 /* Check whether the expression has an ultimate allocatable component.
4443 Being itself allocatable does not count. */
4445 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4447 gfc_ref
*ref
, *last
= NULL
;
4449 if (e
->expr_type
!= EXPR_VARIABLE
)
4452 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4453 if (ref
->type
== REF_COMPONENT
)
4456 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4457 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4458 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4459 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4463 if (e
->ts
.type
== BT_CLASS
)
4464 return CLASS_DATA (e
)->attr
.alloc_comp
;
4465 else if (e
->ts
.type
== BT_DERIVED
)
4466 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4472 /* Check whether the expression has an pointer component.
4473 Being itself a pointer does not count. */
4475 gfc_has_ultimate_pointer (gfc_expr
*e
)
4477 gfc_ref
*ref
, *last
= NULL
;
4479 if (e
->expr_type
!= EXPR_VARIABLE
)
4482 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4483 if (ref
->type
== REF_COMPONENT
)
4486 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4487 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4488 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4489 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4493 if (e
->ts
.type
== BT_CLASS
)
4494 return CLASS_DATA (e
)->attr
.pointer_comp
;
4495 else if (e
->ts
.type
== BT_DERIVED
)
4496 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4502 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4503 Note: A scalar is not regarded as "simply contiguous" by the standard.
4504 if bool is not strict, some further checks are done - for instance,
4505 a "(::1)" is accepted. */
4508 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4512 gfc_array_ref
*ar
= NULL
;
4513 gfc_ref
*ref
, *part_ref
= NULL
;
4516 if (expr
->expr_type
== EXPR_FUNCTION
)
4517 return expr
->value
.function
.esym
4518 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4519 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4522 if (expr
->rank
== 0)
4525 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4528 return false; /* Array shall be last part-ref. */
4530 if (ref
->type
== REF_COMPONENT
)
4532 else if (ref
->type
== REF_SUBSTRING
)
4534 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4538 sym
= expr
->symtree
->n
.sym
;
4539 if (expr
->ts
.type
!= BT_CLASS
4541 && !part_ref
->u
.c
.component
->attr
.contiguous
4542 && part_ref
->u
.c
.component
->attr
.pointer
)
4544 && !sym
->attr
.contiguous
4545 && (sym
->attr
.pointer
4546 || sym
->as
->type
== AS_ASSUMED_RANK
4547 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
4550 if (!ar
|| ar
->type
== AR_FULL
)
4553 gcc_assert (ar
->type
== AR_SECTION
);
4555 /* Check for simply contiguous array */
4557 for (i
= 0; i
< ar
->dimen
; i
++)
4559 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4562 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4568 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4571 /* If the previous section was not contiguous, that's an error,
4572 unless we have effective only one element and checking is not
4574 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4575 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4576 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4577 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4578 ar
->end
[i
]->value
.integer
) != 0))
4581 /* Following the standard, "(::1)" or - if known at compile time -
4582 "(lbound:ubound)" are not simply contiguous; if strict
4583 is false, they are regarded as simply contiguous. */
4584 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4585 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4586 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4590 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4591 || !ar
->as
->lower
[i
]
4592 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4593 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4594 ar
->as
->lower
[i
]->value
.integer
) != 0))
4598 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4599 || !ar
->as
->upper
[i
]
4600 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4601 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4602 ar
->as
->upper
[i
]->value
.integer
) != 0))
4610 /* Build call to an intrinsic procedure. The number of arguments has to be
4611 passed (rather than ending the list with a NULL value) because we may
4612 want to add arguments but with a NULL-expression. */
4615 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
4616 locus where
, unsigned numarg
, ...)
4619 gfc_actual_arglist
* atail
;
4620 gfc_intrinsic_sym
* isym
;
4623 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
4625 isym
= gfc_intrinsic_function_by_id (id
);
4628 result
= gfc_get_expr ();
4629 result
->expr_type
= EXPR_FUNCTION
;
4630 result
->ts
= isym
->ts
;
4631 result
->where
= where
;
4632 result
->value
.function
.name
= mangled_name
;
4633 result
->value
.function
.isym
= isym
;
4635 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
4636 gfc_commit_symbol (result
->symtree
->n
.sym
);
4637 gcc_assert (result
->symtree
4638 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
4639 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
4640 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
4641 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4642 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
4644 va_start (ap
, numarg
);
4646 for (i
= 0; i
< numarg
; ++i
)
4650 atail
->next
= gfc_get_actual_arglist ();
4651 atail
= atail
->next
;
4654 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4656 atail
->expr
= va_arg (ap
, gfc_expr
*);
4664 /* Check if an expression may appear in a variable definition context
4665 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4666 This is called from the various places when resolving
4667 the pieces that make up such a context.
4668 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
4669 variables), some checks are not performed.
4671 Optionally, a possible error message can be suppressed if context is NULL
4672 and just the return status (true / false) be requested. */
4675 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4676 bool own_scope
, const char* context
)
4678 gfc_symbol
* sym
= NULL
;
4680 bool check_intentin
;
4683 symbol_attribute attr
;
4686 if (e
->expr_type
== EXPR_VARIABLE
)
4688 gcc_assert (e
->symtree
);
4689 sym
= e
->symtree
->n
.sym
;
4691 else if (e
->expr_type
== EXPR_FUNCTION
)
4693 gcc_assert (e
->symtree
);
4694 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4697 unlimited
= e
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (sym
);
4699 attr
= gfc_expr_attr (e
);
4700 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4702 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4705 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4706 " context (%s) at %L", context
, &e
->where
);
4710 else if (e
->expr_type
!= EXPR_VARIABLE
)
4713 gfc_error ("Non-variable expression in variable definition context (%s)"
4714 " at %L", context
, &e
->where
);
4718 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4721 gfc_error ("Named constant '%s' in variable definition context (%s)"
4722 " at %L", sym
->name
, context
, &e
->where
);
4725 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4726 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4727 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4730 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4731 " a variable", sym
->name
, context
, &e
->where
);
4735 /* Find out whether the expr is a pointer; this also means following
4736 component references to the last one. */
4737 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4738 if (pointer
&& !is_pointer
&& !unlimited
)
4741 gfc_error ("Non-POINTER in pointer association context (%s)"
4742 " at %L", context
, &e
->where
);
4749 || (e
->ts
.type
== BT_DERIVED
4750 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4751 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4754 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4755 context
, &e
->where
);
4759 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
4760 component of sub-component of a pointer; we need to distinguish
4761 assignment to a pointer component from pointer-assignment to a pointer
4762 component. Note that (normal) assignment to procedure pointers is not
4764 check_intentin
= !own_scope
;
4765 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4766 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4767 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4769 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4770 check_intentin
= false;
4771 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4773 ptr_component
= true;
4775 check_intentin
= false;
4778 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4780 if (pointer
&& is_pointer
)
4783 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4784 " association context (%s) at %L",
4785 sym
->name
, context
, &e
->where
);
4788 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
4791 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4792 " definition context (%s) at %L",
4793 sym
->name
, context
, &e
->where
);
4798 /* PROTECTED and use-associated. */
4799 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4801 if (pointer
&& is_pointer
)
4804 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4805 " pointer association context (%s) at %L",
4806 sym
->name
, context
, &e
->where
);
4809 if (!pointer
&& !is_pointer
)
4812 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4813 " variable definition context (%s) at %L",
4814 sym
->name
, context
, &e
->where
);
4819 /* Variable not assignable from a PURE procedure but appears in
4820 variable definition context. */
4821 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4824 gfc_error ("Variable '%s' can not appear in a variable definition"
4825 " context (%s) at %L in PURE procedure",
4826 sym
->name
, context
, &e
->where
);
4830 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
4831 && gfc_impure_variable (sym
))
4836 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4838 sym
= ns
->proc_name
;
4841 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4843 sym
->attr
.implicit_pure
= 0;
4848 /* Check variable definition context for associate-names. */
4849 if (!pointer
&& sym
->assoc
)
4852 gfc_association_list
* assoc
;
4854 gcc_assert (sym
->assoc
->target
);
4856 /* If this is a SELECT TYPE temporary (the association is used internally
4857 for SELECT TYPE), silently go over to the target. */
4858 if (sym
->attr
.select_type_temporary
)
4860 gfc_expr
* t
= sym
->assoc
->target
;
4862 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4863 name
= t
->symtree
->name
;
4865 if (t
->symtree
->n
.sym
->assoc
)
4866 assoc
= t
->symtree
->n
.sym
->assoc
;
4875 gcc_assert (name
&& assoc
);
4877 /* Is association to a valid variable? */
4878 if (!assoc
->variable
)
4882 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4883 gfc_error ("'%s' at %L associated to vector-indexed target can"
4884 " not be used in a variable definition context (%s)",
4885 name
, &e
->where
, context
);
4887 gfc_error ("'%s' at %L associated to expression can"
4888 " not be used in a variable definition context (%s)",
4889 name
, &e
->where
, context
);
4894 /* Target must be allowed to appear in a variable definition context. */
4895 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
4898 gfc_error ("Associate-name '%s' can not appear in a variable"
4899 " definition context (%s) at %L because its target"
4900 " at %L can not, either",
4901 name
, context
, &e
->where
,
4902 &assoc
->target
->where
);