1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #include "constructor.h"
32 /* The following set of functions provide access to gfc_expr* of
33 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
35 There are two functions available elsewhere that provide
36 slightly different flavours of variables. Namely:
37 expr.c (gfc_get_variable_expr)
38 symbol.c (gfc_lval_expr_from_sym)
39 TODO: Merge these functions, if possible. */
41 /* Get a new expression node. */
49 gfc_clear_ts (&e
->ts
);
57 /* Get a new expression node that is an array constructor
58 of given type and kind. */
61 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
66 e
->expr_type
= EXPR_ARRAY
;
67 e
->value
.constructor
= NULL
;
80 /* Get a new expression node that is the NULL expression. */
83 gfc_get_null_expr (locus
*where
)
88 e
->expr_type
= EXPR_NULL
;
89 e
->ts
.type
= BT_UNKNOWN
;
98 /* Get a new expression node that is an operator expression node. */
101 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
102 gfc_expr
*op1
, gfc_expr
*op2
)
107 e
->expr_type
= EXPR_OP
;
109 e
->value
.op
.op1
= op1
;
110 e
->value
.op
.op2
= op2
;
119 /* Get a new expression node that is an structure constructor
120 of given type and kind. */
123 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
128 e
->expr_type
= EXPR_STRUCTURE
;
129 e
->value
.constructor
= NULL
;
140 /* Get a new expression node that is an constant of given type and kind. */
143 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
148 gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
152 e
->expr_type
= EXPR_CONSTANT
;
160 mpz_init (e
->value
.integer
);
164 gfc_set_model_kind (kind
);
165 mpfr_init (e
->value
.real
);
169 gfc_set_model_kind (kind
);
170 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
181 /* Get a new expression node that is an string constant.
182 If no string is passed, a string of len is allocated,
183 blanked and null-terminated. */
186 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, int len
)
193 dest
= gfc_get_wide_string (len
+ 1);
194 gfc_wide_memset (dest
, ' ', len
);
198 dest
= gfc_char_to_widechar (src
);
200 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
201 where
? where
: &gfc_current_locus
);
202 e
->value
.character
.string
= dest
;
203 e
->value
.character
.length
= len
;
209 /* Get a new expression node that is an integer constant. */
212 gfc_get_int_expr (int kind
, locus
*where
, int value
)
215 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
216 where
? where
: &gfc_current_locus
);
218 mpz_set_si (p
->value
.integer
, value
);
224 /* Get a new expression node that is a logical constant. */
227 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
230 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
231 where
? where
: &gfc_current_locus
);
233 p
->value
.logical
= value
;
240 gfc_get_iokind_expr (locus
*where
, io_kind k
)
244 /* Set the types to something compatible with iokind. This is needed to
245 get through gfc_free_expr later since iokind really has no Basic Type,
249 e
->expr_type
= EXPR_CONSTANT
;
250 e
->ts
.type
= BT_LOGICAL
;
258 /* Given an expression pointer, return a copy of the expression. This
259 subroutine is recursive. */
262 gfc_copy_expr (gfc_expr
*p
)
274 switch (q
->expr_type
)
277 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
278 q
->value
.character
.string
= s
;
279 memcpy (s
, p
->value
.character
.string
,
280 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
284 /* Copy target representation, if it exists. */
285 if (p
->representation
.string
)
287 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
288 q
->representation
.string
= c
;
289 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
292 /* Copy the values of any pointer components of p->value. */
296 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
300 gfc_set_model_kind (q
->ts
.kind
);
301 mpfr_init (q
->value
.real
);
302 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
306 gfc_set_model_kind (q
->ts
.kind
);
307 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
308 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
312 if (p
->representation
.string
)
313 q
->value
.character
.string
314 = gfc_char_to_widechar (q
->representation
.string
);
317 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
318 q
->value
.character
.string
= s
;
320 /* This is the case for the C_NULL_CHAR named constant. */
321 if (p
->value
.character
.length
== 0
322 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
325 /* Need to set the length to 1 to make sure the NUL
326 terminator is copied. */
327 q
->value
.character
.length
= 1;
330 memcpy (s
, p
->value
.character
.string
,
331 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
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
);
399 /* Workhorse function for gfc_free_expr() that frees everything
400 beneath an expression node, but not the node itself. This is
401 useful when we want to simplify a node and replace it with
402 something else or the expression node belongs to another structure. */
405 free_expr0 (gfc_expr
*e
)
409 switch (e
->expr_type
)
412 /* Free any parts of the value that need freeing. */
416 mpz_clear (e
->value
.integer
);
420 mpfr_clear (e
->value
.real
);
424 gfc_free (e
->value
.character
.string
);
428 mpc_clear (e
->value
.complex);
435 /* Free the representation. */
436 if (e
->representation
.string
)
437 gfc_free (e
->representation
.string
);
442 if (e
->value
.op
.op1
!= NULL
)
443 gfc_free_expr (e
->value
.op
.op1
);
444 if (e
->value
.op
.op2
!= NULL
)
445 gfc_free_expr (e
->value
.op
.op2
);
449 gfc_free_actual_arglist (e
->value
.function
.actual
);
454 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
462 gfc_constructor_free (e
->value
.constructor
);
466 gfc_free (e
->value
.character
.string
);
473 gfc_internal_error ("free_expr0(): Bad expr type");
476 /* Free a shape array. */
477 if (e
->shape
!= NULL
)
479 for (n
= 0; n
< e
->rank
; n
++)
480 mpz_clear (e
->shape
[n
]);
485 gfc_free_ref_list (e
->ref
);
487 memset (e
, '\0', sizeof (gfc_expr
));
491 /* Free an expression node and everything beneath it. */
494 gfc_free_expr (gfc_expr
*e
)
503 /* Free an argument list and everything below it. */
506 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
508 gfc_actual_arglist
*a2
;
513 gfc_free_expr (a1
->expr
);
520 /* Copy an arglist structure and all of the arguments. */
523 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
525 gfc_actual_arglist
*head
, *tail
, *new_arg
;
529 for (; p
; p
= p
->next
)
531 new_arg
= gfc_get_actual_arglist ();
534 new_arg
->expr
= gfc_copy_expr (p
->expr
);
535 new_arg
->next
= NULL
;
540 tail
->next
= new_arg
;
549 /* Free a list of reference structures. */
552 gfc_free_ref_list (gfc_ref
*p
)
564 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
566 gfc_free_expr (p
->u
.ar
.start
[i
]);
567 gfc_free_expr (p
->u
.ar
.end
[i
]);
568 gfc_free_expr (p
->u
.ar
.stride
[i
]);
574 gfc_free_expr (p
->u
.ss
.start
);
575 gfc_free_expr (p
->u
.ss
.end
);
587 /* Graft the *src expression onto the *dest subexpression. */
590 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
598 /* Try to extract an integer constant from the passed expression node.
599 Returns an error message or NULL if the result is set. It is
600 tempting to generate an error and return SUCCESS or FAILURE, but
601 failure is OK for some callers. */
604 gfc_extract_int (gfc_expr
*expr
, int *result
)
606 if (expr
->expr_type
!= EXPR_CONSTANT
)
607 return _("Constant expression required at %C");
609 if (expr
->ts
.type
!= BT_INTEGER
)
610 return _("Integer expression required at %C");
612 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
613 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
615 return _("Integer value too large in expression at %C");
618 *result
= (int) mpz_get_si (expr
->value
.integer
);
624 /* Recursively copy a list of reference structures. */
627 gfc_copy_ref (gfc_ref
*src
)
635 dest
= gfc_get_ref ();
636 dest
->type
= src
->type
;
641 ar
= gfc_copy_array_ref (&src
->u
.ar
);
647 dest
->u
.c
= src
->u
.c
;
651 dest
->u
.ss
= src
->u
.ss
;
652 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
653 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
657 dest
->next
= gfc_copy_ref (src
->next
);
663 /* Detect whether an expression has any vector index array references. */
666 gfc_has_vector_index (gfc_expr
*e
)
670 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
671 if (ref
->type
== REF_ARRAY
)
672 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
673 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
679 /* Copy a shape array. */
682 gfc_copy_shape (mpz_t
*shape
, int rank
)
690 new_shape
= gfc_get_shape (rank
);
692 for (n
= 0; n
< rank
; n
++)
693 mpz_init_set (new_shape
[n
], shape
[n
]);
699 /* Copy a shape array excluding dimension N, where N is an integer
700 constant expression. Dimensions are numbered in fortran style --
703 So, if the original shape array contains R elements
704 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
705 the result contains R-1 elements:
706 { s1 ... sN-1 sN+1 ... sR-1}
708 If anything goes wrong -- N is not a constant, its value is out
709 of range -- or anything else, just returns NULL. */
712 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
714 mpz_t
*new_shape
, *s
;
720 || dim
->expr_type
!= EXPR_CONSTANT
721 || dim
->ts
.type
!= BT_INTEGER
)
724 n
= mpz_get_si (dim
->value
.integer
);
725 n
--; /* Convert to zero based index. */
726 if (n
< 0 || n
>= rank
)
729 s
= new_shape
= gfc_get_shape (rank
- 1);
731 for (i
= 0; i
< rank
; i
++)
735 mpz_init_set (*s
, shape
[i
]);
743 /* Return the maximum kind of two expressions. In general, higher
744 kind numbers mean more precision for numeric types. */
747 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
749 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
753 /* Returns nonzero if the type is numeric, zero otherwise. */
756 numeric_type (bt type
)
758 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
762 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
765 gfc_numeric_ts (gfc_typespec
*ts
)
767 return numeric_type (ts
->type
);
771 /* Return an expression node with an optional argument list attached.
772 A variable number of gfc_expr pointers are strung together in an
773 argument list with a NULL pointer terminating the list. */
776 gfc_build_conversion (gfc_expr
*e
)
781 p
->expr_type
= EXPR_FUNCTION
;
783 p
->value
.function
.actual
= NULL
;
785 p
->value
.function
.actual
= gfc_get_actual_arglist ();
786 p
->value
.function
.actual
->expr
= e
;
792 /* Given an expression node with some sort of numeric binary
793 expression, insert type conversions required to make the operands
794 have the same type. Conversion warnings are disabled if wconversion
797 The exception is that the operands of an exponential don't have to
798 have the same type. If possible, the base is promoted to the type
799 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
800 1.0**2 stays as it is. */
803 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
807 op1
= e
->value
.op
.op1
;
808 op2
= e
->value
.op
.op2
;
810 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
812 gfc_clear_ts (&e
->ts
);
816 /* Kind conversions of same type. */
817 if (op1
->ts
.type
== op2
->ts
.type
)
819 if (op1
->ts
.kind
== op2
->ts
.kind
)
821 /* No type conversions. */
826 if (op1
->ts
.kind
> op2
->ts
.kind
)
827 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
829 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
835 /* Integer combined with real or complex. */
836 if (op2
->ts
.type
== BT_INTEGER
)
840 /* Special case for ** operator. */
841 if (e
->value
.op
.op
== INTRINSIC_POWER
)
844 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
848 if (op1
->ts
.type
== BT_INTEGER
)
851 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
855 /* Real combined with complex. */
856 e
->ts
.type
= BT_COMPLEX
;
857 if (op1
->ts
.kind
> op2
->ts
.kind
)
858 e
->ts
.kind
= op1
->ts
.kind
;
860 e
->ts
.kind
= op2
->ts
.kind
;
861 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
862 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
863 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
864 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
871 /* Function to determine if an expression is constant or not. This
872 function expects that the expression has already been simplified. */
875 gfc_is_constant_expr (gfc_expr
*e
)
878 gfc_actual_arglist
*arg
;
884 switch (e
->expr_type
)
887 return (gfc_is_constant_expr (e
->value
.op
.op1
)
888 && (e
->value
.op
.op2
== NULL
889 || gfc_is_constant_expr (e
->value
.op
.op2
)));
897 /* Call to intrinsic with at least one argument. */
898 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
900 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
901 if (!gfc_is_constant_expr (arg
->expr
))
905 /* Make sure we have a symbol. */
906 gcc_assert (e
->symtree
);
908 sym
= e
->symtree
->n
.sym
;
910 /* Specification functions are constant. */
911 /* F95, 7.1.6.2; F2003, 7.1.7 */
913 && sym
->attr
.function
915 && !sym
->attr
.intrinsic
916 && !sym
->attr
.recursive
917 && sym
->attr
.proc
!= PROC_INTERNAL
918 && sym
->attr
.proc
!= PROC_ST_FUNCTION
919 && sym
->attr
.proc
!= PROC_UNKNOWN
920 && sym
->formal
== NULL
)
923 if (e
->value
.function
.isym
924 && (e
->value
.function
.isym
->elemental
925 || e
->value
.function
.isym
->pure
926 || e
->value
.function
.isym
->inquiry
927 || e
->value
.function
.isym
->transformational
))
937 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
938 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
942 c
= gfc_constructor_first (e
->value
.constructor
);
943 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
944 return gfc_constant_ac (e
);
946 for (; c
; c
= gfc_constructor_next (c
))
947 if (!gfc_is_constant_expr (c
->expr
))
954 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
960 /* Is true if an array reference is followed by a component or substring
963 is_subref_array (gfc_expr
* e
)
968 if (e
->expr_type
!= EXPR_VARIABLE
)
971 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
975 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
977 if (ref
->type
== REF_ARRAY
978 && ref
->u
.ar
.type
!= AR_ELEMENT
)
982 && ref
->type
!= REF_ARRAY
)
989 /* Try to collapse intrinsic expressions. */
992 simplify_intrinsic_op (gfc_expr
*p
, int type
)
995 gfc_expr
*op1
, *op2
, *result
;
997 if (p
->value
.op
.op
== INTRINSIC_USER
)
1000 op1
= p
->value
.op
.op1
;
1001 op2
= p
->value
.op
.op2
;
1002 op
= p
->value
.op
.op
;
1004 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1006 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1009 if (!gfc_is_constant_expr (op1
)
1010 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1014 p
->value
.op
.op1
= NULL
;
1015 p
->value
.op
.op2
= NULL
;
1019 case INTRINSIC_PARENTHESES
:
1020 result
= gfc_parentheses (op1
);
1023 case INTRINSIC_UPLUS
:
1024 result
= gfc_uplus (op1
);
1027 case INTRINSIC_UMINUS
:
1028 result
= gfc_uminus (op1
);
1031 case INTRINSIC_PLUS
:
1032 result
= gfc_add (op1
, op2
);
1035 case INTRINSIC_MINUS
:
1036 result
= gfc_subtract (op1
, op2
);
1039 case INTRINSIC_TIMES
:
1040 result
= gfc_multiply (op1
, op2
);
1043 case INTRINSIC_DIVIDE
:
1044 result
= gfc_divide (op1
, op2
);
1047 case INTRINSIC_POWER
:
1048 result
= gfc_power (op1
, op2
);
1051 case INTRINSIC_CONCAT
:
1052 result
= gfc_concat (op1
, op2
);
1056 case INTRINSIC_EQ_OS
:
1057 result
= gfc_eq (op1
, op2
, op
);
1061 case INTRINSIC_NE_OS
:
1062 result
= gfc_ne (op1
, op2
, op
);
1066 case INTRINSIC_GT_OS
:
1067 result
= gfc_gt (op1
, op2
, op
);
1071 case INTRINSIC_GE_OS
:
1072 result
= gfc_ge (op1
, op2
, op
);
1076 case INTRINSIC_LT_OS
:
1077 result
= gfc_lt (op1
, op2
, op
);
1081 case INTRINSIC_LE_OS
:
1082 result
= gfc_le (op1
, op2
, op
);
1086 result
= gfc_not (op1
);
1090 result
= gfc_and (op1
, op2
);
1094 result
= gfc_or (op1
, op2
);
1098 result
= gfc_eqv (op1
, op2
);
1101 case INTRINSIC_NEQV
:
1102 result
= gfc_neqv (op1
, op2
);
1106 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1111 gfc_free_expr (op1
);
1112 gfc_free_expr (op2
);
1116 result
->rank
= p
->rank
;
1117 result
->where
= p
->where
;
1118 gfc_replace_expr (p
, result
);
1124 /* Subroutine to simplify constructor expressions. Mutually recursive
1125 with gfc_simplify_expr(). */
1128 simplify_constructor (gfc_constructor_base base
, int type
)
1133 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1136 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1137 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1138 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1143 /* Try and simplify a copy. Replace the original if successful
1144 but keep going through the constructor at all costs. Not
1145 doing so can make a dog's dinner of complicated things. */
1146 p
= gfc_copy_expr (c
->expr
);
1148 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1154 gfc_replace_expr (c
->expr
, p
);
1162 /* Pull a single array element out of an array constructor. */
1165 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1166 gfc_constructor
**rval
)
1168 unsigned long nelemen
;
1174 gfc_constructor
*cons
;
1181 mpz_init_set_ui (offset
, 0);
1184 mpz_init_set_ui (span
, 1);
1185 for (i
= 0; i
< ar
->dimen
; i
++)
1187 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1188 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1195 e
= gfc_copy_expr (ar
->start
[i
]);
1196 if (e
->expr_type
!= EXPR_CONSTANT
)
1202 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1203 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1205 /* Check the bounds. */
1206 if ((ar
->as
->upper
[i
]
1207 && mpz_cmp (e
->value
.integer
,
1208 ar
->as
->upper
[i
]->value
.integer
) > 0)
1209 || (mpz_cmp (e
->value
.integer
,
1210 ar
->as
->lower
[i
]->value
.integer
) < 0))
1212 gfc_error ("Index in dimension %d is out of bounds "
1213 "at %L", i
+ 1, &ar
->c_where
[i
]);
1219 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1220 mpz_mul (delta
, delta
, span
);
1221 mpz_add (offset
, offset
, delta
);
1223 mpz_set_ui (tmp
, 1);
1224 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1225 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1226 mpz_mul (span
, span
, tmp
);
1229 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1230 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1251 /* Find a component of a structure constructor. */
1253 static gfc_constructor
*
1254 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1256 gfc_component
*comp
;
1257 gfc_component
*pick
;
1258 gfc_constructor
*c
= gfc_constructor_first (base
);
1260 comp
= ref
->u
.c
.sym
->components
;
1261 pick
= ref
->u
.c
.component
;
1262 while (comp
!= pick
)
1265 c
= gfc_constructor_next (c
);
1272 /* Replace an expression with the contents of a constructor, removing
1273 the subobject reference in the process. */
1276 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1286 e
= gfc_copy_expr (p
);
1287 e
->ref
= p
->ref
->next
;
1288 p
->ref
->next
= NULL
;
1289 gfc_replace_expr (p
, e
);
1293 /* Pull an array section out of an array constructor. */
1296 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1303 long unsigned one
= 1;
1305 mpz_t start
[GFC_MAX_DIMENSIONS
];
1306 mpz_t end
[GFC_MAX_DIMENSIONS
];
1307 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1308 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1309 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1314 gfc_constructor_base base
;
1315 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1325 base
= expr
->value
.constructor
;
1326 expr
->value
.constructor
= NULL
;
1328 rank
= ref
->u
.ar
.as
->rank
;
1330 if (expr
->shape
== NULL
)
1331 expr
->shape
= gfc_get_shape (rank
);
1333 mpz_init_set_ui (delta_mpz
, one
);
1334 mpz_init_set_ui (nelts
, one
);
1337 /* Do the initialization now, so that we can cleanup without
1338 keeping track of where we were. */
1339 for (d
= 0; d
< rank
; d
++)
1341 mpz_init (delta
[d
]);
1342 mpz_init (start
[d
]);
1345 mpz_init (stride
[d
]);
1349 /* Build the counters to clock through the array reference. */
1351 for (d
= 0; d
< rank
; d
++)
1353 /* Make this stretch of code easier on the eye! */
1354 begin
= ref
->u
.ar
.start
[d
];
1355 finish
= ref
->u
.ar
.end
[d
];
1356 step
= ref
->u
.ar
.stride
[d
];
1357 lower
= ref
->u
.ar
.as
->lower
[d
];
1358 upper
= ref
->u
.ar
.as
->upper
[d
];
1360 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1362 gfc_constructor
*ci
;
1365 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1371 gcc_assert (begin
->rank
== 1);
1372 /* Zero-sized arrays have no shape and no elements, stop early. */
1375 mpz_init_set_ui (nelts
, 0);
1379 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1380 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1381 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1382 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1385 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1387 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1388 || mpz_cmp (ci
->expr
->value
.integer
,
1389 lower
->value
.integer
) < 0)
1391 gfc_error ("index in dimension %d is out of bounds "
1392 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1400 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1401 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1402 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1408 /* Obtain the stride. */
1410 mpz_set (stride
[d
], step
->value
.integer
);
1412 mpz_set_ui (stride
[d
], one
);
1414 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1415 mpz_set_ui (stride
[d
], one
);
1417 /* Obtain the start value for the index. */
1419 mpz_set (start
[d
], begin
->value
.integer
);
1421 mpz_set (start
[d
], lower
->value
.integer
);
1423 mpz_set (ctr
[d
], start
[d
]);
1425 /* Obtain the end value for the index. */
1427 mpz_set (end
[d
], finish
->value
.integer
);
1429 mpz_set (end
[d
], upper
->value
.integer
);
1431 /* Separate 'if' because elements sometimes arrive with
1433 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1434 mpz_set (end
[d
], begin
->value
.integer
);
1436 /* Check the bounds. */
1437 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1438 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1439 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1440 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1442 gfc_error ("index in dimension %d is out of bounds "
1443 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1448 /* Calculate the number of elements and the shape. */
1449 mpz_set (tmp_mpz
, stride
[d
]);
1450 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1451 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1452 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1453 mpz_mul (nelts
, nelts
, tmp_mpz
);
1455 /* An element reference reduces the rank of the expression; don't
1456 add anything to the shape array. */
1457 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1458 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1461 /* Calculate the 'stride' (=delta) for conversion of the
1462 counter values into the index along the constructor. */
1463 mpz_set (delta
[d
], delta_mpz
);
1464 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1465 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1466 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1470 cons
= gfc_constructor_first (base
);
1472 /* Now clock through the array reference, calculating the index in
1473 the source constructor and transferring the elements to the new
1475 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1477 if (ref
->u
.ar
.offset
)
1478 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1480 mpz_init_set_ui (ptr
, 0);
1483 for (d
= 0; d
< rank
; d
++)
1485 mpz_set (tmp_mpz
, ctr
[d
]);
1486 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1487 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1488 mpz_add (ptr
, ptr
, tmp_mpz
);
1490 if (!incr_ctr
) continue;
1492 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1494 gcc_assert(vecsub
[d
]);
1496 if (!gfc_constructor_next (vecsub
[d
]))
1497 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1500 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1503 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1507 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1509 if (mpz_cmp_ui (stride
[d
], 0) > 0
1510 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1511 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1512 mpz_set (ctr
[d
], start
[d
]);
1518 limit
= mpz_get_ui (ptr
);
1519 if (limit
>= gfc_option
.flag_max_array_constructor
)
1521 gfc_error ("The number of elements in the array constructor "
1522 "at %L requires an increase of the allowed %d "
1523 "upper limit. See -fmax-array-constructor "
1524 "option", &expr
->where
,
1525 gfc_option
.flag_max_array_constructor
);
1529 cons
= gfc_constructor_lookup (base
, limit
);
1531 gfc_constructor_append_expr (&expr
->value
.constructor
,
1532 gfc_copy_expr (cons
->expr
), NULL
);
1539 mpz_clear (delta_mpz
);
1540 mpz_clear (tmp_mpz
);
1542 for (d
= 0; d
< rank
; d
++)
1544 mpz_clear (delta
[d
]);
1545 mpz_clear (start
[d
]);
1548 mpz_clear (stride
[d
]);
1550 gfc_constructor_free (base
);
1554 /* Pull a substring out of an expression. */
1557 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1564 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1565 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1568 *newp
= gfc_copy_expr (p
);
1569 gfc_free ((*newp
)->value
.character
.string
);
1571 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1572 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1573 length
= end
- start
+ 1;
1575 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1576 (*newp
)->value
.character
.length
= length
;
1577 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1578 length
* sizeof (gfc_char_t
));
1585 /* Simplify a subobject reference of a constructor. This occurs when
1586 parameter variable values are substituted. */
1589 simplify_const_ref (gfc_expr
*p
)
1591 gfc_constructor
*cons
, *c
;
1597 switch (p
->ref
->type
)
1600 switch (p
->ref
->u
.ar
.type
)
1603 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1604 will generate this. */
1605 if (p
->expr_type
!= EXPR_ARRAY
)
1607 remove_subobject_ref (p
, NULL
);
1610 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1617 remove_subobject_ref (p
, cons
);
1621 if (find_array_section (p
, p
->ref
) == FAILURE
)
1623 p
->ref
->u
.ar
.type
= AR_FULL
;
1628 if (p
->ref
->next
!= NULL
1629 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1631 for (c
= gfc_constructor_first (p
->value
.constructor
);
1632 c
; c
= gfc_constructor_next (c
))
1634 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1635 if (simplify_const_ref (c
->expr
) == FAILURE
)
1639 if (p
->ts
.type
== BT_DERIVED
1641 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1643 /* There may have been component references. */
1644 p
->ts
= c
->expr
->ts
;
1648 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1650 if (p
->ts
.type
== BT_CHARACTER
1651 && last_ref
->type
== REF_SUBSTRING
)
1653 /* If this is a CHARACTER array and we possibly took
1654 a substring out of it, update the type-spec's
1655 character length according to the first element
1656 (as all should have the same length). */
1658 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1660 const gfc_expr
* first
= c
->expr
;
1661 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1662 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1663 string_len
= first
->value
.character
.length
;
1669 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1672 gfc_free_expr (p
->ts
.u
.cl
->length
);
1675 = gfc_get_int_expr (gfc_default_integer_kind
,
1679 gfc_free_ref_list (p
->ref
);
1690 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1691 remove_subobject_ref (p
, cons
);
1695 if (find_substring_ref (p
, &newp
) == FAILURE
)
1698 gfc_replace_expr (p
, newp
);
1699 gfc_free_ref_list (p
->ref
);
1709 /* Simplify a chain of references. */
1712 simplify_ref_chain (gfc_ref
*ref
, int type
)
1716 for (; ref
; ref
= ref
->next
)
1721 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1723 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1725 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1727 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1733 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1735 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1747 /* Try to substitute the value of a parameter variable. */
1750 simplify_parameter_variable (gfc_expr
*p
, int type
)
1755 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1761 /* Do not copy subobject refs for constant. */
1762 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1763 e
->ref
= gfc_copy_ref (p
->ref
);
1764 t
= gfc_simplify_expr (e
, type
);
1766 /* Only use the simplification if it eliminated all subobject references. */
1767 if (t
== SUCCESS
&& !e
->ref
)
1768 gfc_replace_expr (p
, e
);
1775 /* Given an expression, simplify it by collapsing constant
1776 expressions. Most simplification takes place when the expression
1777 tree is being constructed. If an intrinsic function is simplified
1778 at some point, we get called again to collapse the result against
1781 We work by recursively simplifying expression nodes, simplifying
1782 intrinsic functions where possible, which can lead to further
1783 constant collapsing. If an operator has constant operand(s), we
1784 rip the expression apart, and rebuild it, hoping that it becomes
1787 The expression type is defined for:
1788 0 Basic expression parsing
1789 1 Simplifying array constructors -- will substitute
1791 Returns FAILURE on error, SUCCESS otherwise.
1792 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1795 gfc_simplify_expr (gfc_expr
*p
, int type
)
1797 gfc_actual_arglist
*ap
;
1802 switch (p
->expr_type
)
1809 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1810 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1813 if (p
->value
.function
.isym
!= NULL
1814 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1819 case EXPR_SUBSTRING
:
1820 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1823 if (gfc_is_constant_expr (p
))
1829 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1831 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1832 start
--; /* Convert from one-based to zero-based. */
1835 end
= p
->value
.character
.length
;
1836 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1837 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1839 s
= gfc_get_wide_string (end
- start
+ 2);
1840 memcpy (s
, p
->value
.character
.string
+ start
,
1841 (end
- start
) * sizeof (gfc_char_t
));
1842 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1843 gfc_free (p
->value
.character
.string
);
1844 p
->value
.character
.string
= s
;
1845 p
->value
.character
.length
= end
- start
;
1846 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1847 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1849 p
->value
.character
.length
);
1850 gfc_free_ref_list (p
->ref
);
1852 p
->expr_type
= EXPR_CONSTANT
;
1857 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1862 /* Only substitute array parameter variables if we are in an
1863 initialization expression, or we want a subsection. */
1864 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1865 && (gfc_init_expr_flag
|| p
->ref
1866 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1868 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1875 gfc_simplify_iterator_var (p
);
1878 /* Simplify subcomponent references. */
1879 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1884 case EXPR_STRUCTURE
:
1886 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1889 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1892 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1893 && p
->ref
->u
.ar
.type
== AR_FULL
)
1894 gfc_expand_constructor (p
, false);
1896 if (simplify_const_ref (p
) == FAILURE
)
1911 /* Returns the type of an expression with the exception that iterator
1912 variables are automatically integers no matter what else they may
1918 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1925 /* Check an intrinsic arithmetic operation to see if it is consistent
1926 with some type of expression. */
1928 static gfc_try
check_init_expr (gfc_expr
*);
1931 /* Scalarize an expression for an elemental intrinsic call. */
1934 scalarize_intrinsic_call (gfc_expr
*e
)
1936 gfc_actual_arglist
*a
, *b
;
1937 gfc_constructor_base ctor
;
1938 gfc_constructor
*args
[5];
1939 gfc_constructor
*ci
, *new_ctor
;
1940 gfc_expr
*expr
, *old
;
1941 int n
, i
, rank
[5], array_arg
;
1943 /* Find which, if any, arguments are arrays. Assume that the old
1944 expression carries the type information and that the first arg
1945 that is an array expression carries all the shape information.*/
1947 a
= e
->value
.function
.actual
;
1948 for (; a
; a
= a
->next
)
1951 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1954 expr
= gfc_copy_expr (a
->expr
);
1961 old
= gfc_copy_expr (e
);
1963 gfc_constructor_free (expr
->value
.constructor
);
1964 expr
->value
.constructor
= NULL
;
1966 expr
->where
= old
->where
;
1967 expr
->expr_type
= EXPR_ARRAY
;
1969 /* Copy the array argument constructors into an array, with nulls
1972 a
= old
->value
.function
.actual
;
1973 for (; a
; a
= a
->next
)
1975 /* Check that this is OK for an initialization expression. */
1976 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1980 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1982 rank
[n
] = a
->expr
->rank
;
1983 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1984 args
[n
] = gfc_constructor_first (ctor
);
1986 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1989 rank
[n
] = a
->expr
->rank
;
1992 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
1993 args
[n
] = gfc_constructor_first (ctor
);
2002 /* Using the array argument as the master, step through the array
2003 calling the function for each element and advancing the array
2004 constructors together. */
2005 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2007 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2008 gfc_copy_expr (old
), NULL
);
2010 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2012 b
= old
->value
.function
.actual
;
2013 for (i
= 0; i
< n
; i
++)
2016 new_ctor
->expr
->value
.function
.actual
2017 = a
= gfc_get_actual_arglist ();
2020 a
->next
= gfc_get_actual_arglist ();
2025 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2027 a
->expr
= gfc_copy_expr (b
->expr
);
2032 /* Simplify the function calls. If the simplification fails, the
2033 error will be flagged up down-stream or the library will deal
2035 gfc_simplify_expr (new_ctor
->expr
, 0);
2037 for (i
= 0; i
< n
; i
++)
2039 args
[i
] = gfc_constructor_next (args
[i
]);
2041 for (i
= 1; i
< n
; i
++)
2042 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2043 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2049 gfc_free_expr (old
);
2053 gfc_error_now ("elemental function arguments at %C are not compliant");
2056 gfc_free_expr (expr
);
2057 gfc_free_expr (old
);
2063 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2065 gfc_expr
*op1
= e
->value
.op
.op1
;
2066 gfc_expr
*op2
= e
->value
.op
.op2
;
2068 if ((*check_function
) (op1
) == FAILURE
)
2071 switch (e
->value
.op
.op
)
2073 case INTRINSIC_UPLUS
:
2074 case INTRINSIC_UMINUS
:
2075 if (!numeric_type (et0 (op1
)))
2080 case INTRINSIC_EQ_OS
:
2082 case INTRINSIC_NE_OS
:
2084 case INTRINSIC_GT_OS
:
2086 case INTRINSIC_GE_OS
:
2088 case INTRINSIC_LT_OS
:
2090 case INTRINSIC_LE_OS
:
2091 if ((*check_function
) (op2
) == FAILURE
)
2094 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2095 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2097 gfc_error ("Numeric or CHARACTER operands are required in "
2098 "expression at %L", &e
->where
);
2103 case INTRINSIC_PLUS
:
2104 case INTRINSIC_MINUS
:
2105 case INTRINSIC_TIMES
:
2106 case INTRINSIC_DIVIDE
:
2107 case INTRINSIC_POWER
:
2108 if ((*check_function
) (op2
) == FAILURE
)
2111 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2116 case INTRINSIC_CONCAT
:
2117 if ((*check_function
) (op2
) == FAILURE
)
2120 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2122 gfc_error ("Concatenation operator in expression at %L "
2123 "must have two CHARACTER operands", &op1
->where
);
2127 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2129 gfc_error ("Concat operator at %L must concatenate strings of the "
2130 "same kind", &e
->where
);
2137 if (et0 (op1
) != BT_LOGICAL
)
2139 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2140 "operand", &op1
->where
);
2149 case INTRINSIC_NEQV
:
2150 if ((*check_function
) (op2
) == FAILURE
)
2153 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2155 gfc_error ("LOGICAL operands are required in expression at %L",
2162 case INTRINSIC_PARENTHESES
:
2166 gfc_error ("Only intrinsic operators can be used in expression at %L",
2174 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2179 /* F2003, 7.1.7 (3): In init expression, allocatable components
2180 must not be data-initialized. */
2182 check_alloc_comp_init (gfc_expr
*e
)
2184 gfc_component
*comp
;
2185 gfc_constructor
*ctor
;
2187 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2188 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2190 for (comp
= e
->ts
.u
.derived
->components
,
2191 ctor
= gfc_constructor_first (e
->value
.constructor
);
2192 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2194 if (comp
->attr
.allocatable
2195 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2197 gfc_error("Invalid initialization expression for ALLOCATABLE "
2198 "component '%s' in structure constructor at %L",
2199 comp
->name
, &ctor
->expr
->where
);
2208 check_init_expr_arguments (gfc_expr
*e
)
2210 gfc_actual_arglist
*ap
;
2212 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2213 if (check_init_expr (ap
->expr
) == FAILURE
)
2219 static gfc_try
check_restricted (gfc_expr
*);
2221 /* F95, 7.1.6.1, Initialization expressions, (7)
2222 F2003, 7.1.7 Initialization expression, (8) */
2225 check_inquiry (gfc_expr
*e
, int not_restricted
)
2228 const char *const *functions
;
2230 static const char *const inquiry_func_f95
[] = {
2231 "lbound", "shape", "size", "ubound",
2232 "bit_size", "len", "kind",
2233 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2234 "precision", "radix", "range", "tiny",
2238 static const char *const inquiry_func_f2003
[] = {
2239 "lbound", "shape", "size", "ubound",
2240 "bit_size", "len", "kind",
2241 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2242 "precision", "radix", "range", "tiny",
2247 gfc_actual_arglist
*ap
;
2249 if (!e
->value
.function
.isym
2250 || !e
->value
.function
.isym
->inquiry
)
2253 /* An undeclared parameter will get us here (PR25018). */
2254 if (e
->symtree
== NULL
)
2257 name
= e
->symtree
->n
.sym
->name
;
2259 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2260 ? inquiry_func_f2003
: inquiry_func_f95
;
2262 for (i
= 0; functions
[i
]; i
++)
2263 if (strcmp (functions
[i
], name
) == 0)
2266 if (functions
[i
] == NULL
)
2269 /* At this point we have an inquiry function with a variable argument. The
2270 type of the variable might be undefined, but we need it now, because the
2271 arguments of these functions are not allowed to be undefined. */
2273 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2278 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2280 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2281 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2285 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2288 /* Assumed character length will not reduce to a constant expression
2289 with LEN, as required by the standard. */
2290 if (i
== 5 && not_restricted
2291 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2292 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2293 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2295 gfc_error ("Assumed or deferred character length variable '%s' "
2296 " in constant expression at %L",
2297 ap
->expr
->symtree
->n
.sym
->name
,
2301 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2304 if (not_restricted
== 0
2305 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2306 && check_restricted (ap
->expr
) == FAILURE
)
2309 if (not_restricted
== 0
2310 && ap
->expr
->expr_type
== EXPR_VARIABLE
2311 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2312 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2320 /* F95, 7.1.6.1, Initialization expressions, (5)
2321 F2003, 7.1.7 Initialization expression, (5) */
2324 check_transformational (gfc_expr
*e
)
2326 static const char * const trans_func_f95
[] = {
2327 "repeat", "reshape", "selected_int_kind",
2328 "selected_real_kind", "transfer", "trim", NULL
2331 static const char * const trans_func_f2003
[] = {
2332 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2333 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2334 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2335 "trim", "unpack", NULL
2340 const char *const *functions
;
2342 if (!e
->value
.function
.isym
2343 || !e
->value
.function
.isym
->transformational
)
2346 name
= e
->symtree
->n
.sym
->name
;
2348 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2349 ? trans_func_f2003
: trans_func_f95
;
2351 /* NULL() is dealt with below. */
2352 if (strcmp ("null", name
) == 0)
2355 for (i
= 0; functions
[i
]; i
++)
2356 if (strcmp (functions
[i
], name
) == 0)
2359 if (functions
[i
] == NULL
)
2361 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2362 "in an initialization expression", name
, &e
->where
);
2366 return check_init_expr_arguments (e
);
2370 /* F95, 7.1.6.1, Initialization expressions, (6)
2371 F2003, 7.1.7 Initialization expression, (6) */
2374 check_null (gfc_expr
*e
)
2376 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2379 return check_init_expr_arguments (e
);
2384 check_elemental (gfc_expr
*e
)
2386 if (!e
->value
.function
.isym
2387 || !e
->value
.function
.isym
->elemental
)
2390 if (e
->ts
.type
!= BT_INTEGER
2391 && e
->ts
.type
!= BT_CHARACTER
2392 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2393 "nonstandard initialization expression at %L",
2394 &e
->where
) == FAILURE
)
2397 return check_init_expr_arguments (e
);
2402 check_conversion (gfc_expr
*e
)
2404 if (!e
->value
.function
.isym
2405 || !e
->value
.function
.isym
->conversion
)
2408 return check_init_expr_arguments (e
);
2412 /* Verify that an expression is an initialization expression. A side
2413 effect is that the expression tree is reduced to a single constant
2414 node if all goes well. This would normally happen when the
2415 expression is constructed but function references are assumed to be
2416 intrinsics in the context of initialization expressions. If
2417 FAILURE is returned an error message has been generated. */
2420 check_init_expr (gfc_expr
*e
)
2428 switch (e
->expr_type
)
2431 t
= check_intrinsic_op (e
, check_init_expr
);
2433 t
= gfc_simplify_expr (e
, 0);
2441 gfc_intrinsic_sym
* isym
;
2444 sym
= e
->symtree
->n
.sym
;
2445 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2446 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2448 gfc_error ("Function '%s' in initialization expression at %L "
2449 "must be an intrinsic function",
2450 e
->symtree
->n
.sym
->name
, &e
->where
);
2454 if ((m
= check_conversion (e
)) == MATCH_NO
2455 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2456 && (m
= check_null (e
)) == MATCH_NO
2457 && (m
= check_transformational (e
)) == MATCH_NO
2458 && (m
= check_elemental (e
)) == MATCH_NO
)
2460 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2461 "in an initialization expression",
2462 e
->symtree
->n
.sym
->name
, &e
->where
);
2466 /* Try to scalarize an elemental intrinsic function that has an
2468 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2469 if (isym
&& isym
->elemental
2470 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2475 t
= gfc_simplify_expr (e
, 0);
2482 if (gfc_check_iter_variable (e
) == SUCCESS
)
2485 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2487 /* A PARAMETER shall not be used to define itself, i.e.
2488 REAL, PARAMETER :: x = transfer(0, x)
2490 if (!e
->symtree
->n
.sym
->value
)
2492 gfc_error("PARAMETER '%s' is used at %L before its definition "
2493 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2497 t
= simplify_parameter_variable (e
, 0);
2502 if (gfc_in_match_data ())
2507 if (e
->symtree
->n
.sym
->as
)
2509 switch (e
->symtree
->n
.sym
->as
->type
)
2511 case AS_ASSUMED_SIZE
:
2512 gfc_error ("Assumed size array '%s' at %L is not permitted "
2513 "in an initialization expression",
2514 e
->symtree
->n
.sym
->name
, &e
->where
);
2517 case AS_ASSUMED_SHAPE
:
2518 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2519 "in an initialization expression",
2520 e
->symtree
->n
.sym
->name
, &e
->where
);
2524 gfc_error ("Deferred array '%s' at %L is not permitted "
2525 "in an initialization expression",
2526 e
->symtree
->n
.sym
->name
, &e
->where
);
2530 gfc_error ("Array '%s' at %L is a variable, which does "
2531 "not reduce to a constant expression",
2532 e
->symtree
->n
.sym
->name
, &e
->where
);
2540 gfc_error ("Parameter '%s' at %L has not been declared or is "
2541 "a variable, which does not reduce to a constant "
2542 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2551 case EXPR_SUBSTRING
:
2552 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2556 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2558 t
= gfc_simplify_expr (e
, 0);
2562 case EXPR_STRUCTURE
:
2563 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2567 t
= check_alloc_comp_init (e
);
2571 t
= gfc_check_constructor (e
, check_init_expr
);
2578 t
= gfc_check_constructor (e
, check_init_expr
);
2582 t
= gfc_expand_constructor (e
, true);
2586 t
= gfc_check_constructor_type (e
);
2590 gfc_internal_error ("check_init_expr(): Unknown expression type");
2596 /* Reduces a general expression to an initialization expression (a constant).
2597 This used to be part of gfc_match_init_expr.
2598 Note that this function doesn't free the given expression on FAILURE. */
2601 gfc_reduce_init_expr (gfc_expr
*expr
)
2605 gfc_init_expr_flag
= true;
2606 t
= gfc_resolve_expr (expr
);
2608 t
= check_init_expr (expr
);
2609 gfc_init_expr_flag
= false;
2614 if (expr
->expr_type
== EXPR_ARRAY
)
2616 if (gfc_check_constructor_type (expr
) == FAILURE
)
2618 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2626 /* Match an initialization expression. We work by first matching an
2627 expression, then reducing it to a constant. */
2630 gfc_match_init_expr (gfc_expr
**result
)
2638 gfc_init_expr_flag
= true;
2640 m
= gfc_match_expr (&expr
);
2643 gfc_init_expr_flag
= false;
2647 t
= gfc_reduce_init_expr (expr
);
2650 gfc_free_expr (expr
);
2651 gfc_init_expr_flag
= false;
2656 gfc_init_expr_flag
= false;
2662 /* Given an actual argument list, test to see that each argument is a
2663 restricted expression and optionally if the expression type is
2664 integer or character. */
2667 restricted_args (gfc_actual_arglist
*a
)
2669 for (; a
; a
= a
->next
)
2671 if (check_restricted (a
->expr
) == FAILURE
)
2679 /************* Restricted/specification expressions *************/
2682 /* Make sure a non-intrinsic function is a specification function. */
2685 external_spec_function (gfc_expr
*e
)
2689 f
= e
->value
.function
.esym
;
2691 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2693 gfc_error ("Specification function '%s' at %L cannot be a statement "
2694 "function", f
->name
, &e
->where
);
2698 if (f
->attr
.proc
== PROC_INTERNAL
)
2700 gfc_error ("Specification function '%s' at %L cannot be an internal "
2701 "function", f
->name
, &e
->where
);
2705 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2707 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2712 if (f
->attr
.recursive
)
2714 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2715 f
->name
, &e
->where
);
2719 return restricted_args (e
->value
.function
.actual
);
2723 /* Check to see that a function reference to an intrinsic is a
2724 restricted expression. */
2727 restricted_intrinsic (gfc_expr
*e
)
2729 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2730 if (check_inquiry (e
, 0) == MATCH_YES
)
2733 return restricted_args (e
->value
.function
.actual
);
2737 /* Check the expressions of an actual arglist. Used by check_restricted. */
2740 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2742 for (; arg
; arg
= arg
->next
)
2743 if (checker (arg
->expr
) == FAILURE
)
2750 /* Check the subscription expressions of a reference chain with a checking
2751 function; used by check_restricted. */
2754 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2764 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2766 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2768 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2770 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2776 /* Nothing needed, just proceed to next reference. */
2780 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2782 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2791 return check_references (ref
->next
, checker
);
2795 /* Verify that an expression is a restricted expression. Like its
2796 cousin check_init_expr(), an error message is generated if we
2800 check_restricted (gfc_expr
*e
)
2808 switch (e
->expr_type
)
2811 t
= check_intrinsic_op (e
, check_restricted
);
2813 t
= gfc_simplify_expr (e
, 0);
2818 if (e
->value
.function
.esym
)
2820 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2822 t
= external_spec_function (e
);
2826 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2829 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2832 t
= restricted_intrinsic (e
);
2837 sym
= e
->symtree
->n
.sym
;
2840 /* If a dummy argument appears in a context that is valid for a
2841 restricted expression in an elemental procedure, it will have
2842 already been simplified away once we get here. Therefore we
2843 don't need to jump through hoops to distinguish valid from
2845 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2846 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2848 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2849 sym
->name
, &e
->where
);
2853 if (sym
->attr
.optional
)
2855 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2856 sym
->name
, &e
->where
);
2860 if (sym
->attr
.intent
== INTENT_OUT
)
2862 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2863 sym
->name
, &e
->where
);
2867 /* Check reference chain if any. */
2868 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2871 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2872 processed in resolve.c(resolve_formal_arglist). This is done so
2873 that host associated dummy array indices are accepted (PR23446).
2874 This mechanism also does the same for the specification expressions
2875 of array-valued functions. */
2877 || sym
->attr
.in_common
2878 || sym
->attr
.use_assoc
2880 || sym
->attr
.implied_index
2881 || sym
->attr
.flavor
== FL_PARAMETER
2882 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2883 || (sym
->ns
&& gfc_current_ns
->parent
2884 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2885 || (sym
->ns
->proc_name
!= NULL
2886 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2887 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2893 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2894 sym
->name
, &e
->where
);
2895 /* Prevent a repetition of the error. */
2904 case EXPR_SUBSTRING
:
2905 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2909 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2911 t
= gfc_simplify_expr (e
, 0);
2915 case EXPR_STRUCTURE
:
2916 t
= gfc_check_constructor (e
, check_restricted
);
2920 t
= gfc_check_constructor (e
, check_restricted
);
2924 gfc_internal_error ("check_restricted(): Unknown expression type");
2931 /* Check to see that an expression is a specification expression. If
2932 we return FAILURE, an error has been generated. */
2935 gfc_specification_expr (gfc_expr
*e
)
2937 gfc_component
*comp
;
2942 if (e
->ts
.type
!= BT_INTEGER
)
2944 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2945 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2949 if (e
->expr_type
== EXPR_FUNCTION
2950 && !e
->value
.function
.isym
2951 && !e
->value
.function
.esym
2952 && !gfc_pure (e
->symtree
->n
.sym
)
2953 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2954 || !comp
->attr
.pure
))
2956 gfc_error ("Function '%s' at %L must be PURE",
2957 e
->symtree
->n
.sym
->name
, &e
->where
);
2958 /* Prevent repeat error messages. */
2959 e
->symtree
->n
.sym
->attr
.pure
= 1;
2965 gfc_error ("Expression at %L must be scalar", &e
->where
);
2969 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2972 return check_restricted (e
);
2976 /************** Expression conformance checks. *************/
2978 /* Given two expressions, make sure that the arrays are conformable. */
2981 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
2983 int op1_flag
, op2_flag
, d
;
2984 mpz_t op1_size
, op2_size
;
2990 if (op1
->rank
== 0 || op2
->rank
== 0)
2993 va_start (argp
, optype_msgid
);
2994 vsnprintf (buffer
, 240, optype_msgid
, argp
);
2997 if (op1
->rank
!= op2
->rank
)
2999 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3000 op1
->rank
, op2
->rank
, &op1
->where
);
3006 for (d
= 0; d
< op1
->rank
; d
++)
3008 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3009 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3011 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3013 gfc_error ("Different shape for %s at %L on dimension %d "
3014 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3015 (int) mpz_get_si (op1_size
),
3016 (int) mpz_get_si (op2_size
));
3022 mpz_clear (op1_size
);
3024 mpz_clear (op2_size
);
3034 /* Given an assignable expression and an arbitrary expression, make
3035 sure that the assignment can take place. */
3038 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3044 sym
= lvalue
->symtree
->n
.sym
;
3046 /* See if this is the component or subcomponent of a pointer. */
3047 has_pointer
= sym
->attr
.pointer
;
3048 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3049 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3055 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3056 variable local to a function subprogram. Its existence begins when
3057 execution of the function is initiated and ends when execution of the
3058 function is terminated...
3059 Therefore, the left hand side is no longer a variable, when it is: */
3060 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3061 && !sym
->attr
.external
)
3066 /* (i) Use associated; */
3067 if (sym
->attr
.use_assoc
)
3070 /* (ii) The assignment is in the main program; or */
3071 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3074 /* (iii) A module or internal procedure... */
3075 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3076 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3077 && gfc_current_ns
->parent
3078 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3079 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3080 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3082 /* ... that is not a function... */
3083 if (!gfc_current_ns
->proc_name
->attr
.function
)
3086 /* ... or is not an entry and has a different name. */
3087 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3091 /* (iv) Host associated and not the function symbol or the
3092 parent result. This picks up sibling references, which
3093 cannot be entries. */
3094 if (!sym
->attr
.entry
3095 && sym
->ns
== gfc_current_ns
->parent
3096 && sym
!= gfc_current_ns
->proc_name
3097 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3102 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3107 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3109 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3110 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3114 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3116 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3121 if (rvalue
->expr_type
== EXPR_NULL
)
3123 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3124 && lvalue
->symtree
->n
.sym
->attr
.data
)
3128 gfc_error ("NULL appears on right-hand side in assignment at %L",
3134 /* This is possibly a typo: x = f() instead of x => f(). */
3135 if (gfc_option
.warn_surprising
3136 && rvalue
->expr_type
== EXPR_FUNCTION
3137 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3138 gfc_warning ("POINTER valued function appears on right-hand side of "
3139 "assignment at %L", &rvalue
->where
);
3141 /* Check size of array assignments. */
3142 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3143 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3146 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3147 && lvalue
->symtree
->n
.sym
->attr
.data
3148 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3149 "initialize non-integer variable '%s'",
3150 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3153 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3154 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3155 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3156 &rvalue
->where
) == FAILURE
)
3159 /* Handle the case of a BOZ literal on the RHS. */
3160 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3163 if (gfc_option
.warn_surprising
)
3164 gfc_warning ("BOZ literal at %L is bitwise transferred "
3165 "non-integer symbol '%s'", &rvalue
->where
,
3166 lvalue
->symtree
->n
.sym
->name
);
3167 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3169 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3171 if (rc
== ARITH_UNDERFLOW
)
3172 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3173 ". This check can be disabled with the option "
3174 "-fno-range-check", &rvalue
->where
);
3175 else if (rc
== ARITH_OVERFLOW
)
3176 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3177 ". This check can be disabled with the option "
3178 "-fno-range-check", &rvalue
->where
);
3179 else if (rc
== ARITH_NAN
)
3180 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3181 ". This check can be disabled with the option "
3182 "-fno-range-check", &rvalue
->where
);
3187 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3190 /* Only DATA Statements come here. */
3193 /* Numeric can be converted to any other numeric. And Hollerith can be
3194 converted to any other type. */
3195 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3196 || rvalue
->ts
.type
== BT_HOLLERITH
)
3199 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3202 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3203 "conversion of %s to %s", &lvalue
->where
,
3204 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3209 /* Assignment is the only case where character variables of different
3210 kind values can be converted into one another. */
3211 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3213 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3214 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3219 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3223 /* Check that a pointer assignment is OK. We first check lvalue, and
3224 we only check rvalue if it's not an assignment to NULL() or a
3225 NULLIFY statement. */
3228 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3230 symbol_attribute attr
;
3232 bool is_pure
, is_implicit_pure
, rank_remap
;
3235 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3236 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3238 gfc_error ("Pointer assignment target is not a POINTER at %L",
3243 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3244 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3245 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3247 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3248 "l-value since it is a procedure",
3249 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3253 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3256 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3258 if (ref
->type
== REF_COMPONENT
)
3259 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3261 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3265 if (ref
->u
.ar
.type
== AR_FULL
)
3268 if (ref
->u
.ar
.type
!= AR_SECTION
)
3270 gfc_error ("Expected bounds specification for '%s' at %L",
3271 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3275 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3276 "specification for '%s' in pointer assignment "
3277 "at %L", lvalue
->symtree
->n
.sym
->name
,
3278 &lvalue
->where
) == FAILURE
)
3281 /* When bounds are given, all lbounds are necessary and either all
3282 or none of the upper bounds; no strides are allowed. If the
3283 upper bounds are present, we may do rank remapping. */
3284 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3286 if (!ref
->u
.ar
.start
[dim
])
3288 gfc_error ("Lower bound has to be present at %L",
3292 if (ref
->u
.ar
.stride
[dim
])
3294 gfc_error ("Stride must not be present at %L",
3300 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3303 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3304 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3306 gfc_error ("Either all or none of the upper bounds"
3307 " must be specified at %L", &lvalue
->where
);
3315 is_pure
= gfc_pure (NULL
);
3316 is_implicit_pure
= gfc_implicit_pure (NULL
);
3318 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3319 kind, etc for lvalue and rvalue must match, and rvalue must be a
3320 pure variable if we're in a pure function. */
3321 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3324 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3325 if (lvalue
->expr_type
== EXPR_VARIABLE
3326 && gfc_is_coindexed (lvalue
))
3329 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3330 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3332 gfc_error ("Pointer object at %L shall not have a coindex",
3338 /* Checks on rvalue for procedure pointer assignments. */
3343 gfc_component
*comp
;
3346 attr
= gfc_expr_attr (rvalue
);
3347 if (!((rvalue
->expr_type
== EXPR_NULL
)
3348 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3349 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3350 || (rvalue
->expr_type
== EXPR_VARIABLE
3351 && attr
.flavor
== FL_PROCEDURE
)))
3353 gfc_error ("Invalid procedure pointer assignment at %L",
3359 gfc_error ("Abstract interface '%s' is invalid "
3360 "in procedure pointer assignment at %L",
3361 rvalue
->symtree
->name
, &rvalue
->where
);
3364 /* Check for C727. */
3365 if (attr
.flavor
== FL_PROCEDURE
)
3367 if (attr
.proc
== PROC_ST_FUNCTION
)
3369 gfc_error ("Statement function '%s' is invalid "
3370 "in procedure pointer assignment at %L",
3371 rvalue
->symtree
->name
, &rvalue
->where
);
3374 if (attr
.proc
== PROC_INTERNAL
&&
3375 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3376 "invalid in procedure pointer assignment at %L",
3377 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3381 /* Ensure that the calling convention is the same. As other attributes
3382 such as DLLEXPORT may differ, one explicitly only tests for the
3383 calling conventions. */
3384 if (rvalue
->expr_type
== EXPR_VARIABLE
3385 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3386 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3388 symbol_attribute calls
;
3391 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3392 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3393 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3395 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3396 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3398 gfc_error ("Mismatch in the procedure pointer assignment "
3399 "at %L: mismatch in the calling convention",
3405 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3406 s1
= comp
->ts
.interface
;
3408 s1
= lvalue
->symtree
->n
.sym
;
3410 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3412 s2
= comp
->ts
.interface
;
3415 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3417 s2
= rvalue
->symtree
->n
.sym
->result
;
3418 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3422 s2
= rvalue
->symtree
->n
.sym
;
3423 name
= rvalue
->symtree
->n
.sym
->name
;
3426 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3429 gfc_error ("Interface mismatch in procedure pointer assignment "
3430 "at %L: %s", &rvalue
->where
, err
);
3437 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3439 gfc_error ("Different types in pointer assignment at %L; attempted "
3440 "assignment of %s to %s", &lvalue
->where
,
3441 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3445 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3447 gfc_error ("Different kind type parameters in pointer "
3448 "assignment at %L", &lvalue
->where
);
3452 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3454 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3458 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3459 /* Make sure the vtab is present. */
3460 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3462 /* Check rank remapping. */
3467 /* If this can be determined, check that the target must be at least as
3468 large as the pointer assigned to it is. */
3469 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3470 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3471 && mpz_cmp (rsize
, lsize
) < 0)
3473 gfc_error ("Rank remapping target is smaller than size of the"
3474 " pointer (%ld < %ld) at %L",
3475 mpz_get_si (rsize
), mpz_get_si (lsize
),
3480 /* The target must be either rank one or it must be simply contiguous
3481 and F2008 must be allowed. */
3482 if (rvalue
->rank
!= 1)
3484 if (!gfc_is_simply_contiguous (rvalue
, true))
3486 gfc_error ("Rank remapping target must be rank 1 or"
3487 " simply contiguous at %L", &rvalue
->where
);
3490 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Rank remapping"
3491 " target is not rank 1 at %L", &rvalue
->where
)
3497 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3498 if (rvalue
->expr_type
== EXPR_NULL
)
3501 if (lvalue
->ts
.type
== BT_CHARACTER
)
3503 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3508 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3509 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3511 attr
= gfc_expr_attr (rvalue
);
3513 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3515 gfc_error ("Target expression in pointer assignment "
3516 "at %L must deliver a pointer result",
3521 if (!attr
.target
&& !attr
.pointer
)
3523 gfc_error ("Pointer assignment target is neither TARGET "
3524 "nor POINTER at %L", &rvalue
->where
);
3528 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3530 gfc_error ("Bad target in pointer assignment in PURE "
3531 "procedure at %L", &rvalue
->where
);
3534 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3535 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3538 if (gfc_has_vector_index (rvalue
))
3540 gfc_error ("Pointer assignment with vector subscript "
3541 "on rhs at %L", &rvalue
->where
);
3545 if (attr
.is_protected
&& attr
.use_assoc
3546 && !(attr
.pointer
|| attr
.proc_pointer
))
3548 gfc_error ("Pointer assignment target has PROTECTED "
3549 "attribute at %L", &rvalue
->where
);
3553 /* F2008, C725. For PURE also C1283. */
3554 if (rvalue
->expr_type
== EXPR_VARIABLE
3555 && gfc_is_coindexed (rvalue
))
3558 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3559 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3561 gfc_error ("Data target at %L shall not have a coindex",
3571 /* Relative of gfc_check_assign() except that the lvalue is a single
3572 symbol. Used for initialization assignments. */
3575 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3580 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3582 lvalue
.expr_type
= EXPR_VARIABLE
;
3583 lvalue
.ts
= sym
->ts
;
3585 lvalue
.rank
= sym
->as
->rank
;
3586 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
3587 lvalue
.symtree
->n
.sym
= sym
;
3588 lvalue
.where
= sym
->declared_at
;
3590 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3591 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
3592 && rvalue
->expr_type
== EXPR_NULL
))
3593 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3595 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3597 gfc_free (lvalue
.symtree
);
3602 if (sym
->attr
.pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3604 /* F08:C461. Additional checks for pointer initialization. */
3605 symbol_attribute attr
;
3606 attr
= gfc_expr_attr (rvalue
);
3607 if (attr
.allocatable
)
3609 gfc_error ("Pointer initialization target at %C "
3610 "must not be ALLOCATABLE ");
3613 if (!attr
.target
|| attr
.pointer
)
3615 gfc_error ("Pointer initialization target at %C "
3616 "must have the TARGET attribute");
3621 gfc_error ("Pointer initialization target at %C "
3622 "must have the SAVE attribute");
3627 if (sym
->attr
.proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3629 /* F08:C1220. Additional checks for procedure pointer initialization. */
3630 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3631 if (attr
.proc_pointer
)
3633 gfc_error ("Procedure pointer initialization target at %L "
3634 "may not be a procedure pointer", &rvalue
->where
);
3643 /* Check for default initializer; sym->value is not enough
3644 as it is also set for EXPR_NULL of allocatables. */
3647 gfc_has_default_initializer (gfc_symbol
*der
)
3651 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3652 for (c
= der
->components
; c
; c
= c
->next
)
3653 if (c
->ts
.type
== BT_DERIVED
)
3655 if (!c
->attr
.pointer
3656 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3668 /* Get an expression for a default initializer. */
3671 gfc_default_initializer (gfc_typespec
*ts
)
3674 gfc_component
*comp
;
3676 /* See if we have a default initializer in this, but not in nested
3677 types (otherwise we could use gfc_has_default_initializer()). */
3678 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3679 if (comp
->initializer
|| comp
->attr
.allocatable
3680 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3686 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3687 &ts
->u
.derived
->declared_at
);
3690 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3692 gfc_constructor
*ctor
= gfc_constructor_get();
3694 if (comp
->initializer
)
3695 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3697 if (comp
->attr
.allocatable
3698 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3700 ctor
->expr
= gfc_get_expr ();
3701 ctor
->expr
->expr_type
= EXPR_NULL
;
3702 ctor
->expr
->ts
= comp
->ts
;
3705 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3712 /* Given a symbol, create an expression node with that symbol as a
3713 variable. If the symbol is array valued, setup a reference of the
3717 gfc_get_variable_expr (gfc_symtree
*var
)
3721 e
= gfc_get_expr ();
3722 e
->expr_type
= EXPR_VARIABLE
;
3724 e
->ts
= var
->n
.sym
->ts
;
3726 if (var
->n
.sym
->as
!= NULL
)
3728 e
->rank
= var
->n
.sym
->as
->rank
;
3729 e
->ref
= gfc_get_ref ();
3730 e
->ref
->type
= REF_ARRAY
;
3731 e
->ref
->u
.ar
.type
= AR_FULL
;
3739 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3742 lval
= gfc_get_expr ();
3743 lval
->expr_type
= EXPR_VARIABLE
;
3744 lval
->where
= sym
->declared_at
;
3746 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3748 /* It will always be a full array. */
3749 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
3752 lval
->ref
= gfc_get_ref ();
3753 lval
->ref
->type
= REF_ARRAY
;
3754 lval
->ref
->u
.ar
.type
= AR_FULL
;
3755 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
3756 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
3757 lval
->ref
->u
.ar
.as
= sym
->as
;
3764 /* Returns the array_spec of a full array expression. A NULL is
3765 returned otherwise. */
3767 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3772 if (expr
->rank
== 0)
3775 /* Follow any component references. */
3776 if (expr
->expr_type
== EXPR_VARIABLE
3777 || expr
->expr_type
== EXPR_CONSTANT
)
3779 as
= expr
->symtree
->n
.sym
->as
;
3780 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3785 as
= ref
->u
.c
.component
->as
;
3793 switch (ref
->u
.ar
.type
)
3816 /* General expression traversal function. */
3819 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3820 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3825 gfc_actual_arglist
*args
;
3832 if ((*func
) (expr
, sym
, &f
))
3835 if (expr
->ts
.type
== BT_CHARACTER
3837 && expr
->ts
.u
.cl
->length
3838 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3839 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3842 switch (expr
->expr_type
)
3847 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3849 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3857 case EXPR_SUBSTRING
:
3860 case EXPR_STRUCTURE
:
3862 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3863 c
; c
= gfc_constructor_next (c
))
3865 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3869 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3871 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3873 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3875 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3882 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3884 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3900 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3902 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3904 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3906 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3912 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3914 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3919 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3920 && ref
->u
.c
.component
->ts
.u
.cl
3921 && ref
->u
.c
.component
->ts
.u
.cl
->length
3922 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
3924 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
3928 if (ref
->u
.c
.component
->as
)
3929 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
3930 + ref
->u
.c
.component
->as
->corank
; i
++)
3932 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3935 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3949 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3952 expr_set_symbols_referenced (gfc_expr
*expr
,
3953 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3954 int *f ATTRIBUTE_UNUSED
)
3956 if (expr
->expr_type
!= EXPR_VARIABLE
)
3958 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3963 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3965 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
3969 /* Determine if an expression is a procedure pointer component. If yes, the
3970 argument 'comp' will point to the component (provided that 'comp' was
3974 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
3979 if (!expr
|| !expr
->ref
)
3986 if (ref
->type
== REF_COMPONENT
)
3988 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
3990 *comp
= ref
->u
.c
.component
;
3997 /* Walk an expression tree and check each variable encountered for being typed.
3998 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3999 mode as is a basic arithmetic expression using those; this is for things in
4002 INTEGER :: arr(n), n
4003 INTEGER :: arr(n + 1), n
4005 The namespace is needed for IMPLICIT typing. */
4007 static gfc_namespace
* check_typed_ns
;
4010 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4011 int* f ATTRIBUTE_UNUSED
)
4015 if (e
->expr_type
!= EXPR_VARIABLE
)
4018 gcc_assert (e
->symtree
);
4019 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4022 return (t
== FAILURE
);
4026 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4030 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4034 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4035 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4037 if (e
->expr_type
== EXPR_OP
)
4039 gfc_try t
= SUCCESS
;
4041 gcc_assert (e
->value
.op
.op1
);
4042 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4044 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4045 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4051 /* Otherwise, walk the expression and do it strictly. */
4052 check_typed_ns
= ns
;
4053 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4055 return error_found
? FAILURE
: SUCCESS
;
4058 /* Walk an expression tree and replace all symbols with a corresponding symbol
4059 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4060 statements. The boolean return value is required by gfc_traverse_expr. */
4063 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4065 if ((expr
->expr_type
== EXPR_VARIABLE
4066 || (expr
->expr_type
== EXPR_FUNCTION
4067 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4068 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
4071 gfc_namespace
*ns
= sym
->formal_ns
;
4072 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4073 the symtree rather than create a new one (and probably fail later). */
4074 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4075 expr
->symtree
->n
.sym
->name
);
4077 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4078 expr
->symtree
= stree
;
4084 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
4086 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
4089 /* The following is analogous to 'replace_symbol', and needed for copying
4090 interfaces for procedure pointer components. The argument 'sym' must formally
4091 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4092 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4093 component in whose formal_ns the arguments have to be). */
4096 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4098 gfc_component
*comp
;
4099 comp
= (gfc_component
*)sym
;
4100 if ((expr
->expr_type
== EXPR_VARIABLE
4101 || (expr
->expr_type
== EXPR_FUNCTION
4102 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4103 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4106 gfc_namespace
*ns
= comp
->formal_ns
;
4107 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4108 the symtree rather than create a new one (and probably fail later). */
4109 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4110 expr
->symtree
->n
.sym
->name
);
4112 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4113 expr
->symtree
= stree
;
4119 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4121 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4126 gfc_is_coindexed (gfc_expr
*e
)
4130 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4131 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4134 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4135 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4144 gfc_get_corank (gfc_expr
*e
)
4148 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4149 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4151 if (ref
->type
== REF_ARRAY
)
4152 corank
= ref
->u
.ar
.as
->corank
;
4153 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4159 /* Check whether the expression has an ultimate allocatable component.
4160 Being itself allocatable does not count. */
4162 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4164 gfc_ref
*ref
, *last
= NULL
;
4166 if (e
->expr_type
!= EXPR_VARIABLE
)
4169 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4170 if (ref
->type
== REF_COMPONENT
)
4173 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4174 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4175 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4176 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4180 if (e
->ts
.type
== BT_CLASS
)
4181 return CLASS_DATA (e
)->attr
.alloc_comp
;
4182 else if (e
->ts
.type
== BT_DERIVED
)
4183 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4189 /* Check whether the expression has an pointer component.
4190 Being itself a pointer does not count. */
4192 gfc_has_ultimate_pointer (gfc_expr
*e
)
4194 gfc_ref
*ref
, *last
= NULL
;
4196 if (e
->expr_type
!= EXPR_VARIABLE
)
4199 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4200 if (ref
->type
== REF_COMPONENT
)
4203 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4204 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4205 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4206 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4210 if (e
->ts
.type
== BT_CLASS
)
4211 return CLASS_DATA (e
)->attr
.pointer_comp
;
4212 else if (e
->ts
.type
== BT_DERIVED
)
4213 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4219 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4220 Note: A scalar is not regarded as "simply contiguous" by the standard.
4221 if bool is not strict, some futher checks are done - for instance,
4222 a "(::1)" is accepted. */
4225 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4229 gfc_array_ref
*ar
= NULL
;
4230 gfc_ref
*ref
, *part_ref
= NULL
;
4232 if (expr
->expr_type
== EXPR_FUNCTION
)
4233 return expr
->value
.function
.esym
4234 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4235 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4238 if (expr
->rank
== 0)
4241 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4244 return false; /* Array shall be last part-ref. */
4246 if (ref
->type
== REF_COMPONENT
)
4248 else if (ref
->type
== REF_SUBSTRING
)
4250 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4254 if ((part_ref
&& !part_ref
->u
.c
.component
->attr
.contiguous
4255 && part_ref
->u
.c
.component
->attr
.pointer
)
4256 || (!part_ref
&& !expr
->symtree
->n
.sym
->attr
.contiguous
4257 && (expr
->symtree
->n
.sym
->attr
.pointer
4258 || expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)))
4261 if (!ar
|| ar
->type
== AR_FULL
)
4264 gcc_assert (ar
->type
== AR_SECTION
);
4266 /* Check for simply contiguous array */
4268 for (i
= 0; i
< ar
->dimen
; i
++)
4270 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4273 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4279 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4282 /* If the previous section was not contiguous, that's an error,
4283 unless we have effective only one element and checking is not
4285 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4286 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4287 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4288 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4289 ar
->end
[i
]->value
.integer
) != 0))
4292 /* Following the standard, "(::1)" or - if known at compile time -
4293 "(lbound:ubound)" are not simply contigous; if strict
4294 is false, they are regarded as simply contiguous. */
4295 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4296 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4297 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4301 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4302 || !ar
->as
->lower
[i
]
4303 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4304 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4305 ar
->as
->lower
[i
]->value
.integer
) != 0))
4309 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4310 || !ar
->as
->upper
[i
]
4311 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4312 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4313 ar
->as
->upper
[i
]->value
.integer
) != 0))
4321 /* Build call to an intrinsic procedure. The number of arguments has to be
4322 passed (rather than ending the list with a NULL value) because we may
4323 want to add arguments but with a NULL-expression. */
4326 gfc_build_intrinsic_call (const char* name
, locus where
, unsigned numarg
, ...)
4329 gfc_actual_arglist
* atail
;
4330 gfc_intrinsic_sym
* isym
;
4334 isym
= gfc_find_function (name
);
4337 result
= gfc_get_expr ();
4338 result
->expr_type
= EXPR_FUNCTION
;
4339 result
->ts
= isym
->ts
;
4340 result
->where
= where
;
4341 result
->value
.function
.name
= name
;
4342 result
->value
.function
.isym
= isym
;
4344 va_start (ap
, numarg
);
4346 for (i
= 0; i
< numarg
; ++i
)
4350 atail
->next
= gfc_get_actual_arglist ();
4351 atail
= atail
->next
;
4354 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4356 atail
->expr
= va_arg (ap
, gfc_expr
*);
4364 /* Check if an expression may appear in a variable definition context
4365 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4366 This is called from the various places when resolving
4367 the pieces that make up such a context.
4369 Optionally, a possible error message can be suppressed if context is NULL
4370 and just the return status (SUCCESS / FAILURE) be requested. */
4373 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, const char* context
)
4377 bool check_intentin
;
4379 symbol_attribute attr
;
4382 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
4383 && e
->symtree
->n
.sym
->result
->attr
.pointer
)
4385 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4388 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4389 " context (%s) at %L", context
, &e
->where
);
4393 else if (e
->expr_type
!= EXPR_VARIABLE
)
4396 gfc_error ("Non-variable expression in variable definition context (%s)"
4397 " at %L", context
, &e
->where
);
4401 gcc_assert (e
->symtree
);
4402 sym
= e
->symtree
->n
.sym
;
4404 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4407 gfc_error ("Named constant '%s' in variable definition context (%s)"
4408 " at %L", sym
->name
, context
, &e
->where
);
4411 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4412 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4413 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4416 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4417 " a variable", sym
->name
, context
, &e
->where
);
4421 /* Find out whether the expr is a pointer; this also means following
4422 component references to the last one. */
4423 attr
= gfc_expr_attr (e
);
4424 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4425 if (pointer
&& !is_pointer
)
4428 gfc_error ("Non-POINTER in pointer association context (%s)"
4429 " at %L", context
, &e
->where
);
4433 /* INTENT(IN) dummy argument. Check this, unless the object itself is
4434 the component of sub-component of a pointer. Obviously,
4435 procedure pointers are of no interest here. */
4436 check_intentin
= true;
4437 ptr_component
= sym
->attr
.pointer
;
4438 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4440 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4441 check_intentin
= false;
4442 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4443 ptr_component
= true;
4445 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4447 if (pointer
&& is_pointer
)
4450 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4451 " association context (%s) at %L",
4452 sym
->name
, context
, &e
->where
);
4455 if (!pointer
&& !is_pointer
)
4458 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4459 " definition context (%s) at %L",
4460 sym
->name
, context
, &e
->where
);
4465 /* PROTECTED and use-associated. */
4466 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4468 if (pointer
&& is_pointer
)
4471 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4472 " pointer association context (%s) at %L",
4473 sym
->name
, context
, &e
->where
);
4476 if (!pointer
&& !is_pointer
)
4479 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4480 " variable definition context (%s) at %L",
4481 sym
->name
, context
, &e
->where
);
4486 /* Variable not assignable from a PURE procedure but appears in
4487 variable definition context. */
4488 if (!pointer
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4491 gfc_error ("Variable '%s' can not appear in a variable definition"
4492 " context (%s) at %L in PURE procedure",
4493 sym
->name
, context
, &e
->where
);
4497 if (!pointer
&& gfc_implicit_pure (NULL
) && gfc_impure_variable (sym
))
4498 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4500 /* Check variable definition context for associate-names. */
4501 if (!pointer
&& sym
->assoc
)
4504 gfc_association_list
* assoc
;
4506 gcc_assert (sym
->assoc
->target
);
4508 /* If this is a SELECT TYPE temporary (the association is used internally
4509 for SELECT TYPE), silently go over to the target. */
4510 if (sym
->attr
.select_type_temporary
)
4512 gfc_expr
* t
= sym
->assoc
->target
;
4514 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4515 name
= t
->symtree
->name
;
4517 if (t
->symtree
->n
.sym
->assoc
)
4518 assoc
= t
->symtree
->n
.sym
->assoc
;
4527 gcc_assert (name
&& assoc
);
4529 /* Is association to a valid variable? */
4530 if (!assoc
->variable
)
4534 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4535 gfc_error ("'%s' at %L associated to vector-indexed target can"
4536 " not be used in a variable definition context (%s)",
4537 name
, &e
->where
, context
);
4539 gfc_error ("'%s' at %L associated to expression can"
4540 " not be used in a variable definition context (%s)",
4541 name
, &e
->where
, context
);
4546 /* Target must be allowed to appear in a variable definition context. */
4547 if (gfc_check_vardef_context (assoc
->target
, pointer
, NULL
) == FAILURE
)
4550 gfc_error ("Associate-name '%s' can not appear in a variable"
4551 " definition context (%s) at %L because its target"
4552 " at %L can not, either",
4553 name
, context
, &e
->where
,
4554 &assoc
->target
->where
);