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
]))
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
--)
1266 /* Find a component of a structure constructor. */
1268 static gfc_constructor
*
1269 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1271 gfc_component
*comp
;
1272 gfc_component
*pick
;
1273 gfc_constructor
*c
= gfc_constructor_first (base
);
1275 comp
= ref
->u
.c
.sym
->components
;
1276 pick
= ref
->u
.c
.component
;
1277 while (comp
!= pick
)
1280 c
= gfc_constructor_next (c
);
1287 /* Replace an expression with the contents of a constructor, removing
1288 the subobject reference in the process. */
1291 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1301 e
= gfc_copy_expr (p
);
1302 e
->ref
= p
->ref
->next
;
1303 p
->ref
->next
= NULL
;
1304 gfc_replace_expr (p
, e
);
1308 /* Pull an array section out of an array constructor. */
1311 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1318 long unsigned one
= 1;
1320 mpz_t start
[GFC_MAX_DIMENSIONS
];
1321 mpz_t end
[GFC_MAX_DIMENSIONS
];
1322 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1323 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1324 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1329 gfc_constructor_base base
;
1330 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1340 base
= expr
->value
.constructor
;
1341 expr
->value
.constructor
= NULL
;
1343 rank
= ref
->u
.ar
.as
->rank
;
1345 if (expr
->shape
== NULL
)
1346 expr
->shape
= gfc_get_shape (rank
);
1348 mpz_init_set_ui (delta_mpz
, one
);
1349 mpz_init_set_ui (nelts
, one
);
1352 /* Do the initialization now, so that we can cleanup without
1353 keeping track of where we were. */
1354 for (d
= 0; d
< rank
; d
++)
1356 mpz_init (delta
[d
]);
1357 mpz_init (start
[d
]);
1360 mpz_init (stride
[d
]);
1364 /* Build the counters to clock through the array reference. */
1366 for (d
= 0; d
< rank
; d
++)
1368 /* Make this stretch of code easier on the eye! */
1369 begin
= ref
->u
.ar
.start
[d
];
1370 finish
= ref
->u
.ar
.end
[d
];
1371 step
= ref
->u
.ar
.stride
[d
];
1372 lower
= ref
->u
.ar
.as
->lower
[d
];
1373 upper
= ref
->u
.ar
.as
->upper
[d
];
1375 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1377 gfc_constructor
*ci
;
1380 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1386 gcc_assert (begin
->rank
== 1);
1387 /* Zero-sized arrays have no shape and no elements, stop early. */
1390 mpz_init_set_ui (nelts
, 0);
1394 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1395 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1396 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1397 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1400 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1402 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1403 || mpz_cmp (ci
->expr
->value
.integer
,
1404 lower
->value
.integer
) < 0)
1406 gfc_error ("index in dimension %d is out of bounds "
1407 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1415 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1416 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1417 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1423 /* Obtain the stride. */
1425 mpz_set (stride
[d
], step
->value
.integer
);
1427 mpz_set_ui (stride
[d
], one
);
1429 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1430 mpz_set_ui (stride
[d
], one
);
1432 /* Obtain the start value for the index. */
1434 mpz_set (start
[d
], begin
->value
.integer
);
1436 mpz_set (start
[d
], lower
->value
.integer
);
1438 mpz_set (ctr
[d
], start
[d
]);
1440 /* Obtain the end value for the index. */
1442 mpz_set (end
[d
], finish
->value
.integer
);
1444 mpz_set (end
[d
], upper
->value
.integer
);
1446 /* Separate 'if' because elements sometimes arrive with
1448 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1449 mpz_set (end
[d
], begin
->value
.integer
);
1451 /* Check the bounds. */
1452 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1453 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1454 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1455 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1457 gfc_error ("index in dimension %d is out of bounds "
1458 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1463 /* Calculate the number of elements and the shape. */
1464 mpz_set (tmp_mpz
, stride
[d
]);
1465 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1466 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1467 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1468 mpz_mul (nelts
, nelts
, tmp_mpz
);
1470 /* An element reference reduces the rank of the expression; don't
1471 add anything to the shape array. */
1472 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1473 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1476 /* Calculate the 'stride' (=delta) for conversion of the
1477 counter values into the index along the constructor. */
1478 mpz_set (delta
[d
], delta_mpz
);
1479 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1480 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1481 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1485 cons
= gfc_constructor_first (base
);
1487 /* Now clock through the array reference, calculating the index in
1488 the source constructor and transferring the elements to the new
1490 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1492 mpz_init_set_ui (ptr
, 0);
1495 for (d
= 0; d
< rank
; d
++)
1497 mpz_set (tmp_mpz
, ctr
[d
]);
1498 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1499 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1500 mpz_add (ptr
, ptr
, tmp_mpz
);
1502 if (!incr_ctr
) continue;
1504 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1506 gcc_assert(vecsub
[d
]);
1508 if (!gfc_constructor_next (vecsub
[d
]))
1509 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1512 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1515 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1519 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1521 if (mpz_cmp_ui (stride
[d
], 0) > 0
1522 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1523 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1524 mpz_set (ctr
[d
], start
[d
]);
1530 limit
= mpz_get_ui (ptr
);
1531 if (limit
>= gfc_option
.flag_max_array_constructor
)
1533 gfc_error ("The number of elements in the array constructor "
1534 "at %L requires an increase of the allowed %d "
1535 "upper limit. See -fmax-array-constructor "
1536 "option", &expr
->where
,
1537 gfc_option
.flag_max_array_constructor
);
1541 cons
= gfc_constructor_lookup (base
, limit
);
1543 gfc_constructor_append_expr (&expr
->value
.constructor
,
1544 gfc_copy_expr (cons
->expr
), NULL
);
1551 mpz_clear (delta_mpz
);
1552 mpz_clear (tmp_mpz
);
1554 for (d
= 0; d
< rank
; d
++)
1556 mpz_clear (delta
[d
]);
1557 mpz_clear (start
[d
]);
1560 mpz_clear (stride
[d
]);
1562 gfc_constructor_free (base
);
1566 /* Pull a substring out of an expression. */
1569 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1576 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1577 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1580 *newp
= gfc_copy_expr (p
);
1581 free ((*newp
)->value
.character
.string
);
1583 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1584 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1585 length
= end
- start
+ 1;
1587 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1588 (*newp
)->value
.character
.length
= length
;
1589 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1590 length
* sizeof (gfc_char_t
));
1597 /* Simplify a subobject reference of a constructor. This occurs when
1598 parameter variable values are substituted. */
1601 simplify_const_ref (gfc_expr
*p
)
1603 gfc_constructor
*cons
, *c
;
1609 switch (p
->ref
->type
)
1612 switch (p
->ref
->u
.ar
.type
)
1615 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1616 will generate this. */
1617 if (p
->expr_type
!= EXPR_ARRAY
)
1619 remove_subobject_ref (p
, NULL
);
1622 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1628 remove_subobject_ref (p
, cons
);
1632 if (!find_array_section (p
, p
->ref
))
1634 p
->ref
->u
.ar
.type
= AR_FULL
;
1639 if (p
->ref
->next
!= NULL
1640 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1642 for (c
= gfc_constructor_first (p
->value
.constructor
);
1643 c
; c
= gfc_constructor_next (c
))
1645 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1646 if (!simplify_const_ref (c
->expr
))
1650 if (p
->ts
.type
== BT_DERIVED
1652 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1654 /* There may have been component references. */
1655 p
->ts
= c
->expr
->ts
;
1659 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1661 if (p
->ts
.type
== BT_CHARACTER
1662 && last_ref
->type
== REF_SUBSTRING
)
1664 /* If this is a CHARACTER array and we possibly took
1665 a substring out of it, update the type-spec's
1666 character length according to the first element
1667 (as all should have the same length). */
1669 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1671 const gfc_expr
* first
= c
->expr
;
1672 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1673 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1674 string_len
= first
->value
.character
.length
;
1680 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1683 gfc_free_expr (p
->ts
.u
.cl
->length
);
1686 = gfc_get_int_expr (gfc_default_integer_kind
,
1690 gfc_free_ref_list (p
->ref
);
1701 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1702 remove_subobject_ref (p
, cons
);
1706 if (!find_substring_ref (p
, &newp
))
1709 gfc_replace_expr (p
, newp
);
1710 gfc_free_ref_list (p
->ref
);
1720 /* Simplify a chain of references. */
1723 simplify_ref_chain (gfc_ref
*ref
, int type
)
1727 for (; ref
; ref
= ref
->next
)
1732 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1734 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1736 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1738 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1744 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1746 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1758 /* Try to substitute the value of a parameter variable. */
1761 simplify_parameter_variable (gfc_expr
*p
, int type
)
1766 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1772 /* Do not copy subobject refs for constant. */
1773 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1774 e
->ref
= gfc_copy_ref (p
->ref
);
1775 t
= gfc_simplify_expr (e
, type
);
1777 /* Only use the simplification if it eliminated all subobject references. */
1779 gfc_replace_expr (p
, e
);
1786 /* Given an expression, simplify it by collapsing constant
1787 expressions. Most simplification takes place when the expression
1788 tree is being constructed. If an intrinsic function is simplified
1789 at some point, we get called again to collapse the result against
1792 We work by recursively simplifying expression nodes, simplifying
1793 intrinsic functions where possible, which can lead to further
1794 constant collapsing. If an operator has constant operand(s), we
1795 rip the expression apart, and rebuild it, hoping that it becomes
1798 The expression type is defined for:
1799 0 Basic expression parsing
1800 1 Simplifying array constructors -- will substitute
1802 Returns false on error, true otherwise.
1803 NOTE: Will return true even if the expression can not be simplified. */
1806 gfc_simplify_expr (gfc_expr
*p
, int type
)
1808 gfc_actual_arglist
*ap
;
1813 switch (p
->expr_type
)
1820 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1821 if (!gfc_simplify_expr (ap
->expr
, type
))
1824 if (p
->value
.function
.isym
!= NULL
1825 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1830 case EXPR_SUBSTRING
:
1831 if (!simplify_ref_chain (p
->ref
, type
))
1834 if (gfc_is_constant_expr (p
))
1840 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1842 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1843 start
--; /* Convert from one-based to zero-based. */
1846 end
= p
->value
.character
.length
;
1847 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1848 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1853 s
= gfc_get_wide_string (end
- start
+ 2);
1854 memcpy (s
, p
->value
.character
.string
+ start
,
1855 (end
- start
) * sizeof (gfc_char_t
));
1856 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1857 free (p
->value
.character
.string
);
1858 p
->value
.character
.string
= s
;
1859 p
->value
.character
.length
= end
- start
;
1860 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1861 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1863 p
->value
.character
.length
);
1864 gfc_free_ref_list (p
->ref
);
1866 p
->expr_type
= EXPR_CONSTANT
;
1871 if (!simplify_intrinsic_op (p
, type
))
1876 /* Only substitute array parameter variables if we are in an
1877 initialization expression, or we want a subsection. */
1878 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1879 && (gfc_init_expr_flag
|| p
->ref
1880 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1882 if (!simplify_parameter_variable (p
, type
))
1889 gfc_simplify_iterator_var (p
);
1892 /* Simplify subcomponent references. */
1893 if (!simplify_ref_chain (p
->ref
, type
))
1898 case EXPR_STRUCTURE
:
1900 if (!simplify_ref_chain (p
->ref
, type
))
1903 if (!simplify_constructor (p
->value
.constructor
, type
))
1906 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1907 && p
->ref
->u
.ar
.type
== AR_FULL
)
1908 gfc_expand_constructor (p
, false);
1910 if (!simplify_const_ref (p
))
1924 /* Returns the type of an expression with the exception that iterator
1925 variables are automatically integers no matter what else they may
1931 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
1938 /* Scalarize an expression for an elemental intrinsic call. */
1941 scalarize_intrinsic_call (gfc_expr
*e
)
1943 gfc_actual_arglist
*a
, *b
;
1944 gfc_constructor_base ctor
;
1945 gfc_constructor
*args
[5];
1946 gfc_constructor
*ci
, *new_ctor
;
1947 gfc_expr
*expr
, *old
;
1948 int n
, i
, rank
[5], array_arg
;
1950 /* Find which, if any, arguments are arrays. Assume that the old
1951 expression carries the type information and that the first arg
1952 that is an array expression carries all the shape information.*/
1954 a
= e
->value
.function
.actual
;
1955 for (; a
; a
= a
->next
)
1958 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1961 expr
= gfc_copy_expr (a
->expr
);
1968 old
= gfc_copy_expr (e
);
1970 gfc_constructor_free (expr
->value
.constructor
);
1971 expr
->value
.constructor
= NULL
;
1973 expr
->where
= old
->where
;
1974 expr
->expr_type
= EXPR_ARRAY
;
1976 /* Copy the array argument constructors into an array, with nulls
1979 a
= old
->value
.function
.actual
;
1980 for (; a
; a
= a
->next
)
1982 /* Check that this is OK for an initialization expression. */
1983 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
1987 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1989 rank
[n
] = a
->expr
->rank
;
1990 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1991 args
[n
] = gfc_constructor_first (ctor
);
1993 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1996 rank
[n
] = a
->expr
->rank
;
1999 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2000 args
[n
] = gfc_constructor_first (ctor
);
2009 /* Using the array argument as the master, step through the array
2010 calling the function for each element and advancing the array
2011 constructors together. */
2012 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2014 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2015 gfc_copy_expr (old
), NULL
);
2017 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2019 b
= old
->value
.function
.actual
;
2020 for (i
= 0; i
< n
; i
++)
2023 new_ctor
->expr
->value
.function
.actual
2024 = a
= gfc_get_actual_arglist ();
2027 a
->next
= gfc_get_actual_arglist ();
2032 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2034 a
->expr
= gfc_copy_expr (b
->expr
);
2039 /* Simplify the function calls. If the simplification fails, the
2040 error will be flagged up down-stream or the library will deal
2042 gfc_simplify_expr (new_ctor
->expr
, 0);
2044 for (i
= 0; i
< n
; i
++)
2046 args
[i
] = gfc_constructor_next (args
[i
]);
2048 for (i
= 1; i
< n
; i
++)
2049 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2050 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2056 /* Free "expr" but not the pointers it contains. */
2058 gfc_free_expr (old
);
2062 gfc_error_now ("elemental function arguments at %C are not compliant");
2065 gfc_free_expr (expr
);
2066 gfc_free_expr (old
);
2072 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2074 gfc_expr
*op1
= e
->value
.op
.op1
;
2075 gfc_expr
*op2
= e
->value
.op
.op2
;
2077 if (!(*check_function
)(op1
))
2080 switch (e
->value
.op
.op
)
2082 case INTRINSIC_UPLUS
:
2083 case INTRINSIC_UMINUS
:
2084 if (!numeric_type (et0 (op1
)))
2089 case INTRINSIC_EQ_OS
:
2091 case INTRINSIC_NE_OS
:
2093 case INTRINSIC_GT_OS
:
2095 case INTRINSIC_GE_OS
:
2097 case INTRINSIC_LT_OS
:
2099 case INTRINSIC_LE_OS
:
2100 if (!(*check_function
)(op2
))
2103 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2104 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2106 gfc_error ("Numeric or CHARACTER operands are required in "
2107 "expression at %L", &e
->where
);
2112 case INTRINSIC_PLUS
:
2113 case INTRINSIC_MINUS
:
2114 case INTRINSIC_TIMES
:
2115 case INTRINSIC_DIVIDE
:
2116 case INTRINSIC_POWER
:
2117 if (!(*check_function
)(op2
))
2120 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2125 case INTRINSIC_CONCAT
:
2126 if (!(*check_function
)(op2
))
2129 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2131 gfc_error ("Concatenation operator in expression at %L "
2132 "must have two CHARACTER operands", &op1
->where
);
2136 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2138 gfc_error ("Concat operator at %L must concatenate strings of the "
2139 "same kind", &e
->where
);
2146 if (et0 (op1
) != BT_LOGICAL
)
2148 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2149 "operand", &op1
->where
);
2158 case INTRINSIC_NEQV
:
2159 if (!(*check_function
)(op2
))
2162 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2164 gfc_error ("LOGICAL operands are required in expression at %L",
2171 case INTRINSIC_PARENTHESES
:
2175 gfc_error ("Only intrinsic operators can be used in expression at %L",
2183 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2188 /* F2003, 7.1.7 (3): In init expression, allocatable components
2189 must not be data-initialized. */
2191 check_alloc_comp_init (gfc_expr
*e
)
2193 gfc_component
*comp
;
2194 gfc_constructor
*ctor
;
2196 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2197 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2199 for (comp
= e
->ts
.u
.derived
->components
,
2200 ctor
= gfc_constructor_first (e
->value
.constructor
);
2201 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2203 if (comp
->attr
.allocatable
2204 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2206 gfc_error("Invalid initialization expression for ALLOCATABLE "
2207 "component '%s' in structure constructor at %L",
2208 comp
->name
, &ctor
->expr
->where
);
2217 check_init_expr_arguments (gfc_expr
*e
)
2219 gfc_actual_arglist
*ap
;
2221 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2222 if (!gfc_check_init_expr (ap
->expr
))
2228 static bool check_restricted (gfc_expr
*);
2230 /* F95, 7.1.6.1, Initialization expressions, (7)
2231 F2003, 7.1.7 Initialization expression, (8) */
2234 check_inquiry (gfc_expr
*e
, int not_restricted
)
2237 const char *const *functions
;
2239 static const char *const inquiry_func_f95
[] = {
2240 "lbound", "shape", "size", "ubound",
2241 "bit_size", "len", "kind",
2242 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2243 "precision", "radix", "range", "tiny",
2247 static const char *const inquiry_func_f2003
[] = {
2248 "lbound", "shape", "size", "ubound",
2249 "bit_size", "len", "kind",
2250 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2251 "precision", "radix", "range", "tiny",
2256 gfc_actual_arglist
*ap
;
2258 if (!e
->value
.function
.isym
2259 || !e
->value
.function
.isym
->inquiry
)
2262 /* An undeclared parameter will get us here (PR25018). */
2263 if (e
->symtree
== NULL
)
2266 if (e
->symtree
->n
.sym
->from_intmod
)
2268 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2269 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2270 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2273 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2274 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2279 name
= e
->symtree
->n
.sym
->name
;
2281 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2282 ? inquiry_func_f2003
: inquiry_func_f95
;
2284 for (i
= 0; functions
[i
]; i
++)
2285 if (strcmp (functions
[i
], name
) == 0)
2288 if (functions
[i
] == NULL
)
2292 /* At this point we have an inquiry function with a variable argument. The
2293 type of the variable might be undefined, but we need it now, because the
2294 arguments of these functions are not allowed to be undefined. */
2296 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2301 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2303 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2304 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2307 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2310 /* Assumed character length will not reduce to a constant expression
2311 with LEN, as required by the standard. */
2312 if (i
== 5 && not_restricted
2313 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2314 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2315 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2317 gfc_error ("Assumed or deferred character length variable '%s' "
2318 " in constant expression at %L",
2319 ap
->expr
->symtree
->n
.sym
->name
,
2323 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2326 if (not_restricted
== 0
2327 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2328 && !check_restricted (ap
->expr
))
2331 if (not_restricted
== 0
2332 && ap
->expr
->expr_type
== EXPR_VARIABLE
2333 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2334 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2342 /* F95, 7.1.6.1, Initialization expressions, (5)
2343 F2003, 7.1.7 Initialization expression, (5) */
2346 check_transformational (gfc_expr
*e
)
2348 static const char * const trans_func_f95
[] = {
2349 "repeat", "reshape", "selected_int_kind",
2350 "selected_real_kind", "transfer", "trim", NULL
2353 static const char * const trans_func_f2003
[] = {
2354 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2355 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2356 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2357 "trim", "unpack", NULL
2362 const char *const *functions
;
2364 if (!e
->value
.function
.isym
2365 || !e
->value
.function
.isym
->transformational
)
2368 name
= e
->symtree
->n
.sym
->name
;
2370 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2371 ? trans_func_f2003
: trans_func_f95
;
2373 /* NULL() is dealt with below. */
2374 if (strcmp ("null", name
) == 0)
2377 for (i
= 0; functions
[i
]; i
++)
2378 if (strcmp (functions
[i
], name
) == 0)
2381 if (functions
[i
] == NULL
)
2383 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2384 "in an initialization expression", name
, &e
->where
);
2388 return check_init_expr_arguments (e
);
2392 /* F95, 7.1.6.1, Initialization expressions, (6)
2393 F2003, 7.1.7 Initialization expression, (6) */
2396 check_null (gfc_expr
*e
)
2398 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2401 return check_init_expr_arguments (e
);
2406 check_elemental (gfc_expr
*e
)
2408 if (!e
->value
.function
.isym
2409 || !e
->value
.function
.isym
->elemental
)
2412 if (e
->ts
.type
!= BT_INTEGER
2413 && e
->ts
.type
!= BT_CHARACTER
2414 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2415 "initialization expression at %L", &e
->where
))
2418 return check_init_expr_arguments (e
);
2423 check_conversion (gfc_expr
*e
)
2425 if (!e
->value
.function
.isym
2426 || !e
->value
.function
.isym
->conversion
)
2429 return check_init_expr_arguments (e
);
2433 /* Verify that an expression is an initialization expression. A side
2434 effect is that the expression tree is reduced to a single constant
2435 node if all goes well. This would normally happen when the
2436 expression is constructed but function references are assumed to be
2437 intrinsics in the context of initialization expressions. If
2438 false is returned an error message has been generated. */
2441 gfc_check_init_expr (gfc_expr
*e
)
2449 switch (e
->expr_type
)
2452 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2454 t
= gfc_simplify_expr (e
, 0);
2462 gfc_intrinsic_sym
* isym
;
2465 sym
= e
->symtree
->n
.sym
;
2466 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2467 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2469 gfc_error ("Function '%s' in initialization expression at %L "
2470 "must be an intrinsic function",
2471 e
->symtree
->n
.sym
->name
, &e
->where
);
2475 if ((m
= check_conversion (e
)) == MATCH_NO
2476 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2477 && (m
= check_null (e
)) == MATCH_NO
2478 && (m
= check_transformational (e
)) == MATCH_NO
2479 && (m
= check_elemental (e
)) == MATCH_NO
)
2481 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2482 "in an initialization expression",
2483 e
->symtree
->n
.sym
->name
, &e
->where
);
2487 if (m
== MATCH_ERROR
)
2490 /* Try to scalarize an elemental intrinsic function that has an
2492 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2493 if (isym
&& isym
->elemental
2494 && (t
= scalarize_intrinsic_call(e
)))
2499 t
= gfc_simplify_expr (e
, 0);
2506 if (gfc_check_iter_variable (e
))
2509 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2511 /* A PARAMETER shall not be used to define itself, i.e.
2512 REAL, PARAMETER :: x = transfer(0, x)
2514 if (!e
->symtree
->n
.sym
->value
)
2516 gfc_error("PARAMETER '%s' is used at %L before its definition "
2517 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2521 t
= simplify_parameter_variable (e
, 0);
2526 if (gfc_in_match_data ())
2531 if (e
->symtree
->n
.sym
->as
)
2533 switch (e
->symtree
->n
.sym
->as
->type
)
2535 case AS_ASSUMED_SIZE
:
2536 gfc_error ("Assumed size array '%s' at %L is not permitted "
2537 "in an initialization expression",
2538 e
->symtree
->n
.sym
->name
, &e
->where
);
2541 case AS_ASSUMED_SHAPE
:
2542 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2543 "in an initialization expression",
2544 e
->symtree
->n
.sym
->name
, &e
->where
);
2548 gfc_error ("Deferred array '%s' at %L is not permitted "
2549 "in an initialization expression",
2550 e
->symtree
->n
.sym
->name
, &e
->where
);
2554 gfc_error ("Array '%s' at %L is a variable, which does "
2555 "not reduce to a constant expression",
2556 e
->symtree
->n
.sym
->name
, &e
->where
);
2564 gfc_error ("Parameter '%s' at %L has not been declared or is "
2565 "a variable, which does not reduce to a constant "
2566 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2575 case EXPR_SUBSTRING
:
2576 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2580 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2582 t
= gfc_simplify_expr (e
, 0);
2586 case EXPR_STRUCTURE
:
2587 t
= e
->ts
.is_iso_c
? true : false;
2591 t
= check_alloc_comp_init (e
);
2595 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2602 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2606 t
= gfc_expand_constructor (e
, true);
2610 t
= gfc_check_constructor_type (e
);
2614 gfc_internal_error ("check_init_expr(): Unknown expression type");
2620 /* Reduces a general expression to an initialization expression (a constant).
2621 This used to be part of gfc_match_init_expr.
2622 Note that this function doesn't free the given expression on false. */
2625 gfc_reduce_init_expr (gfc_expr
*expr
)
2629 gfc_init_expr_flag
= true;
2630 t
= gfc_resolve_expr (expr
);
2632 t
= gfc_check_init_expr (expr
);
2633 gfc_init_expr_flag
= false;
2638 if (expr
->expr_type
== EXPR_ARRAY
)
2640 if (!gfc_check_constructor_type (expr
))
2642 if (!gfc_expand_constructor (expr
, true))
2650 /* Match an initialization expression. We work by first matching an
2651 expression, then reducing it to a constant. */
2654 gfc_match_init_expr (gfc_expr
**result
)
2662 gfc_init_expr_flag
= true;
2664 m
= gfc_match_expr (&expr
);
2667 gfc_init_expr_flag
= false;
2671 t
= gfc_reduce_init_expr (expr
);
2674 gfc_free_expr (expr
);
2675 gfc_init_expr_flag
= false;
2680 gfc_init_expr_flag
= false;
2686 /* Given an actual argument list, test to see that each argument is a
2687 restricted expression and optionally if the expression type is
2688 integer or character. */
2691 restricted_args (gfc_actual_arglist
*a
)
2693 for (; a
; a
= a
->next
)
2695 if (!check_restricted (a
->expr
))
2703 /************* Restricted/specification expressions *************/
2706 /* Make sure a non-intrinsic function is a specification function. */
2709 external_spec_function (gfc_expr
*e
)
2713 f
= e
->value
.function
.esym
;
2715 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2717 gfc_error ("Specification function '%s' at %L cannot be a statement "
2718 "function", f
->name
, &e
->where
);
2722 if (f
->attr
.proc
== PROC_INTERNAL
)
2724 gfc_error ("Specification function '%s' at %L cannot be an internal "
2725 "function", f
->name
, &e
->where
);
2729 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2731 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2736 if (f
->attr
.recursive
)
2738 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2739 f
->name
, &e
->where
);
2743 return restricted_args (e
->value
.function
.actual
);
2747 /* Check to see that a function reference to an intrinsic is a
2748 restricted expression. */
2751 restricted_intrinsic (gfc_expr
*e
)
2753 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2754 if (check_inquiry (e
, 0) == MATCH_YES
)
2757 return restricted_args (e
->value
.function
.actual
);
2761 /* Check the expressions of an actual arglist. Used by check_restricted. */
2764 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2766 for (; arg
; arg
= arg
->next
)
2767 if (!checker (arg
->expr
))
2774 /* Check the subscription expressions of a reference chain with a checking
2775 function; used by check_restricted. */
2778 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2788 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2790 if (!checker (ref
->u
.ar
.start
[dim
]))
2792 if (!checker (ref
->u
.ar
.end
[dim
]))
2794 if (!checker (ref
->u
.ar
.stride
[dim
]))
2800 /* Nothing needed, just proceed to next reference. */
2804 if (!checker (ref
->u
.ss
.start
))
2806 if (!checker (ref
->u
.ss
.end
))
2815 return check_references (ref
->next
, checker
);
2819 /* Verify that an expression is a restricted expression. Like its
2820 cousin check_init_expr(), an error message is generated if we
2824 check_restricted (gfc_expr
*e
)
2832 switch (e
->expr_type
)
2835 t
= check_intrinsic_op (e
, check_restricted
);
2837 t
= gfc_simplify_expr (e
, 0);
2842 if (e
->value
.function
.esym
)
2844 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2846 t
= external_spec_function (e
);
2850 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2853 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2856 t
= restricted_intrinsic (e
);
2861 sym
= e
->symtree
->n
.sym
;
2864 /* If a dummy argument appears in a context that is valid for a
2865 restricted expression in an elemental procedure, it will have
2866 already been simplified away once we get here. Therefore we
2867 don't need to jump through hoops to distinguish valid from
2869 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2870 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2872 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2873 sym
->name
, &e
->where
);
2877 if (sym
->attr
.optional
)
2879 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2880 sym
->name
, &e
->where
);
2884 if (sym
->attr
.intent
== INTENT_OUT
)
2886 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2887 sym
->name
, &e
->where
);
2891 /* Check reference chain if any. */
2892 if (!check_references (e
->ref
, &check_restricted
))
2895 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2896 processed in resolve.c(resolve_formal_arglist). This is done so
2897 that host associated dummy array indices are accepted (PR23446).
2898 This mechanism also does the same for the specification expressions
2899 of array-valued functions. */
2901 || sym
->attr
.in_common
2902 || sym
->attr
.use_assoc
2904 || sym
->attr
.implied_index
2905 || sym
->attr
.flavor
== FL_PARAMETER
2906 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2907 || (sym
->ns
&& gfc_current_ns
->parent
2908 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2909 || (sym
->ns
->proc_name
!= NULL
2910 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2911 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2917 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2918 sym
->name
, &e
->where
);
2919 /* Prevent a repetition of the error. */
2928 case EXPR_SUBSTRING
:
2929 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2933 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2935 t
= gfc_simplify_expr (e
, 0);
2939 case EXPR_STRUCTURE
:
2940 t
= gfc_check_constructor (e
, check_restricted
);
2944 t
= gfc_check_constructor (e
, check_restricted
);
2948 gfc_internal_error ("check_restricted(): Unknown expression type");
2955 /* Check to see that an expression is a specification expression. If
2956 we return false, an error has been generated. */
2959 gfc_specification_expr (gfc_expr
*e
)
2961 gfc_component
*comp
;
2966 if (e
->ts
.type
!= BT_INTEGER
)
2968 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2969 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2973 comp
= gfc_get_proc_ptr_comp (e
);
2974 if (e
->expr_type
== EXPR_FUNCTION
2975 && !e
->value
.function
.isym
2976 && !e
->value
.function
.esym
2977 && !gfc_pure (e
->symtree
->n
.sym
)
2978 && (!comp
|| !comp
->attr
.pure
))
2980 gfc_error ("Function '%s' at %L must be PURE",
2981 e
->symtree
->n
.sym
->name
, &e
->where
);
2982 /* Prevent repeat error messages. */
2983 e
->symtree
->n
.sym
->attr
.pure
= 1;
2989 gfc_error ("Expression at %L must be scalar", &e
->where
);
2993 if (!gfc_simplify_expr (e
, 0))
2996 return check_restricted (e
);
3000 /************** Expression conformance checks. *************/
3002 /* Given two expressions, make sure that the arrays are conformable. */
3005 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3007 int op1_flag
, op2_flag
, d
;
3008 mpz_t op1_size
, op2_size
;
3014 if (op1
->rank
== 0 || op2
->rank
== 0)
3017 va_start (argp
, optype_msgid
);
3018 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3021 if (op1
->rank
!= op2
->rank
)
3023 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3024 op1
->rank
, op2
->rank
, &op1
->where
);
3030 for (d
= 0; d
< op1
->rank
; d
++)
3032 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3033 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3035 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3037 gfc_error ("Different shape for %s at %L on dimension %d "
3038 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3039 (int) mpz_get_si (op1_size
),
3040 (int) mpz_get_si (op2_size
));
3046 mpz_clear (op1_size
);
3048 mpz_clear (op2_size
);
3058 /* Given an assignable expression and an arbitrary expression, make
3059 sure that the assignment can take place. */
3062 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3068 sym
= lvalue
->symtree
->n
.sym
;
3070 /* See if this is the component or subcomponent of a pointer. */
3071 has_pointer
= sym
->attr
.pointer
;
3072 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3073 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3079 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3080 variable local to a function subprogram. Its existence begins when
3081 execution of the function is initiated and ends when execution of the
3082 function is terminated...
3083 Therefore, the left hand side is no longer a variable, when it is: */
3084 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3085 && !sym
->attr
.external
)
3090 /* (i) Use associated; */
3091 if (sym
->attr
.use_assoc
)
3094 /* (ii) The assignment is in the main program; or */
3095 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3098 /* (iii) A module or internal procedure... */
3099 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3100 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3101 && gfc_current_ns
->parent
3102 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3103 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3104 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3106 /* ... that is not a function... */
3107 if (!gfc_current_ns
->proc_name
->attr
.function
)
3110 /* ... or is not an entry and has a different name. */
3111 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3115 /* (iv) Host associated and not the function symbol or the
3116 parent result. This picks up sibling references, which
3117 cannot be entries. */
3118 if (!sym
->attr
.entry
3119 && sym
->ns
== gfc_current_ns
->parent
3120 && sym
!= gfc_current_ns
->proc_name
3121 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3126 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3131 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3133 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3134 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3138 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3140 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3145 if (rvalue
->expr_type
== EXPR_NULL
)
3147 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3148 && lvalue
->symtree
->n
.sym
->attr
.data
)
3152 gfc_error ("NULL appears on right-hand side in assignment at %L",
3158 /* This is possibly a typo: x = f() instead of x => f(). */
3159 if (gfc_option
.warn_surprising
3160 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3161 gfc_warning ("POINTER-valued function appears on right-hand side of "
3162 "assignment at %L", &rvalue
->where
);
3164 /* Check size of array assignments. */
3165 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3166 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3169 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3170 && lvalue
->symtree
->n
.sym
->attr
.data
3171 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3172 "initialize non-integer variable '%s'",
3173 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3175 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3176 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3177 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3181 /* Handle the case of a BOZ literal on the RHS. */
3182 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3185 if (gfc_option
.warn_surprising
)
3186 gfc_warning ("BOZ literal at %L is bitwise transferred "
3187 "non-integer symbol '%s'", &rvalue
->where
,
3188 lvalue
->symtree
->n
.sym
->name
);
3189 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3191 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3193 if (rc
== ARITH_UNDERFLOW
)
3194 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3195 ". This check can be disabled with the option "
3196 "-fno-range-check", &rvalue
->where
);
3197 else if (rc
== ARITH_OVERFLOW
)
3198 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3199 ". This check can be disabled with the option "
3200 "-fno-range-check", &rvalue
->where
);
3201 else if (rc
== ARITH_NAN
)
3202 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3203 ". This check can be disabled with the option "
3204 "-fno-range-check", &rvalue
->where
);
3209 /* Warn about type-changing conversions for REAL or COMPLEX constants.
3210 If lvalue and rvalue are mixed REAL and complex, gfc_compare_types
3211 will warn anyway, so there is no need to to so here. */
3213 if (rvalue
->expr_type
== EXPR_CONSTANT
&& lvalue
->ts
.type
== rvalue
->ts
.type
3214 && (lvalue
->ts
.type
== BT_REAL
|| lvalue
->ts
.type
== BT_COMPLEX
))
3216 if (lvalue
->ts
.kind
< rvalue
->ts
.kind
&& gfc_option
.gfc_warn_conversion
)
3218 /* As a special bonus, don't warn about REAL rvalues which are not
3219 changed by the conversion if -Wconversion is specified. */
3220 if (rvalue
->ts
.type
== BT_REAL
&& mpfr_number_p (rvalue
->value
.real
))
3222 /* Calculate the difference between the constant and the rounded
3223 value and check it against zero. */
3225 gfc_set_model_kind (lvalue
->ts
.kind
);
3227 gfc_set_model_kind (rvalue
->ts
.kind
);
3230 mpfr_set (rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3231 mpfr_sub (diff
, rv
, rvalue
->value
.real
, GFC_RND_MODE
);
3233 if (!mpfr_zero_p (diff
))
3234 gfc_warning ("Change of value in conversion from "
3235 " %s to %s at %L", gfc_typename (&rvalue
->ts
),
3236 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3242 gfc_warning ("Possible change of value in conversion from %s "
3243 "to %s at %L",gfc_typename (&rvalue
->ts
),
3244 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3247 else if (gfc_option
.warn_conversion_extra
3248 && lvalue
->ts
.kind
> rvalue
->ts
.kind
)
3250 gfc_warning ("Conversion from %s to %s at %L",
3251 gfc_typename (&rvalue
->ts
),
3252 gfc_typename (&lvalue
->ts
), &rvalue
->where
);
3256 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3259 /* Only DATA Statements come here. */
3262 /* Numeric can be converted to any other numeric. And Hollerith can be
3263 converted to any other type. */
3264 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3265 || rvalue
->ts
.type
== BT_HOLLERITH
)
3268 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3271 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3272 "conversion of %s to %s", &lvalue
->where
,
3273 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3278 /* Assignment is the only case where character variables of different
3279 kind values can be converted into one another. */
3280 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3282 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3283 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3288 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3292 /* Check that a pointer assignment is OK. We first check lvalue, and
3293 we only check rvalue if it's not an assignment to NULL() or a
3294 NULLIFY statement. */
3297 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3299 symbol_attribute attr
, lhs_attr
;
3301 bool is_pure
, is_implicit_pure
, rank_remap
;
3304 lhs_attr
= gfc_expr_attr (lvalue
);
3305 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3307 gfc_error ("Pointer assignment target is not a POINTER at %L",
3312 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3313 && !lhs_attr
.proc_pointer
)
3315 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3316 "l-value since it is a procedure",
3317 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3321 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3324 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3326 if (ref
->type
== REF_COMPONENT
)
3327 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3329 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3333 if (ref
->u
.ar
.type
== AR_FULL
)
3336 if (ref
->u
.ar
.type
!= AR_SECTION
)
3338 gfc_error ("Expected bounds specification for '%s' at %L",
3339 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3343 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3344 "for '%s' in pointer assignment at %L",
3345 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3348 /* When bounds are given, all lbounds are necessary and either all
3349 or none of the upper bounds; no strides are allowed. If the
3350 upper bounds are present, we may do rank remapping. */
3351 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3353 if (!ref
->u
.ar
.start
[dim
]
3354 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3356 gfc_error ("Lower bound has to be present at %L",
3360 if (ref
->u
.ar
.stride
[dim
])
3362 gfc_error ("Stride must not be present at %L",
3368 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3371 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3372 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3374 gfc_error ("Either all or none of the upper bounds"
3375 " must be specified at %L", &lvalue
->where
);
3383 is_pure
= gfc_pure (NULL
);
3384 is_implicit_pure
= gfc_implicit_pure (NULL
);
3386 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3387 kind, etc for lvalue and rvalue must match, and rvalue must be a
3388 pure variable if we're in a pure function. */
3389 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3392 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3393 if (lvalue
->expr_type
== EXPR_VARIABLE
3394 && gfc_is_coindexed (lvalue
))
3397 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3398 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3400 gfc_error ("Pointer object at %L shall not have a coindex",
3406 /* Checks on rvalue for procedure pointer assignments. */
3411 gfc_component
*comp
;
3414 attr
= gfc_expr_attr (rvalue
);
3415 if (!((rvalue
->expr_type
== EXPR_NULL
)
3416 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3417 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3418 || (rvalue
->expr_type
== EXPR_VARIABLE
3419 && attr
.flavor
== FL_PROCEDURE
)))
3421 gfc_error ("Invalid procedure pointer assignment at %L",
3425 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3427 /* Check for intrinsics. */
3428 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3429 if (!sym
->attr
.intrinsic
3430 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3431 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3433 sym
->attr
.intrinsic
= 1;
3434 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3435 attr
= gfc_expr_attr (rvalue
);
3437 /* Check for result of embracing function. */
3438 if (sym
->attr
.function
&& sym
->result
== sym
)
3442 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3443 if (sym
== ns
->proc_name
)
3445 gfc_error ("Function result '%s' is invalid as proc-target "
3446 "in procedure pointer assignment at %L",
3447 sym
->name
, &rvalue
->where
);
3454 gfc_error ("Abstract interface '%s' is invalid "
3455 "in procedure pointer assignment at %L",
3456 rvalue
->symtree
->name
, &rvalue
->where
);
3459 /* Check for F08:C729. */
3460 if (attr
.flavor
== FL_PROCEDURE
)
3462 if (attr
.proc
== PROC_ST_FUNCTION
)
3464 gfc_error ("Statement function '%s' is invalid "
3465 "in procedure pointer assignment at %L",
3466 rvalue
->symtree
->name
, &rvalue
->where
);
3469 if (attr
.proc
== PROC_INTERNAL
&&
3470 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure '%s' "
3471 "is invalid in procedure pointer assignment "
3472 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3474 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3475 attr
.subroutine
) == 0)
3477 gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer "
3478 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3482 /* Check for F08:C730. */
3483 if (attr
.elemental
&& !attr
.intrinsic
)
3485 gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
3486 "in procedure pointer assignment at %L",
3487 rvalue
->symtree
->name
, &rvalue
->where
);
3491 /* Ensure that the calling convention is the same. As other attributes
3492 such as DLLEXPORT may differ, one explicitly only tests for the
3493 calling conventions. */
3494 if (rvalue
->expr_type
== EXPR_VARIABLE
3495 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3496 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3498 symbol_attribute calls
;
3501 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3502 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3503 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3505 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3506 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3508 gfc_error ("Mismatch in the procedure pointer assignment "
3509 "at %L: mismatch in the calling convention",
3515 comp
= gfc_get_proc_ptr_comp (lvalue
);
3517 s1
= comp
->ts
.interface
;
3520 s1
= lvalue
->symtree
->n
.sym
;
3521 if (s1
->ts
.interface
)
3522 s1
= s1
->ts
.interface
;
3525 comp
= gfc_get_proc_ptr_comp (rvalue
);
3528 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3530 s2
= comp
->ts
.interface
->result
;
3535 s2
= comp
->ts
.interface
;
3539 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3541 if (rvalue
->value
.function
.esym
)
3542 s2
= rvalue
->value
.function
.esym
->result
;
3544 s2
= rvalue
->symtree
->n
.sym
->result
;
3550 s2
= rvalue
->symtree
->n
.sym
;
3554 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3555 s2
= s2
->ts
.interface
;
3557 if (s1
== s2
|| !s1
|| !s2
)
3560 /* F08:7.2.2.4 (4) */
3561 if (s1
->attr
.if_source
== IFSRC_UNKNOWN
3562 && gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3564 gfc_error ("Explicit interface required for '%s' at %L: %s",
3565 s1
->name
, &lvalue
->where
, err
);
3568 if (s2
->attr
.if_source
== IFSRC_UNKNOWN
3569 && gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3571 gfc_error ("Explicit interface required for '%s' at %L: %s",
3572 s2
->name
, &rvalue
->where
, err
);
3576 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3577 err
, sizeof(err
), NULL
, NULL
))
3579 gfc_error ("Interface mismatch in procedure pointer assignment "
3580 "at %L: %s", &rvalue
->where
, err
);
3584 if (!gfc_compare_interfaces (s2
, s1
, name
, 0, 1,
3585 err
, sizeof(err
), NULL
, NULL
))
3587 gfc_error ("Interface mismatch in procedure pointer assignment "
3588 "at %L: %s", &rvalue
->where
, err
);
3595 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3597 /* Check for F03:C717. */
3598 if (UNLIMITED_POLY (rvalue
)
3599 && !(UNLIMITED_POLY (lvalue
)
3600 || (lvalue
->ts
.type
== BT_DERIVED
3601 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3602 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3603 gfc_error ("Data-pointer-object &L must be unlimited "
3604 "polymorphic, a sequence derived type or of a "
3605 "type with the BIND attribute assignment at %L "
3606 "to be compatible with an unlimited polymorphic "
3607 "target", &lvalue
->where
);
3609 gfc_error ("Different types in pointer assignment at %L; "
3610 "attempted assignment of %s to %s", &lvalue
->where
,
3611 gfc_typename (&rvalue
->ts
),
3612 gfc_typename (&lvalue
->ts
));
3616 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3618 gfc_error ("Different kind type parameters in pointer "
3619 "assignment at %L", &lvalue
->where
);
3623 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3625 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3629 /* Make sure the vtab is present. */
3630 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3631 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3632 else if (UNLIMITED_POLY (lvalue
) && !UNLIMITED_POLY (rvalue
))
3633 gfc_find_intrinsic_vtab (&rvalue
->ts
);
3635 /* Check rank remapping. */
3640 /* If this can be determined, check that the target must be at least as
3641 large as the pointer assigned to it is. */
3642 if (gfc_array_size (lvalue
, &lsize
)
3643 && gfc_array_size (rvalue
, &rsize
)
3644 && mpz_cmp (rsize
, lsize
) < 0)
3646 gfc_error ("Rank remapping target is smaller than size of the"
3647 " pointer (%ld < %ld) at %L",
3648 mpz_get_si (rsize
), mpz_get_si (lsize
),
3653 /* The target must be either rank one or it must be simply contiguous
3654 and F2008 must be allowed. */
3655 if (rvalue
->rank
!= 1)
3657 if (!gfc_is_simply_contiguous (rvalue
, true))
3659 gfc_error ("Rank remapping target must be rank 1 or"
3660 " simply contiguous at %L", &rvalue
->where
);
3663 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3664 "rank 1 at %L", &rvalue
->where
))
3669 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3670 if (rvalue
->expr_type
== EXPR_NULL
)
3673 if (lvalue
->ts
.type
== BT_CHARACTER
)
3675 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3680 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3681 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3683 attr
= gfc_expr_attr (rvalue
);
3685 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3687 gfc_error ("Target expression in pointer assignment "
3688 "at %L must deliver a pointer result",
3693 if (!attr
.target
&& !attr
.pointer
)
3695 gfc_error ("Pointer assignment target is neither TARGET "
3696 "nor POINTER at %L", &rvalue
->where
);
3700 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3702 gfc_error ("Bad target in pointer assignment in PURE "
3703 "procedure at %L", &rvalue
->where
);
3706 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3707 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3710 if (gfc_has_vector_index (rvalue
))
3712 gfc_error ("Pointer assignment with vector subscript "
3713 "on rhs at %L", &rvalue
->where
);
3717 if (attr
.is_protected
&& attr
.use_assoc
3718 && !(attr
.pointer
|| attr
.proc_pointer
))
3720 gfc_error ("Pointer assignment target has PROTECTED "
3721 "attribute at %L", &rvalue
->where
);
3725 /* F2008, C725. For PURE also C1283. */
3726 if (rvalue
->expr_type
== EXPR_VARIABLE
3727 && gfc_is_coindexed (rvalue
))
3730 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3731 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3733 gfc_error ("Data target at %L shall not have a coindex",
3739 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3740 if (gfc_option
.warn_target_lifetime
3741 && rvalue
->expr_type
== EXPR_VARIABLE
3742 && !rvalue
->symtree
->n
.sym
->attr
.save
3743 && !attr
.pointer
&& !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3744 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3745 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3746 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3751 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3752 || lvalue
->symtree
->n
.sym
->attr
.result
3753 || lvalue
->symtree
->n
.sym
->attr
.function
3754 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3755 && lvalue
->symtree
->n
.sym
->ns
3756 != rvalue
->symtree
->n
.sym
->ns
)
3757 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3758 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3760 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3761 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3762 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3763 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3764 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3766 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3773 gfc_warning ("Pointer at %L in pointer assignment might outlive the "
3774 "pointer target", &lvalue
->where
);
3781 /* Relative of gfc_check_assign() except that the lvalue is a single
3782 symbol. Used for initialization assignments. */
3785 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3789 bool pointer
, proc_pointer
;
3791 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3793 lvalue
.expr_type
= EXPR_VARIABLE
;
3794 lvalue
.ts
= sym
->ts
;
3796 lvalue
.rank
= sym
->as
->rank
;
3797 lvalue
.symtree
= XCNEW (gfc_symtree
);
3798 lvalue
.symtree
->n
.sym
= sym
;
3799 lvalue
.where
= sym
->declared_at
;
3803 lvalue
.ref
= gfc_get_ref ();
3804 lvalue
.ref
->type
= REF_COMPONENT
;
3805 lvalue
.ref
->u
.c
.component
= comp
;
3806 lvalue
.ref
->u
.c
.sym
= sym
;
3807 lvalue
.ts
= comp
->ts
;
3808 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3809 lvalue
.where
= comp
->loc
;
3810 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3811 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3812 proc_pointer
= comp
->attr
.proc_pointer
;
3816 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3817 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
3818 proc_pointer
= sym
->attr
.proc_pointer
;
3821 if (pointer
|| proc_pointer
)
3822 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3824 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3826 free (lvalue
.symtree
);
3831 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3833 /* F08:C461. Additional checks for pointer initialization. */
3834 symbol_attribute attr
;
3835 attr
= gfc_expr_attr (rvalue
);
3836 if (attr
.allocatable
)
3838 gfc_error ("Pointer initialization target at %L "
3839 "must not be ALLOCATABLE", &rvalue
->where
);
3842 if (!attr
.target
|| attr
.pointer
)
3844 gfc_error ("Pointer initialization target at %L "
3845 "must have the TARGET attribute", &rvalue
->where
);
3849 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
3850 && rvalue
->symtree
->n
.sym
->ns
->proc_name
3851 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
3853 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
3854 attr
.save
= SAVE_IMPLICIT
;
3859 gfc_error ("Pointer initialization target at %L "
3860 "must have the SAVE attribute", &rvalue
->where
);
3865 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3867 /* F08:C1220. Additional checks for procedure pointer initialization. */
3868 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3869 if (attr
.proc_pointer
)
3871 gfc_error ("Procedure pointer initialization target at %L "
3872 "may not be a procedure pointer", &rvalue
->where
);
3881 /* Check for default initializer; sym->value is not enough
3882 as it is also set for EXPR_NULL of allocatables. */
3885 gfc_has_default_initializer (gfc_symbol
*der
)
3889 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3890 for (c
= der
->components
; c
; c
= c
->next
)
3891 if (c
->ts
.type
== BT_DERIVED
)
3893 if (!c
->attr
.pointer
3894 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3896 if (c
->attr
.pointer
&& c
->initializer
)
3909 /* Get an expression for a default initializer. */
3912 gfc_default_initializer (gfc_typespec
*ts
)
3915 gfc_component
*comp
;
3917 /* See if we have a default initializer in this, but not in nested
3918 types (otherwise we could use gfc_has_default_initializer()). */
3919 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3920 if (comp
->initializer
|| comp
->attr
.allocatable
3921 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3922 && CLASS_DATA (comp
)->attr
.allocatable
))
3928 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3929 &ts
->u
.derived
->declared_at
);
3932 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3934 gfc_constructor
*ctor
= gfc_constructor_get();
3936 if (comp
->initializer
)
3938 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3939 if ((comp
->ts
.type
!= comp
->initializer
->ts
.type
3940 || comp
->ts
.kind
!= comp
->initializer
->ts
.kind
)
3941 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
3942 gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 2, false);
3945 if (comp
->attr
.allocatable
3946 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3948 ctor
->expr
= gfc_get_expr ();
3949 ctor
->expr
->expr_type
= EXPR_NULL
;
3950 ctor
->expr
->ts
= comp
->ts
;
3953 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3960 /* Given a symbol, create an expression node with that symbol as a
3961 variable. If the symbol is array valued, setup a reference of the
3965 gfc_get_variable_expr (gfc_symtree
*var
)
3969 e
= gfc_get_expr ();
3970 e
->expr_type
= EXPR_VARIABLE
;
3972 e
->ts
= var
->n
.sym
->ts
;
3974 if ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
3975 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
3976 && CLASS_DATA (var
->n
.sym
)->as
))
3978 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
3979 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
3980 e
->ref
= gfc_get_ref ();
3981 e
->ref
->type
= REF_ARRAY
;
3982 e
->ref
->u
.ar
.type
= AR_FULL
;
3983 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
3984 ? CLASS_DATA (var
->n
.sym
)->as
3992 /* Adds a full array reference to an expression, as needed. */
3995 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
3998 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4003 ref
->next
= gfc_get_ref ();
4008 e
->ref
= gfc_get_ref ();
4011 ref
->type
= REF_ARRAY
;
4012 ref
->u
.ar
.type
= AR_FULL
;
4013 ref
->u
.ar
.dimen
= e
->rank
;
4014 ref
->u
.ar
.where
= e
->where
;
4020 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4023 lval
= gfc_get_expr ();
4024 lval
->expr_type
= EXPR_VARIABLE
;
4025 lval
->where
= sym
->declared_at
;
4027 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4029 /* It will always be a full array. */
4030 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
4032 gfc_add_full_array_ref (lval
, sym
->ts
.type
== BT_CLASS
?
4033 CLASS_DATA (sym
)->as
: sym
->as
);
4038 /* Returns the array_spec of a full array expression. A NULL is
4039 returned otherwise. */
4041 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4046 if (expr
->rank
== 0)
4049 /* Follow any component references. */
4050 if (expr
->expr_type
== EXPR_VARIABLE
4051 || expr
->expr_type
== EXPR_CONSTANT
)
4053 as
= expr
->symtree
->n
.sym
->as
;
4054 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4059 as
= ref
->u
.c
.component
->as
;
4067 switch (ref
->u
.ar
.type
)
4090 /* General expression traversal function. */
4093 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4094 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4099 gfc_actual_arglist
*args
;
4106 if ((*func
) (expr
, sym
, &f
))
4109 if (expr
->ts
.type
== BT_CHARACTER
4111 && expr
->ts
.u
.cl
->length
4112 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4113 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4116 switch (expr
->expr_type
)
4121 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4123 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4131 case EXPR_SUBSTRING
:
4134 case EXPR_STRUCTURE
:
4136 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4137 c
; c
= gfc_constructor_next (c
))
4139 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4143 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4145 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4147 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4149 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4156 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4158 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4174 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4176 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4178 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4180 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4186 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4188 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4193 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4194 && ref
->u
.c
.component
->ts
.u
.cl
4195 && ref
->u
.c
.component
->ts
.u
.cl
->length
4196 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4198 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4202 if (ref
->u
.c
.component
->as
)
4203 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4204 + ref
->u
.c
.component
->as
->corank
; i
++)
4206 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4209 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4223 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4226 expr_set_symbols_referenced (gfc_expr
*expr
,
4227 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4228 int *f ATTRIBUTE_UNUSED
)
4230 if (expr
->expr_type
!= EXPR_VARIABLE
)
4232 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4237 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4239 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4243 /* Determine if an expression is a procedure pointer component and return
4244 the component in that case. Otherwise return NULL. */
4247 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4251 if (!expr
|| !expr
->ref
)
4258 if (ref
->type
== REF_COMPONENT
4259 && ref
->u
.c
.component
->attr
.proc_pointer
)
4260 return ref
->u
.c
.component
;
4266 /* Determine if an expression is a procedure pointer component. */
4269 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4271 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4275 /* Walk an expression tree and check each variable encountered for being typed.
4276 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4277 mode as is a basic arithmetic expression using those; this is for things in
4280 INTEGER :: arr(n), n
4281 INTEGER :: arr(n + 1), n
4283 The namespace is needed for IMPLICIT typing. */
4285 static gfc_namespace
* check_typed_ns
;
4288 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4289 int* f ATTRIBUTE_UNUSED
)
4293 if (e
->expr_type
!= EXPR_VARIABLE
)
4296 gcc_assert (e
->symtree
);
4297 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4304 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4308 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4312 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4313 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4315 if (e
->expr_type
== EXPR_OP
)
4319 gcc_assert (e
->value
.op
.op1
);
4320 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4322 if (t
&& e
->value
.op
.op2
)
4323 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4329 /* Otherwise, walk the expression and do it strictly. */
4330 check_typed_ns
= ns
;
4331 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4333 return error_found
? false : true;
4338 gfc_ref_this_image (gfc_ref
*ref
)
4342 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
4344 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4345 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4353 gfc_is_coindexed (gfc_expr
*e
)
4357 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4358 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4359 return !gfc_ref_this_image (ref
);
4365 /* Coarrays are variables with a corank but not being coindexed. However, also
4366 the following is a coarray: A subobject of a coarray is a coarray if it does
4367 not have any cosubscripts, vector subscripts, allocatable component
4368 selection, or pointer component selection. (F2008, 2.4.7) */
4371 gfc_is_coarray (gfc_expr
*e
)
4375 gfc_component
*comp
;
4380 if (e
->expr_type
!= EXPR_VARIABLE
)
4384 sym
= e
->symtree
->n
.sym
;
4386 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
4387 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
4389 coarray
= sym
->attr
.codimension
;
4391 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4395 comp
= ref
->u
.c
.component
;
4396 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
4397 && (CLASS_DATA (comp
)->attr
.class_pointer
4398 || CLASS_DATA (comp
)->attr
.allocatable
))
4401 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
4403 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
4406 coarray
= comp
->attr
.codimension
;
4414 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
4420 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4421 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4432 return coarray
&& !coindexed
;
4437 gfc_get_corank (gfc_expr
*e
)
4442 if (!gfc_is_coarray (e
))
4445 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
4446 corank
= e
->ts
.u
.derived
->components
->as
4447 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
4449 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4451 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4453 if (ref
->type
== REF_ARRAY
)
4454 corank
= ref
->u
.ar
.as
->corank
;
4455 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4462 /* Check whether the expression has an ultimate allocatable component.
4463 Being itself allocatable does not count. */
4465 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4467 gfc_ref
*ref
, *last
= NULL
;
4469 if (e
->expr_type
!= EXPR_VARIABLE
)
4472 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4473 if (ref
->type
== REF_COMPONENT
)
4476 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4477 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4478 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4479 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4483 if (e
->ts
.type
== BT_CLASS
)
4484 return CLASS_DATA (e
)->attr
.alloc_comp
;
4485 else if (e
->ts
.type
== BT_DERIVED
)
4486 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4492 /* Check whether the expression has an pointer component.
4493 Being itself a pointer does not count. */
4495 gfc_has_ultimate_pointer (gfc_expr
*e
)
4497 gfc_ref
*ref
, *last
= NULL
;
4499 if (e
->expr_type
!= EXPR_VARIABLE
)
4502 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4503 if (ref
->type
== REF_COMPONENT
)
4506 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4507 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4508 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4509 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4513 if (e
->ts
.type
== BT_CLASS
)
4514 return CLASS_DATA (e
)->attr
.pointer_comp
;
4515 else if (e
->ts
.type
== BT_DERIVED
)
4516 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4522 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4523 Note: A scalar is not regarded as "simply contiguous" by the standard.
4524 if bool is not strict, some further checks are done - for instance,
4525 a "(::1)" is accepted. */
4528 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4532 gfc_array_ref
*ar
= NULL
;
4533 gfc_ref
*ref
, *part_ref
= NULL
;
4536 if (expr
->expr_type
== EXPR_FUNCTION
)
4537 return expr
->value
.function
.esym
4538 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4539 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4542 if (expr
->rank
== 0)
4545 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4548 return false; /* Array shall be last part-ref. */
4550 if (ref
->type
== REF_COMPONENT
)
4552 else if (ref
->type
== REF_SUBSTRING
)
4554 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4558 sym
= expr
->symtree
->n
.sym
;
4559 if (expr
->ts
.type
!= BT_CLASS
4561 && !part_ref
->u
.c
.component
->attr
.contiguous
4562 && part_ref
->u
.c
.component
->attr
.pointer
)
4564 && !sym
->attr
.contiguous
4565 && (sym
->attr
.pointer
4566 || sym
->as
->type
== AS_ASSUMED_RANK
4567 || sym
->as
->type
== AS_ASSUMED_SHAPE
))))
4570 if (!ar
|| ar
->type
== AR_FULL
)
4573 gcc_assert (ar
->type
== AR_SECTION
);
4575 /* Check for simply contiguous array */
4577 for (i
= 0; i
< ar
->dimen
; i
++)
4579 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4582 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4588 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4591 /* If the previous section was not contiguous, that's an error,
4592 unless we have effective only one element and checking is not
4594 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4595 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4596 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4597 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4598 ar
->end
[i
]->value
.integer
) != 0))
4601 /* Following the standard, "(::1)" or - if known at compile time -
4602 "(lbound:ubound)" are not simply contiguous; if strict
4603 is false, they are regarded as simply contiguous. */
4604 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4605 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4606 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4610 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4611 || !ar
->as
->lower
[i
]
4612 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4613 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4614 ar
->as
->lower
[i
]->value
.integer
) != 0))
4618 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4619 || !ar
->as
->upper
[i
]
4620 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4621 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4622 ar
->as
->upper
[i
]->value
.integer
) != 0))
4630 /* Build call to an intrinsic procedure. The number of arguments has to be
4631 passed (rather than ending the list with a NULL value) because we may
4632 want to add arguments but with a NULL-expression. */
4635 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
4636 locus where
, unsigned numarg
, ...)
4639 gfc_actual_arglist
* atail
;
4640 gfc_intrinsic_sym
* isym
;
4643 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
4645 isym
= gfc_intrinsic_function_by_id (id
);
4648 result
= gfc_get_expr ();
4649 result
->expr_type
= EXPR_FUNCTION
;
4650 result
->ts
= isym
->ts
;
4651 result
->where
= where
;
4652 result
->value
.function
.name
= mangled_name
;
4653 result
->value
.function
.isym
= isym
;
4655 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
4656 gfc_commit_symbol (result
->symtree
->n
.sym
);
4657 gcc_assert (result
->symtree
4658 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
4659 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
4660 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
4661 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4662 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
4663 result
->symtree
->n
.sym
->attr
.artificial
= 1;
4665 va_start (ap
, numarg
);
4667 for (i
= 0; i
< numarg
; ++i
)
4671 atail
->next
= gfc_get_actual_arglist ();
4672 atail
= atail
->next
;
4675 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4677 atail
->expr
= va_arg (ap
, gfc_expr
*);
4685 /* Check if an expression may appear in a variable definition context
4686 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4687 This is called from the various places when resolving
4688 the pieces that make up such a context.
4689 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
4690 variables), some checks are not performed.
4692 Optionally, a possible error message can be suppressed if context is NULL
4693 and just the return status (true / false) be requested. */
4696 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
4697 bool own_scope
, const char* context
)
4699 gfc_symbol
* sym
= NULL
;
4701 bool check_intentin
;
4704 symbol_attribute attr
;
4708 if (e
->expr_type
== EXPR_VARIABLE
)
4710 gcc_assert (e
->symtree
);
4711 sym
= e
->symtree
->n
.sym
;
4713 else if (e
->expr_type
== EXPR_FUNCTION
)
4715 gcc_assert (e
->symtree
);
4716 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
4719 unlimited
= e
->ts
.type
== BT_CLASS
&& UNLIMITED_POLY (sym
);
4721 attr
= gfc_expr_attr (e
);
4722 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
4724 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4727 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4728 " context (%s) at %L", context
, &e
->where
);
4732 else if (e
->expr_type
!= EXPR_VARIABLE
)
4735 gfc_error ("Non-variable expression in variable definition context (%s)"
4736 " at %L", context
, &e
->where
);
4740 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4743 gfc_error ("Named constant '%s' in variable definition context (%s)"
4744 " at %L", sym
->name
, context
, &e
->where
);
4747 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4748 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4749 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4752 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4753 " a variable", sym
->name
, context
, &e
->where
);
4757 /* Find out whether the expr is a pointer; this also means following
4758 component references to the last one. */
4759 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4760 if (pointer
&& !is_pointer
&& !unlimited
)
4763 gfc_error ("Non-POINTER in pointer association context (%s)"
4764 " at %L", context
, &e
->where
);
4771 || (e
->ts
.type
== BT_DERIVED
4772 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
4773 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
4776 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
4777 context
, &e
->where
);
4781 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
4782 component of sub-component of a pointer; we need to distinguish
4783 assignment to a pointer component from pointer-assignment to a pointer
4784 component. Note that (normal) assignment to procedure pointers is not
4786 check_intentin
= !own_scope
;
4787 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4788 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4789 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4791 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4792 check_intentin
= false;
4793 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4795 ptr_component
= true;
4797 check_intentin
= false;
4800 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4802 if (pointer
&& is_pointer
)
4805 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4806 " association context (%s) at %L",
4807 sym
->name
, context
, &e
->where
);
4810 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
4813 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4814 " definition context (%s) at %L",
4815 sym
->name
, context
, &e
->where
);
4820 /* PROTECTED and use-associated. */
4821 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4823 if (pointer
&& is_pointer
)
4826 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4827 " pointer association context (%s) at %L",
4828 sym
->name
, context
, &e
->where
);
4831 if (!pointer
&& !is_pointer
)
4834 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4835 " variable definition context (%s) at %L",
4836 sym
->name
, context
, &e
->where
);
4841 /* Variable not assignable from a PURE procedure but appears in
4842 variable definition context. */
4843 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4846 gfc_error ("Variable '%s' can not appear in a variable definition"
4847 " context (%s) at %L in PURE procedure",
4848 sym
->name
, context
, &e
->where
);
4852 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
4853 && gfc_impure_variable (sym
))
4858 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
4860 sym
= ns
->proc_name
;
4863 if (sym
->attr
.flavor
== FL_PROCEDURE
)
4865 sym
->attr
.implicit_pure
= 0;
4870 /* Check variable definition context for associate-names. */
4871 if (!pointer
&& sym
->assoc
)
4874 gfc_association_list
* assoc
;
4876 gcc_assert (sym
->assoc
->target
);
4878 /* If this is a SELECT TYPE temporary (the association is used internally
4879 for SELECT TYPE), silently go over to the target. */
4880 if (sym
->attr
.select_type_temporary
)
4882 gfc_expr
* t
= sym
->assoc
->target
;
4884 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4885 name
= t
->symtree
->name
;
4887 if (t
->symtree
->n
.sym
->assoc
)
4888 assoc
= t
->symtree
->n
.sym
->assoc
;
4897 gcc_assert (name
&& assoc
);
4899 /* Is association to a valid variable? */
4900 if (!assoc
->variable
)
4904 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4905 gfc_error ("'%s' at %L associated to vector-indexed target can"
4906 " not be used in a variable definition context (%s)",
4907 name
, &e
->where
, context
);
4909 gfc_error ("'%s' at %L associated to expression can"
4910 " not be used in a variable definition context (%s)",
4911 name
, &e
->where
, context
);
4916 /* Target must be allowed to appear in a variable definition context. */
4917 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
4920 gfc_error ("Associate-name '%s' can not appear in a variable"
4921 " definition context (%s) at %L because its target"
4922 " at %L can not, either",
4923 name
, context
, &e
->where
,
4924 &assoc
->target
->where
);
4929 /* Check for same value in vector expression subscript. */
4932 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
4933 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
4934 for (i
= 0; i
< GFC_MAX_DIMENSIONS
4935 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
4936 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4938 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
4939 if (arr
->expr_type
== EXPR_ARRAY
)
4941 gfc_constructor
*c
, *n
;
4944 for (c
= gfc_constructor_first (arr
->value
.constructor
);
4945 c
!= NULL
; c
= gfc_constructor_next (c
))
4947 if (c
== NULL
|| c
->iterator
!= NULL
)
4952 for (n
= gfc_constructor_next (c
); n
!= NULL
;
4953 n
= gfc_constructor_next (n
))
4955 if (n
->iterator
!= NULL
)
4959 if (gfc_dep_compare_expr (ec
, en
) == 0)
4961 gfc_error_now ("Elements with the same value at %L"
4962 " and %L in vector subscript"
4963 " in a variable definition"
4964 " context (%s)", &(ec
->where
),
4965 &(en
->where
), context
);