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
);
872 check_specification_function (gfc_expr
*e
)
879 sym
= e
->symtree
->n
.sym
;
881 /* F95, 7.1.6.2; F2003, 7.1.7 */
883 && sym
->attr
.function
885 && !sym
->attr
.intrinsic
886 && !sym
->attr
.recursive
887 && sym
->attr
.proc
!= PROC_INTERNAL
888 && sym
->attr
.proc
!= PROC_ST_FUNCTION
889 && sym
->attr
.proc
!= PROC_UNKNOWN
890 && sym
->formal
== NULL
)
896 /* Function to determine if an expression is constant or not. This
897 function expects that the expression has already been simplified. */
900 gfc_is_constant_expr (gfc_expr
*e
)
903 gfc_actual_arglist
*arg
;
908 switch (e
->expr_type
)
911 return (gfc_is_constant_expr (e
->value
.op
.op1
)
912 && (e
->value
.op
.op2
== NULL
913 || gfc_is_constant_expr (e
->value
.op
.op2
)));
921 /* Specification functions are constant. */
922 if (check_specification_function (e
) == MATCH_YES
)
925 /* Call to intrinsic with at least one argument. */
926 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
928 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
929 if (!gfc_is_constant_expr (arg
->expr
))
942 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
943 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
946 for (c
= gfc_constructor_first (e
->value
.constructor
);
947 c
; c
= gfc_constructor_next (c
))
948 if (!gfc_is_constant_expr (c
->expr
))
954 return gfc_constant_ac (e
);
957 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
963 /* Is true if an array reference is followed by a component or substring
966 is_subref_array (gfc_expr
* e
)
971 if (e
->expr_type
!= EXPR_VARIABLE
)
974 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
978 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
980 if (ref
->type
== REF_ARRAY
981 && ref
->u
.ar
.type
!= AR_ELEMENT
)
985 && ref
->type
!= REF_ARRAY
)
992 /* Try to collapse intrinsic expressions. */
995 simplify_intrinsic_op (gfc_expr
*p
, int type
)
998 gfc_expr
*op1
, *op2
, *result
;
1000 if (p
->value
.op
.op
== INTRINSIC_USER
)
1003 op1
= p
->value
.op
.op1
;
1004 op2
= p
->value
.op
.op2
;
1005 op
= p
->value
.op
.op
;
1007 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1009 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1012 if (!gfc_is_constant_expr (op1
)
1013 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1017 p
->value
.op
.op1
= NULL
;
1018 p
->value
.op
.op2
= NULL
;
1022 case INTRINSIC_PARENTHESES
:
1023 result
= gfc_parentheses (op1
);
1026 case INTRINSIC_UPLUS
:
1027 result
= gfc_uplus (op1
);
1030 case INTRINSIC_UMINUS
:
1031 result
= gfc_uminus (op1
);
1034 case INTRINSIC_PLUS
:
1035 result
= gfc_add (op1
, op2
);
1038 case INTRINSIC_MINUS
:
1039 result
= gfc_subtract (op1
, op2
);
1042 case INTRINSIC_TIMES
:
1043 result
= gfc_multiply (op1
, op2
);
1046 case INTRINSIC_DIVIDE
:
1047 result
= gfc_divide (op1
, op2
);
1050 case INTRINSIC_POWER
:
1051 result
= gfc_power (op1
, op2
);
1054 case INTRINSIC_CONCAT
:
1055 result
= gfc_concat (op1
, op2
);
1059 case INTRINSIC_EQ_OS
:
1060 result
= gfc_eq (op1
, op2
, op
);
1064 case INTRINSIC_NE_OS
:
1065 result
= gfc_ne (op1
, op2
, op
);
1069 case INTRINSIC_GT_OS
:
1070 result
= gfc_gt (op1
, op2
, op
);
1074 case INTRINSIC_GE_OS
:
1075 result
= gfc_ge (op1
, op2
, op
);
1079 case INTRINSIC_LT_OS
:
1080 result
= gfc_lt (op1
, op2
, op
);
1084 case INTRINSIC_LE_OS
:
1085 result
= gfc_le (op1
, op2
, op
);
1089 result
= gfc_not (op1
);
1093 result
= gfc_and (op1
, op2
);
1097 result
= gfc_or (op1
, op2
);
1101 result
= gfc_eqv (op1
, op2
);
1104 case INTRINSIC_NEQV
:
1105 result
= gfc_neqv (op1
, op2
);
1109 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1114 gfc_free_expr (op1
);
1115 gfc_free_expr (op2
);
1119 result
->rank
= p
->rank
;
1120 result
->where
= p
->where
;
1121 gfc_replace_expr (p
, result
);
1127 /* Subroutine to simplify constructor expressions. Mutually recursive
1128 with gfc_simplify_expr(). */
1131 simplify_constructor (gfc_constructor_base base
, int type
)
1136 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1139 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1140 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1141 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1146 /* Try and simplify a copy. Replace the original if successful
1147 but keep going through the constructor at all costs. Not
1148 doing so can make a dog's dinner of complicated things. */
1149 p
= gfc_copy_expr (c
->expr
);
1151 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1157 gfc_replace_expr (c
->expr
, p
);
1165 /* Pull a single array element out of an array constructor. */
1168 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1169 gfc_constructor
**rval
)
1171 unsigned long nelemen
;
1177 gfc_constructor
*cons
;
1184 mpz_init_set_ui (offset
, 0);
1187 mpz_init_set_ui (span
, 1);
1188 for (i
= 0; i
< ar
->dimen
; i
++)
1190 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1191 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1198 e
= gfc_copy_expr (ar
->start
[i
]);
1199 if (e
->expr_type
!= EXPR_CONSTANT
)
1205 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1206 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1208 /* Check the bounds. */
1209 if ((ar
->as
->upper
[i
]
1210 && mpz_cmp (e
->value
.integer
,
1211 ar
->as
->upper
[i
]->value
.integer
) > 0)
1212 || (mpz_cmp (e
->value
.integer
,
1213 ar
->as
->lower
[i
]->value
.integer
) < 0))
1215 gfc_error ("Index in dimension %d is out of bounds "
1216 "at %L", i
+ 1, &ar
->c_where
[i
]);
1222 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1223 mpz_mul (delta
, delta
, span
);
1224 mpz_add (offset
, offset
, delta
);
1226 mpz_set_ui (tmp
, 1);
1227 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1228 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1229 mpz_mul (span
, span
, tmp
);
1232 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1233 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1254 /* Find a component of a structure constructor. */
1256 static gfc_constructor
*
1257 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1259 gfc_component
*comp
;
1260 gfc_component
*pick
;
1261 gfc_constructor
*c
= gfc_constructor_first (base
);
1263 comp
= ref
->u
.c
.sym
->components
;
1264 pick
= ref
->u
.c
.component
;
1265 while (comp
!= pick
)
1268 c
= gfc_constructor_next (c
);
1275 /* Replace an expression with the contents of a constructor, removing
1276 the subobject reference in the process. */
1279 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1289 e
= gfc_copy_expr (p
);
1290 e
->ref
= p
->ref
->next
;
1291 p
->ref
->next
= NULL
;
1292 gfc_replace_expr (p
, e
);
1296 /* Pull an array section out of an array constructor. */
1299 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1306 long unsigned one
= 1;
1308 mpz_t start
[GFC_MAX_DIMENSIONS
];
1309 mpz_t end
[GFC_MAX_DIMENSIONS
];
1310 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1311 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1312 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1317 gfc_constructor_base base
;
1318 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1328 base
= expr
->value
.constructor
;
1329 expr
->value
.constructor
= NULL
;
1331 rank
= ref
->u
.ar
.as
->rank
;
1333 if (expr
->shape
== NULL
)
1334 expr
->shape
= gfc_get_shape (rank
);
1336 mpz_init_set_ui (delta_mpz
, one
);
1337 mpz_init_set_ui (nelts
, one
);
1340 /* Do the initialization now, so that we can cleanup without
1341 keeping track of where we were. */
1342 for (d
= 0; d
< rank
; d
++)
1344 mpz_init (delta
[d
]);
1345 mpz_init (start
[d
]);
1348 mpz_init (stride
[d
]);
1352 /* Build the counters to clock through the array reference. */
1354 for (d
= 0; d
< rank
; d
++)
1356 /* Make this stretch of code easier on the eye! */
1357 begin
= ref
->u
.ar
.start
[d
];
1358 finish
= ref
->u
.ar
.end
[d
];
1359 step
= ref
->u
.ar
.stride
[d
];
1360 lower
= ref
->u
.ar
.as
->lower
[d
];
1361 upper
= ref
->u
.ar
.as
->upper
[d
];
1363 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1365 gfc_constructor
*ci
;
1368 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1374 gcc_assert (begin
->rank
== 1);
1375 /* Zero-sized arrays have no shape and no elements, stop early. */
1378 mpz_init_set_ui (nelts
, 0);
1382 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1383 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1384 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1385 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1388 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1390 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1391 || mpz_cmp (ci
->expr
->value
.integer
,
1392 lower
->value
.integer
) < 0)
1394 gfc_error ("index in dimension %d is out of bounds "
1395 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1403 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1404 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1405 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1411 /* Obtain the stride. */
1413 mpz_set (stride
[d
], step
->value
.integer
);
1415 mpz_set_ui (stride
[d
], one
);
1417 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1418 mpz_set_ui (stride
[d
], one
);
1420 /* Obtain the start value for the index. */
1422 mpz_set (start
[d
], begin
->value
.integer
);
1424 mpz_set (start
[d
], lower
->value
.integer
);
1426 mpz_set (ctr
[d
], start
[d
]);
1428 /* Obtain the end value for the index. */
1430 mpz_set (end
[d
], finish
->value
.integer
);
1432 mpz_set (end
[d
], upper
->value
.integer
);
1434 /* Separate 'if' because elements sometimes arrive with
1436 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1437 mpz_set (end
[d
], begin
->value
.integer
);
1439 /* Check the bounds. */
1440 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1441 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1442 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1443 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1445 gfc_error ("index in dimension %d is out of bounds "
1446 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1451 /* Calculate the number of elements and the shape. */
1452 mpz_set (tmp_mpz
, stride
[d
]);
1453 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1454 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1455 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1456 mpz_mul (nelts
, nelts
, tmp_mpz
);
1458 /* An element reference reduces the rank of the expression; don't
1459 add anything to the shape array. */
1460 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1461 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1464 /* Calculate the 'stride' (=delta) for conversion of the
1465 counter values into the index along the constructor. */
1466 mpz_set (delta
[d
], delta_mpz
);
1467 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1468 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1469 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1473 cons
= gfc_constructor_first (base
);
1475 /* Now clock through the array reference, calculating the index in
1476 the source constructor and transferring the elements to the new
1478 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1480 if (ref
->u
.ar
.offset
)
1481 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1483 mpz_init_set_ui (ptr
, 0);
1486 for (d
= 0; d
< rank
; d
++)
1488 mpz_set (tmp_mpz
, ctr
[d
]);
1489 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1490 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1491 mpz_add (ptr
, ptr
, tmp_mpz
);
1493 if (!incr_ctr
) continue;
1495 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1497 gcc_assert(vecsub
[d
]);
1499 if (!gfc_constructor_next (vecsub
[d
]))
1500 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1503 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1506 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1510 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1512 if (mpz_cmp_ui (stride
[d
], 0) > 0
1513 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1514 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1515 mpz_set (ctr
[d
], start
[d
]);
1521 limit
= mpz_get_ui (ptr
);
1522 if (limit
>= gfc_option
.flag_max_array_constructor
)
1524 gfc_error ("The number of elements in the array constructor "
1525 "at %L requires an increase of the allowed %d "
1526 "upper limit. See -fmax-array-constructor "
1527 "option", &expr
->where
,
1528 gfc_option
.flag_max_array_constructor
);
1532 cons
= gfc_constructor_lookup (base
, limit
);
1534 gfc_constructor_append_expr (&expr
->value
.constructor
,
1535 gfc_copy_expr (cons
->expr
), NULL
);
1542 mpz_clear (delta_mpz
);
1543 mpz_clear (tmp_mpz
);
1545 for (d
= 0; d
< rank
; d
++)
1547 mpz_clear (delta
[d
]);
1548 mpz_clear (start
[d
]);
1551 mpz_clear (stride
[d
]);
1553 gfc_constructor_free (base
);
1557 /* Pull a substring out of an expression. */
1560 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1567 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1568 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1571 *newp
= gfc_copy_expr (p
);
1572 gfc_free ((*newp
)->value
.character
.string
);
1574 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1575 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1576 length
= end
- start
+ 1;
1578 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1579 (*newp
)->value
.character
.length
= length
;
1580 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1581 length
* sizeof (gfc_char_t
));
1588 /* Simplify a subobject reference of a constructor. This occurs when
1589 parameter variable values are substituted. */
1592 simplify_const_ref (gfc_expr
*p
)
1594 gfc_constructor
*cons
, *c
;
1600 switch (p
->ref
->type
)
1603 switch (p
->ref
->u
.ar
.type
)
1606 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1607 will generate this. */
1608 if (p
->expr_type
!= EXPR_ARRAY
)
1610 remove_subobject_ref (p
, NULL
);
1613 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1620 remove_subobject_ref (p
, cons
);
1624 if (find_array_section (p
, p
->ref
) == FAILURE
)
1626 p
->ref
->u
.ar
.type
= AR_FULL
;
1631 if (p
->ref
->next
!= NULL
1632 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1634 for (c
= gfc_constructor_first (p
->value
.constructor
);
1635 c
; c
= gfc_constructor_next (c
))
1637 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1638 if (simplify_const_ref (c
->expr
) == FAILURE
)
1642 if (p
->ts
.type
== BT_DERIVED
1644 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1646 /* There may have been component references. */
1647 p
->ts
= c
->expr
->ts
;
1651 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1653 if (p
->ts
.type
== BT_CHARACTER
1654 && last_ref
->type
== REF_SUBSTRING
)
1656 /* If this is a CHARACTER array and we possibly took
1657 a substring out of it, update the type-spec's
1658 character length according to the first element
1659 (as all should have the same length). */
1661 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1663 const gfc_expr
* first
= c
->expr
;
1664 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1665 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1666 string_len
= first
->value
.character
.length
;
1672 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1675 gfc_free_expr (p
->ts
.u
.cl
->length
);
1678 = gfc_get_int_expr (gfc_default_integer_kind
,
1682 gfc_free_ref_list (p
->ref
);
1693 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1694 remove_subobject_ref (p
, cons
);
1698 if (find_substring_ref (p
, &newp
) == FAILURE
)
1701 gfc_replace_expr (p
, newp
);
1702 gfc_free_ref_list (p
->ref
);
1712 /* Simplify a chain of references. */
1715 simplify_ref_chain (gfc_ref
*ref
, int type
)
1719 for (; ref
; ref
= ref
->next
)
1724 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1726 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1728 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1730 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1736 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1738 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1750 /* Try to substitute the value of a parameter variable. */
1753 simplify_parameter_variable (gfc_expr
*p
, int type
)
1758 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1764 /* Do not copy subobject refs for constant. */
1765 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1766 e
->ref
= gfc_copy_ref (p
->ref
);
1767 t
= gfc_simplify_expr (e
, type
);
1769 /* Only use the simplification if it eliminated all subobject references. */
1770 if (t
== SUCCESS
&& !e
->ref
)
1771 gfc_replace_expr (p
, e
);
1778 /* Given an expression, simplify it by collapsing constant
1779 expressions. Most simplification takes place when the expression
1780 tree is being constructed. If an intrinsic function is simplified
1781 at some point, we get called again to collapse the result against
1784 We work by recursively simplifying expression nodes, simplifying
1785 intrinsic functions where possible, which can lead to further
1786 constant collapsing. If an operator has constant operand(s), we
1787 rip the expression apart, and rebuild it, hoping that it becomes
1790 The expression type is defined for:
1791 0 Basic expression parsing
1792 1 Simplifying array constructors -- will substitute
1794 Returns FAILURE on error, SUCCESS otherwise.
1795 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1798 gfc_simplify_expr (gfc_expr
*p
, int type
)
1800 gfc_actual_arglist
*ap
;
1805 switch (p
->expr_type
)
1812 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1813 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1816 if (p
->value
.function
.isym
!= NULL
1817 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1822 case EXPR_SUBSTRING
:
1823 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1826 if (gfc_is_constant_expr (p
))
1832 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1834 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1835 start
--; /* Convert from one-based to zero-based. */
1838 end
= p
->value
.character
.length
;
1839 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1840 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1842 s
= gfc_get_wide_string (end
- start
+ 2);
1843 memcpy (s
, p
->value
.character
.string
+ start
,
1844 (end
- start
) * sizeof (gfc_char_t
));
1845 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1846 gfc_free (p
->value
.character
.string
);
1847 p
->value
.character
.string
= s
;
1848 p
->value
.character
.length
= end
- start
;
1849 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1850 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1852 p
->value
.character
.length
);
1853 gfc_free_ref_list (p
->ref
);
1855 p
->expr_type
= EXPR_CONSTANT
;
1860 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1865 /* Only substitute array parameter variables if we are in an
1866 initialization expression, or we want a subsection. */
1867 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1868 && (gfc_init_expr_flag
|| p
->ref
1869 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1871 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1878 gfc_simplify_iterator_var (p
);
1881 /* Simplify subcomponent references. */
1882 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1887 case EXPR_STRUCTURE
:
1889 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1892 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1895 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1896 && p
->ref
->u
.ar
.type
== AR_FULL
)
1897 gfc_expand_constructor (p
, false);
1899 if (simplify_const_ref (p
) == FAILURE
)
1914 /* Returns the type of an expression with the exception that iterator
1915 variables are automatically integers no matter what else they may
1921 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1928 /* Check an intrinsic arithmetic operation to see if it is consistent
1929 with some type of expression. */
1931 static gfc_try
check_init_expr (gfc_expr
*);
1934 /* Scalarize an expression for an elemental intrinsic call. */
1937 scalarize_intrinsic_call (gfc_expr
*e
)
1939 gfc_actual_arglist
*a
, *b
;
1940 gfc_constructor_base ctor
;
1941 gfc_constructor
*args
[5];
1942 gfc_constructor
*ci
, *new_ctor
;
1943 gfc_expr
*expr
, *old
;
1944 int n
, i
, rank
[5], array_arg
;
1946 /* Find which, if any, arguments are arrays. Assume that the old
1947 expression carries the type information and that the first arg
1948 that is an array expression carries all the shape information.*/
1950 a
= e
->value
.function
.actual
;
1951 for (; a
; a
= a
->next
)
1954 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1957 expr
= gfc_copy_expr (a
->expr
);
1964 old
= gfc_copy_expr (e
);
1966 gfc_constructor_free (expr
->value
.constructor
);
1967 expr
->value
.constructor
= NULL
;
1969 expr
->where
= old
->where
;
1970 expr
->expr_type
= EXPR_ARRAY
;
1972 /* Copy the array argument constructors into an array, with nulls
1975 a
= old
->value
.function
.actual
;
1976 for (; a
; a
= a
->next
)
1978 /* Check that this is OK for an initialization expression. */
1979 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1983 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1985 rank
[n
] = a
->expr
->rank
;
1986 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1987 args
[n
] = gfc_constructor_first (ctor
);
1989 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1992 rank
[n
] = a
->expr
->rank
;
1995 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
1996 args
[n
] = gfc_constructor_first (ctor
);
2005 /* Using the array argument as the master, step through the array
2006 calling the function for each element and advancing the array
2007 constructors together. */
2008 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2010 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2011 gfc_copy_expr (old
), NULL
);
2013 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2015 b
= old
->value
.function
.actual
;
2016 for (i
= 0; i
< n
; i
++)
2019 new_ctor
->expr
->value
.function
.actual
2020 = a
= gfc_get_actual_arglist ();
2023 a
->next
= gfc_get_actual_arglist ();
2028 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2030 a
->expr
= gfc_copy_expr (b
->expr
);
2035 /* Simplify the function calls. If the simplification fails, the
2036 error will be flagged up down-stream or the library will deal
2038 gfc_simplify_expr (new_ctor
->expr
, 0);
2040 for (i
= 0; i
< n
; i
++)
2042 args
[i
] = gfc_constructor_next (args
[i
]);
2044 for (i
= 1; i
< n
; i
++)
2045 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2046 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2052 gfc_free_expr (old
);
2056 gfc_error_now ("elemental function arguments at %C are not compliant");
2059 gfc_free_expr (expr
);
2060 gfc_free_expr (old
);
2066 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2068 gfc_expr
*op1
= e
->value
.op
.op1
;
2069 gfc_expr
*op2
= e
->value
.op
.op2
;
2071 if ((*check_function
) (op1
) == FAILURE
)
2074 switch (e
->value
.op
.op
)
2076 case INTRINSIC_UPLUS
:
2077 case INTRINSIC_UMINUS
:
2078 if (!numeric_type (et0 (op1
)))
2083 case INTRINSIC_EQ_OS
:
2085 case INTRINSIC_NE_OS
:
2087 case INTRINSIC_GT_OS
:
2089 case INTRINSIC_GE_OS
:
2091 case INTRINSIC_LT_OS
:
2093 case INTRINSIC_LE_OS
:
2094 if ((*check_function
) (op2
) == FAILURE
)
2097 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2098 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2100 gfc_error ("Numeric or CHARACTER operands are required in "
2101 "expression at %L", &e
->where
);
2106 case INTRINSIC_PLUS
:
2107 case INTRINSIC_MINUS
:
2108 case INTRINSIC_TIMES
:
2109 case INTRINSIC_DIVIDE
:
2110 case INTRINSIC_POWER
:
2111 if ((*check_function
) (op2
) == FAILURE
)
2114 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2119 case INTRINSIC_CONCAT
:
2120 if ((*check_function
) (op2
) == FAILURE
)
2123 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2125 gfc_error ("Concatenation operator in expression at %L "
2126 "must have two CHARACTER operands", &op1
->where
);
2130 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2132 gfc_error ("Concat operator at %L must concatenate strings of the "
2133 "same kind", &e
->where
);
2140 if (et0 (op1
) != BT_LOGICAL
)
2142 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2143 "operand", &op1
->where
);
2152 case INTRINSIC_NEQV
:
2153 if ((*check_function
) (op2
) == FAILURE
)
2156 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2158 gfc_error ("LOGICAL operands are required in expression at %L",
2165 case INTRINSIC_PARENTHESES
:
2169 gfc_error ("Only intrinsic operators can be used in expression at %L",
2177 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2182 /* F2003, 7.1.7 (3): In init expression, allocatable components
2183 must not be data-initialized. */
2185 check_alloc_comp_init (gfc_expr
*e
)
2187 gfc_component
*comp
;
2188 gfc_constructor
*ctor
;
2190 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2191 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2193 for (comp
= e
->ts
.u
.derived
->components
,
2194 ctor
= gfc_constructor_first (e
->value
.constructor
);
2195 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2197 if (comp
->attr
.allocatable
2198 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2200 gfc_error("Invalid initialization expression for ALLOCATABLE "
2201 "component '%s' in structure constructor at %L",
2202 comp
->name
, &ctor
->expr
->where
);
2211 check_init_expr_arguments (gfc_expr
*e
)
2213 gfc_actual_arglist
*ap
;
2215 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2216 if (check_init_expr (ap
->expr
) == FAILURE
)
2222 static gfc_try
check_restricted (gfc_expr
*);
2224 /* F95, 7.1.6.1, Initialization expressions, (7)
2225 F2003, 7.1.7 Initialization expression, (8) */
2228 check_inquiry (gfc_expr
*e
, int not_restricted
)
2231 const char *const *functions
;
2233 static const char *const inquiry_func_f95
[] = {
2234 "lbound", "shape", "size", "ubound",
2235 "bit_size", "len", "kind",
2236 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2237 "precision", "radix", "range", "tiny",
2241 static const char *const inquiry_func_f2003
[] = {
2242 "lbound", "shape", "size", "ubound",
2243 "bit_size", "len", "kind",
2244 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2245 "precision", "radix", "range", "tiny",
2250 gfc_actual_arglist
*ap
;
2252 if (!e
->value
.function
.isym
2253 || !e
->value
.function
.isym
->inquiry
)
2256 /* An undeclared parameter will get us here (PR25018). */
2257 if (e
->symtree
== NULL
)
2260 name
= e
->symtree
->n
.sym
->name
;
2262 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2263 ? inquiry_func_f2003
: inquiry_func_f95
;
2265 for (i
= 0; functions
[i
]; i
++)
2266 if (strcmp (functions
[i
], name
) == 0)
2269 if (functions
[i
] == NULL
)
2272 /* At this point we have an inquiry function with a variable argument. The
2273 type of the variable might be undefined, but we need it now, because the
2274 arguments of these functions are not allowed to be undefined. */
2276 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2281 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2283 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2284 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2288 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2291 /* Assumed character length will not reduce to a constant expression
2292 with LEN, as required by the standard. */
2293 if (i
== 5 && not_restricted
2294 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2295 && ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
)
2297 gfc_error ("Assumed character length variable '%s' in constant "
2298 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
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
)
2314 /* F95, 7.1.6.1, Initialization expressions, (5)
2315 F2003, 7.1.7 Initialization expression, (5) */
2318 check_transformational (gfc_expr
*e
)
2320 static const char * const trans_func_f95
[] = {
2321 "repeat", "reshape", "selected_int_kind",
2322 "selected_real_kind", "transfer", "trim", NULL
2325 static const char * const trans_func_f2003
[] = {
2326 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2327 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2328 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2329 "trim", "unpack", NULL
2334 const char *const *functions
;
2336 if (!e
->value
.function
.isym
2337 || !e
->value
.function
.isym
->transformational
)
2340 name
= e
->symtree
->n
.sym
->name
;
2342 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2343 ? trans_func_f2003
: trans_func_f95
;
2345 /* NULL() is dealt with below. */
2346 if (strcmp ("null", name
) == 0)
2349 for (i
= 0; functions
[i
]; i
++)
2350 if (strcmp (functions
[i
], name
) == 0)
2353 if (functions
[i
] == NULL
)
2355 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2356 "in an initialization expression", name
, &e
->where
);
2360 return check_init_expr_arguments (e
);
2364 /* F95, 7.1.6.1, Initialization expressions, (6)
2365 F2003, 7.1.7 Initialization expression, (6) */
2368 check_null (gfc_expr
*e
)
2370 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2373 return check_init_expr_arguments (e
);
2378 check_elemental (gfc_expr
*e
)
2380 if (!e
->value
.function
.isym
2381 || !e
->value
.function
.isym
->elemental
)
2384 if (e
->ts
.type
!= BT_INTEGER
2385 && e
->ts
.type
!= BT_CHARACTER
2386 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2387 "nonstandard initialization expression at %L",
2388 &e
->where
) == FAILURE
)
2391 return check_init_expr_arguments (e
);
2396 check_conversion (gfc_expr
*e
)
2398 if (!e
->value
.function
.isym
2399 || !e
->value
.function
.isym
->conversion
)
2402 return check_init_expr_arguments (e
);
2406 /* Verify that an expression is an initialization expression. A side
2407 effect is that the expression tree is reduced to a single constant
2408 node if all goes well. This would normally happen when the
2409 expression is constructed but function references are assumed to be
2410 intrinsics in the context of initialization expressions. If
2411 FAILURE is returned an error message has been generated. */
2414 check_init_expr (gfc_expr
*e
)
2422 switch (e
->expr_type
)
2425 t
= check_intrinsic_op (e
, check_init_expr
);
2427 t
= gfc_simplify_expr (e
, 0);
2435 gfc_intrinsic_sym
* isym
;
2438 sym
= e
->symtree
->n
.sym
;
2439 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2440 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2442 gfc_error ("Function '%s' in initialization expression at %L "
2443 "must be an intrinsic function",
2444 e
->symtree
->n
.sym
->name
, &e
->where
);
2448 if ((m
= check_conversion (e
)) == MATCH_NO
2449 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2450 && (m
= check_null (e
)) == MATCH_NO
2451 && (m
= check_transformational (e
)) == MATCH_NO
2452 && (m
= check_elemental (e
)) == MATCH_NO
)
2454 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2455 "in an initialization expression",
2456 e
->symtree
->n
.sym
->name
, &e
->where
);
2460 /* Try to scalarize an elemental intrinsic function that has an
2462 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2463 if (isym
&& isym
->elemental
2464 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2469 t
= gfc_simplify_expr (e
, 0);
2476 if (gfc_check_iter_variable (e
) == SUCCESS
)
2479 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2481 /* A PARAMETER shall not be used to define itself, i.e.
2482 REAL, PARAMETER :: x = transfer(0, x)
2484 if (!e
->symtree
->n
.sym
->value
)
2486 gfc_error("PARAMETER '%s' is used at %L before its definition "
2487 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2491 t
= simplify_parameter_variable (e
, 0);
2496 if (gfc_in_match_data ())
2501 if (e
->symtree
->n
.sym
->as
)
2503 switch (e
->symtree
->n
.sym
->as
->type
)
2505 case AS_ASSUMED_SIZE
:
2506 gfc_error ("Assumed size array '%s' at %L is not permitted "
2507 "in an initialization expression",
2508 e
->symtree
->n
.sym
->name
, &e
->where
);
2511 case AS_ASSUMED_SHAPE
:
2512 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2513 "in an initialization expression",
2514 e
->symtree
->n
.sym
->name
, &e
->where
);
2518 gfc_error ("Deferred array '%s' at %L is not permitted "
2519 "in an initialization expression",
2520 e
->symtree
->n
.sym
->name
, &e
->where
);
2524 gfc_error ("Array '%s' at %L is a variable, which does "
2525 "not reduce to a constant expression",
2526 e
->symtree
->n
.sym
->name
, &e
->where
);
2534 gfc_error ("Parameter '%s' at %L has not been declared or is "
2535 "a variable, which does not reduce to a constant "
2536 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2545 case EXPR_SUBSTRING
:
2546 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2550 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2552 t
= gfc_simplify_expr (e
, 0);
2556 case EXPR_STRUCTURE
:
2557 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2561 t
= check_alloc_comp_init (e
);
2565 t
= gfc_check_constructor (e
, check_init_expr
);
2572 t
= gfc_check_constructor (e
, check_init_expr
);
2576 t
= gfc_expand_constructor (e
, true);
2580 t
= gfc_check_constructor_type (e
);
2584 gfc_internal_error ("check_init_expr(): Unknown expression type");
2590 /* Reduces a general expression to an initialization expression (a constant).
2591 This used to be part of gfc_match_init_expr.
2592 Note that this function doesn't free the given expression on FAILURE. */
2595 gfc_reduce_init_expr (gfc_expr
*expr
)
2599 gfc_init_expr_flag
= true;
2600 t
= gfc_resolve_expr (expr
);
2602 t
= check_init_expr (expr
);
2603 gfc_init_expr_flag
= false;
2608 if (expr
->expr_type
== EXPR_ARRAY
)
2610 if (gfc_check_constructor_type (expr
) == FAILURE
)
2612 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2620 /* Match an initialization expression. We work by first matching an
2621 expression, then reducing it to a constant. */
2624 gfc_match_init_expr (gfc_expr
**result
)
2632 gfc_init_expr_flag
= true;
2634 m
= gfc_match_expr (&expr
);
2637 gfc_init_expr_flag
= false;
2641 t
= gfc_reduce_init_expr (expr
);
2644 gfc_free_expr (expr
);
2645 gfc_init_expr_flag
= false;
2650 gfc_init_expr_flag
= false;
2656 /* Given an actual argument list, test to see that each argument is a
2657 restricted expression and optionally if the expression type is
2658 integer or character. */
2661 restricted_args (gfc_actual_arglist
*a
)
2663 for (; a
; a
= a
->next
)
2665 if (check_restricted (a
->expr
) == FAILURE
)
2673 /************* Restricted/specification expressions *************/
2676 /* Make sure a non-intrinsic function is a specification function. */
2679 external_spec_function (gfc_expr
*e
)
2683 f
= e
->value
.function
.esym
;
2685 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2687 gfc_error ("Specification function '%s' at %L cannot be a statement "
2688 "function", f
->name
, &e
->where
);
2692 if (f
->attr
.proc
== PROC_INTERNAL
)
2694 gfc_error ("Specification function '%s' at %L cannot be an internal "
2695 "function", f
->name
, &e
->where
);
2699 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2701 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2706 if (f
->attr
.recursive
)
2708 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2709 f
->name
, &e
->where
);
2713 return restricted_args (e
->value
.function
.actual
);
2717 /* Check to see that a function reference to an intrinsic is a
2718 restricted expression. */
2721 restricted_intrinsic (gfc_expr
*e
)
2723 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2724 if (check_inquiry (e
, 0) == MATCH_YES
)
2727 return restricted_args (e
->value
.function
.actual
);
2731 /* Check the expressions of an actual arglist. Used by check_restricted. */
2734 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2736 for (; arg
; arg
= arg
->next
)
2737 if (checker (arg
->expr
) == FAILURE
)
2744 /* Check the subscription expressions of a reference chain with a checking
2745 function; used by check_restricted. */
2748 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2758 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2760 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2762 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2764 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2770 /* Nothing needed, just proceed to next reference. */
2774 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2776 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2785 return check_references (ref
->next
, checker
);
2789 /* Verify that an expression is a restricted expression. Like its
2790 cousin check_init_expr(), an error message is generated if we
2794 check_restricted (gfc_expr
*e
)
2802 switch (e
->expr_type
)
2805 t
= check_intrinsic_op (e
, check_restricted
);
2807 t
= gfc_simplify_expr (e
, 0);
2812 if (e
->value
.function
.esym
)
2814 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2816 t
= external_spec_function (e
);
2820 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2823 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2826 t
= restricted_intrinsic (e
);
2831 sym
= e
->symtree
->n
.sym
;
2834 /* If a dummy argument appears in a context that is valid for a
2835 restricted expression in an elemental procedure, it will have
2836 already been simplified away once we get here. Therefore we
2837 don't need to jump through hoops to distinguish valid from
2839 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2840 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2842 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2843 sym
->name
, &e
->where
);
2847 if (sym
->attr
.optional
)
2849 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2850 sym
->name
, &e
->where
);
2854 if (sym
->attr
.intent
== INTENT_OUT
)
2856 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2857 sym
->name
, &e
->where
);
2861 /* Check reference chain if any. */
2862 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2865 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2866 processed in resolve.c(resolve_formal_arglist). This is done so
2867 that host associated dummy array indices are accepted (PR23446).
2868 This mechanism also does the same for the specification expressions
2869 of array-valued functions. */
2871 || sym
->attr
.in_common
2872 || sym
->attr
.use_assoc
2874 || sym
->attr
.implied_index
2875 || sym
->attr
.flavor
== FL_PARAMETER
2876 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2877 || (sym
->ns
&& gfc_current_ns
->parent
2878 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2879 || (sym
->ns
->proc_name
!= NULL
2880 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2881 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2887 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2888 sym
->name
, &e
->where
);
2889 /* Prevent a repetition of the error. */
2898 case EXPR_SUBSTRING
:
2899 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2903 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2905 t
= gfc_simplify_expr (e
, 0);
2909 case EXPR_STRUCTURE
:
2910 t
= gfc_check_constructor (e
, check_restricted
);
2914 t
= gfc_check_constructor (e
, check_restricted
);
2918 gfc_internal_error ("check_restricted(): Unknown expression type");
2925 /* Check to see that an expression is a specification expression. If
2926 we return FAILURE, an error has been generated. */
2929 gfc_specification_expr (gfc_expr
*e
)
2931 gfc_component
*comp
;
2936 if (e
->ts
.type
!= BT_INTEGER
)
2938 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2939 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2943 if (e
->expr_type
== EXPR_FUNCTION
2944 && !e
->value
.function
.isym
2945 && !e
->value
.function
.esym
2946 && !gfc_pure (e
->symtree
->n
.sym
)
2947 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2948 || !comp
->attr
.pure
))
2950 gfc_error ("Function '%s' at %L must be PURE",
2951 e
->symtree
->n
.sym
->name
, &e
->where
);
2952 /* Prevent repeat error messages. */
2953 e
->symtree
->n
.sym
->attr
.pure
= 1;
2959 gfc_error ("Expression at %L must be scalar", &e
->where
);
2963 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2966 return check_restricted (e
);
2970 /************** Expression conformance checks. *************/
2972 /* Given two expressions, make sure that the arrays are conformable. */
2975 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
2977 int op1_flag
, op2_flag
, d
;
2978 mpz_t op1_size
, op2_size
;
2984 if (op1
->rank
== 0 || op2
->rank
== 0)
2987 va_start (argp
, optype_msgid
);
2988 vsnprintf (buffer
, 240, optype_msgid
, argp
);
2991 if (op1
->rank
!= op2
->rank
)
2993 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
2994 op1
->rank
, op2
->rank
, &op1
->where
);
3000 for (d
= 0; d
< op1
->rank
; d
++)
3002 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3003 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3005 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3007 gfc_error ("Different shape for %s at %L on dimension %d "
3008 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3009 (int) mpz_get_si (op1_size
),
3010 (int) mpz_get_si (op2_size
));
3016 mpz_clear (op1_size
);
3018 mpz_clear (op2_size
);
3028 /* Given an assignable expression and an arbitrary expression, make
3029 sure that the assignment can take place. */
3032 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3038 sym
= lvalue
->symtree
->n
.sym
;
3040 /* Check INTENT(IN), unless the object itself is the component or
3041 sub-component of a pointer. */
3042 has_pointer
= sym
->attr
.pointer
;
3044 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3045 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3051 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
3053 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3054 sym
->name
, &lvalue
->where
);
3058 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3059 variable local to a function subprogram. Its existence begins when
3060 execution of the function is initiated and ends when execution of the
3061 function is terminated...
3062 Therefore, the left hand side is no longer a variable, when it is: */
3063 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3064 && !sym
->attr
.external
)
3069 /* (i) Use associated; */
3070 if (sym
->attr
.use_assoc
)
3073 /* (ii) The assignment is in the main program; or */
3074 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3077 /* (iii) A module or internal procedure... */
3078 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3079 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3080 && gfc_current_ns
->parent
3081 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3082 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3083 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3085 /* ... that is not a function... */
3086 if (!gfc_current_ns
->proc_name
->attr
.function
)
3089 /* ... or is not an entry and has a different name. */
3090 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3094 /* (iv) Host associated and not the function symbol or the
3095 parent result. This picks up sibling references, which
3096 cannot be entries. */
3097 if (!sym
->attr
.entry
3098 && sym
->ns
== gfc_current_ns
->parent
3099 && sym
!= gfc_current_ns
->proc_name
3100 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3105 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3110 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3112 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3113 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3117 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3119 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3124 if (rvalue
->expr_type
== EXPR_NULL
)
3126 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3127 && lvalue
->symtree
->n
.sym
->attr
.data
)
3131 gfc_error ("NULL appears on right-hand side in assignment at %L",
3137 /* This is possibly a typo: x = f() instead of x => f(). */
3138 if (gfc_option
.warn_surprising
3139 && rvalue
->expr_type
== EXPR_FUNCTION
3140 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3141 gfc_warning ("POINTER valued function appears on right-hand side of "
3142 "assignment at %L", &rvalue
->where
);
3144 /* Check size of array assignments. */
3145 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3146 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3149 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3150 && lvalue
->symtree
->n
.sym
->attr
.data
3151 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3152 "initialize non-integer variable '%s'",
3153 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3156 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3157 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3158 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3159 &rvalue
->where
) == FAILURE
)
3162 /* Handle the case of a BOZ literal on the RHS. */
3163 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3166 if (gfc_option
.warn_surprising
)
3167 gfc_warning ("BOZ literal at %L is bitwise transferred "
3168 "non-integer symbol '%s'", &rvalue
->where
,
3169 lvalue
->symtree
->n
.sym
->name
);
3170 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3172 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3174 if (rc
== ARITH_UNDERFLOW
)
3175 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3176 ". This check can be disabled with the option "
3177 "-fno-range-check", &rvalue
->where
);
3178 else if (rc
== ARITH_OVERFLOW
)
3179 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3180 ". This check can be disabled with the option "
3181 "-fno-range-check", &rvalue
->where
);
3182 else if (rc
== ARITH_NAN
)
3183 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3184 ". This check can be disabled with the option "
3185 "-fno-range-check", &rvalue
->where
);
3190 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3193 /* Only DATA Statements come here. */
3196 /* Numeric can be converted to any other numeric. And Hollerith can be
3197 converted to any other type. */
3198 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3199 || rvalue
->ts
.type
== BT_HOLLERITH
)
3202 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3205 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3206 "conversion of %s to %s", &lvalue
->where
,
3207 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3212 /* Assignment is the only case where character variables of different
3213 kind values can be converted into one another. */
3214 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3216 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3217 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3222 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3226 /* Check that a pointer assignment is OK. We first check lvalue, and
3227 we only check rvalue if it's not an assignment to NULL() or a
3228 NULLIFY statement. */
3231 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3233 symbol_attribute attr
;
3236 int pointer
, check_intent_in
, proc_pointer
;
3238 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3239 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3241 gfc_error ("Pointer assignment target is not a POINTER at %L",
3246 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3247 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3248 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3250 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3251 "l-value since it is a procedure",
3252 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3257 /* Check INTENT(IN), unless the object itself is the component or
3258 sub-component of a pointer. */
3259 check_intent_in
= 1;
3260 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
3261 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3263 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3266 check_intent_in
= 0;
3268 if (ref
->type
== REF_COMPONENT
)
3270 pointer
= ref
->u
.c
.component
->attr
.pointer
;
3271 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3274 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3276 if (ref
->u
.ar
.type
== AR_FULL
)
3279 if (ref
->u
.ar
.type
!= AR_SECTION
)
3281 gfc_error ("Expected bounds specification for '%s' at %L",
3282 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3286 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3287 "specification for '%s' in pointer assignment "
3288 "at %L", lvalue
->symtree
->n
.sym
->name
,
3289 &lvalue
->where
) == FAILURE
)
3292 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3293 "in gfortran", &lvalue
->where
);
3294 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3295 either never or always the upper-bound; strides shall not be
3301 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3303 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3304 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3308 if (!pointer
&& !proc_pointer
3309 && !(lvalue
->ts
.type
== BT_CLASS
3310 && CLASS_DATA (lvalue
)->attr
.class_pointer
))
3312 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
3316 is_pure
= gfc_pure (NULL
);
3318 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
3319 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
3321 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
3325 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3326 kind, etc for lvalue and rvalue must match, and rvalue must be a
3327 pure variable if we're in a pure function. */
3328 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3331 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3332 if (lvalue
->expr_type
== EXPR_VARIABLE
3333 && gfc_is_coindexed (lvalue
))
3336 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3337 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3339 gfc_error ("Pointer object at %L shall not have a coindex",
3345 /* Checks on rvalue for procedure pointer assignments. */
3350 gfc_component
*comp
;
3353 attr
= gfc_expr_attr (rvalue
);
3354 if (!((rvalue
->expr_type
== EXPR_NULL
)
3355 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3356 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3357 || (rvalue
->expr_type
== EXPR_VARIABLE
3358 && attr
.flavor
== FL_PROCEDURE
)))
3360 gfc_error ("Invalid procedure pointer assignment at %L",
3366 gfc_error ("Abstract interface '%s' is invalid "
3367 "in procedure pointer assignment at %L",
3368 rvalue
->symtree
->name
, &rvalue
->where
);
3371 /* Check for C727. */
3372 if (attr
.flavor
== FL_PROCEDURE
)
3374 if (attr
.proc
== PROC_ST_FUNCTION
)
3376 gfc_error ("Statement function '%s' is invalid "
3377 "in procedure pointer assignment at %L",
3378 rvalue
->symtree
->name
, &rvalue
->where
);
3381 if (attr
.proc
== PROC_INTERNAL
&&
3382 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3383 "invalid in procedure pointer assignment at %L",
3384 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3388 /* Ensure that the calling convention is the same. As other attributes
3389 such as DLLEXPORT may differ, one explicitly only tests for the
3390 calling conventions. */
3391 if (rvalue
->expr_type
== EXPR_VARIABLE
3392 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3393 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3395 symbol_attribute calls
;
3398 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3399 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3400 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3402 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3403 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3405 gfc_error ("Mismatch in the procedure pointer assignment "
3406 "at %L: mismatch in the calling convention",
3412 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3413 s1
= comp
->ts
.interface
;
3415 s1
= lvalue
->symtree
->n
.sym
;
3417 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3419 s2
= comp
->ts
.interface
;
3422 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3424 s2
= rvalue
->symtree
->n
.sym
->result
;
3425 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3429 s2
= rvalue
->symtree
->n
.sym
;
3430 name
= rvalue
->symtree
->n
.sym
->name
;
3433 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3436 gfc_error ("Interface mismatch in procedure pointer assignment "
3437 "at %L: %s", &rvalue
->where
, err
);
3444 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3446 gfc_error ("Different types in pointer assignment at %L; attempted "
3447 "assignment of %s to %s", &lvalue
->where
,
3448 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3452 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3454 gfc_error ("Different kind type parameters in pointer "
3455 "assignment at %L", &lvalue
->where
);
3459 if (lvalue
->rank
!= rvalue
->rank
)
3461 gfc_error ("Different ranks in pointer assignment at %L",
3466 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3467 if (rvalue
->expr_type
== EXPR_NULL
)
3470 if (lvalue
->ts
.type
== BT_CHARACTER
)
3472 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3477 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3478 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3480 attr
= gfc_expr_attr (rvalue
);
3481 if (!attr
.target
&& !attr
.pointer
)
3483 gfc_error ("Pointer assignment target is neither TARGET "
3484 "nor POINTER at %L", &rvalue
->where
);
3488 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3490 gfc_error ("Bad target in pointer assignment in PURE "
3491 "procedure at %L", &rvalue
->where
);
3494 if (gfc_has_vector_index (rvalue
))
3496 gfc_error ("Pointer assignment with vector subscript "
3497 "on rhs at %L", &rvalue
->where
);
3501 if (attr
.is_protected
&& attr
.use_assoc
3502 && !(attr
.pointer
|| attr
.proc_pointer
))
3504 gfc_error ("Pointer assignment target has PROTECTED "
3505 "attribute at %L", &rvalue
->where
);
3509 /* F2008, C725. For PURE also C1283. */
3510 if (rvalue
->expr_type
== EXPR_VARIABLE
3511 && gfc_is_coindexed (rvalue
))
3514 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3515 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3517 gfc_error ("Data target at %L shall not have a coindex",
3527 /* Relative of gfc_check_assign() except that the lvalue is a single
3528 symbol. Used for initialization assignments. */
3531 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3536 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3538 lvalue
.expr_type
= EXPR_VARIABLE
;
3539 lvalue
.ts
= sym
->ts
;
3541 lvalue
.rank
= sym
->as
->rank
;
3542 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
3543 lvalue
.symtree
->n
.sym
= sym
;
3544 lvalue
.where
= sym
->declared_at
;
3546 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3547 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
3548 && rvalue
->expr_type
== EXPR_NULL
))
3549 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3551 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3553 gfc_free (lvalue
.symtree
);
3559 /* Check for default initializer; sym->value is not enough
3560 as it is also set for EXPR_NULL of allocatables. */
3563 gfc_has_default_initializer (gfc_symbol
*der
)
3567 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3568 for (c
= der
->components
; c
; c
= c
->next
)
3569 if (c
->ts
.type
== BT_DERIVED
)
3571 if (!c
->attr
.pointer
3572 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3584 /* Get an expression for a default initializer. */
3587 gfc_default_initializer (gfc_typespec
*ts
)
3590 gfc_component
*comp
;
3592 /* See if we have a default initializer in this, but not in nested
3593 types (otherwise we could use gfc_has_default_initializer()). */
3594 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3595 if (comp
->initializer
|| comp
->attr
.allocatable
)
3601 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3602 &ts
->u
.derived
->declared_at
);
3605 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3607 gfc_constructor
*ctor
= gfc_constructor_get();
3609 if (comp
->initializer
)
3610 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3612 if (comp
->attr
.allocatable
)
3614 ctor
->expr
= gfc_get_expr ();
3615 ctor
->expr
->expr_type
= EXPR_NULL
;
3616 ctor
->expr
->ts
= comp
->ts
;
3619 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3626 /* Given a symbol, create an expression node with that symbol as a
3627 variable. If the symbol is array valued, setup a reference of the
3631 gfc_get_variable_expr (gfc_symtree
*var
)
3635 e
= gfc_get_expr ();
3636 e
->expr_type
= EXPR_VARIABLE
;
3638 e
->ts
= var
->n
.sym
->ts
;
3640 if (var
->n
.sym
->as
!= NULL
)
3642 e
->rank
= var
->n
.sym
->as
->rank
;
3643 e
->ref
= gfc_get_ref ();
3644 e
->ref
->type
= REF_ARRAY
;
3645 e
->ref
->u
.ar
.type
= AR_FULL
;
3652 /* Returns the array_spec of a full array expression. A NULL is
3653 returned otherwise. */
3655 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3660 if (expr
->rank
== 0)
3663 /* Follow any component references. */
3664 if (expr
->expr_type
== EXPR_VARIABLE
3665 || expr
->expr_type
== EXPR_CONSTANT
)
3667 as
= expr
->symtree
->n
.sym
->as
;
3668 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3673 as
= ref
->u
.c
.component
->as
;
3681 switch (ref
->u
.ar
.type
)
3704 /* General expression traversal function. */
3707 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3708 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3713 gfc_actual_arglist
*args
;
3720 if ((*func
) (expr
, sym
, &f
))
3723 if (expr
->ts
.type
== BT_CHARACTER
3725 && expr
->ts
.u
.cl
->length
3726 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3727 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3730 switch (expr
->expr_type
)
3735 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3737 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3745 case EXPR_SUBSTRING
:
3748 case EXPR_STRUCTURE
:
3750 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3751 c
; c
= gfc_constructor_next (c
))
3753 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3757 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3759 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3761 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3763 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3770 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3772 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3788 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3790 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3792 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3794 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3800 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3802 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3807 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3808 && ref
->u
.c
.component
->ts
.u
.cl
3809 && ref
->u
.c
.component
->ts
.u
.cl
->length
3810 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
3812 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
3816 if (ref
->u
.c
.component
->as
)
3817 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
3818 + ref
->u
.c
.component
->as
->corank
; i
++)
3820 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3823 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3837 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3840 expr_set_symbols_referenced (gfc_expr
*expr
,
3841 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3842 int *f ATTRIBUTE_UNUSED
)
3844 if (expr
->expr_type
!= EXPR_VARIABLE
)
3846 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3851 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3853 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
3857 /* Determine if an expression is a procedure pointer component. If yes, the
3858 argument 'comp' will point to the component (provided that 'comp' was
3862 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
3867 if (!expr
|| !expr
->ref
)
3874 if (ref
->type
== REF_COMPONENT
)
3876 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
3878 *comp
= ref
->u
.c
.component
;
3885 /* Walk an expression tree and check each variable encountered for being typed.
3886 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3887 mode as is a basic arithmetic expression using those; this is for things in
3890 INTEGER :: arr(n), n
3891 INTEGER :: arr(n + 1), n
3893 The namespace is needed for IMPLICIT typing. */
3895 static gfc_namespace
* check_typed_ns
;
3898 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3899 int* f ATTRIBUTE_UNUSED
)
3903 if (e
->expr_type
!= EXPR_VARIABLE
)
3906 gcc_assert (e
->symtree
);
3907 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
3910 return (t
== FAILURE
);
3914 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
3918 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3922 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
3923 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
3925 if (e
->expr_type
== EXPR_OP
)
3927 gfc_try t
= SUCCESS
;
3929 gcc_assert (e
->value
.op
.op1
);
3930 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
3932 if (t
== SUCCESS
&& e
->value
.op
.op2
)
3933 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
3939 /* Otherwise, walk the expression and do it strictly. */
3940 check_typed_ns
= ns
;
3941 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
3943 return error_found
? FAILURE
: SUCCESS
;
3946 /* Walk an expression tree and replace all symbols with a corresponding symbol
3947 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3948 statements. The boolean return value is required by gfc_traverse_expr. */
3951 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3953 if ((expr
->expr_type
== EXPR_VARIABLE
3954 || (expr
->expr_type
== EXPR_FUNCTION
3955 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
3956 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
3959 gfc_namespace
*ns
= sym
->formal_ns
;
3960 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3961 the symtree rather than create a new one (and probably fail later). */
3962 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
3963 expr
->symtree
->n
.sym
->name
);
3965 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
3966 expr
->symtree
= stree
;
3972 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
3974 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
3977 /* The following is analogous to 'replace_symbol', and needed for copying
3978 interfaces for procedure pointer components. The argument 'sym' must formally
3979 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3980 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3981 component in whose formal_ns the arguments have to be). */
3984 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3986 gfc_component
*comp
;
3987 comp
= (gfc_component
*)sym
;
3988 if ((expr
->expr_type
== EXPR_VARIABLE
3989 || (expr
->expr_type
== EXPR_FUNCTION
3990 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
3991 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
3994 gfc_namespace
*ns
= comp
->formal_ns
;
3995 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3996 the symtree rather than create a new one (and probably fail later). */
3997 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
3998 expr
->symtree
->n
.sym
->name
);
4000 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4001 expr
->symtree
= stree
;
4007 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4009 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4014 gfc_is_coindexed (gfc_expr
*e
)
4018 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4019 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4027 gfc_get_corank (gfc_expr
*e
)
4031 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4032 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4034 if (ref
->type
== REF_ARRAY
)
4035 corank
= ref
->u
.ar
.as
->corank
;
4036 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4042 /* Check whether the expression has an ultimate allocatable component.
4043 Being itself allocatable does not count. */
4045 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4047 gfc_ref
*ref
, *last
= NULL
;
4049 if (e
->expr_type
!= EXPR_VARIABLE
)
4052 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4053 if (ref
->type
== REF_COMPONENT
)
4056 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4057 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4058 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4059 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4063 if (e
->ts
.type
== BT_CLASS
)
4064 return CLASS_DATA (e
)->attr
.alloc_comp
;
4065 else if (e
->ts
.type
== BT_DERIVED
)
4066 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4072 /* Check whether the expression has an pointer component.
4073 Being itself a pointer does not count. */
4075 gfc_has_ultimate_pointer (gfc_expr
*e
)
4077 gfc_ref
*ref
, *last
= NULL
;
4079 if (e
->expr_type
!= EXPR_VARIABLE
)
4082 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4083 if (ref
->type
== REF_COMPONENT
)
4086 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4087 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4088 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4089 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4093 if (e
->ts
.type
== BT_CLASS
)
4094 return CLASS_DATA (e
)->attr
.pointer_comp
;
4095 else if (e
->ts
.type
== BT_DERIVED
)
4096 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4102 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4103 Note: A scalar is not regarded as "simply contiguous" by the standard.
4104 if bool is not strict, some futher checks are done - for instance,
4105 a "(::1)" is accepted. */
4108 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4112 gfc_array_ref
*ar
= NULL
;
4113 gfc_ref
*ref
, *part_ref
= NULL
;
4115 if (expr
->expr_type
== EXPR_FUNCTION
)
4116 return expr
->value
.function
.esym
4117 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4118 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4121 if (expr
->rank
== 0)
4124 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4127 return false; /* Array shall be last part-ref. */
4129 if (ref
->type
== REF_COMPONENT
)
4131 else if (ref
->type
== REF_SUBSTRING
)
4133 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4137 if ((part_ref
&& !part_ref
->u
.c
.component
->attr
.contiguous
4138 && part_ref
->u
.c
.component
->attr
.pointer
)
4139 || (!part_ref
&& !expr
->symtree
->n
.sym
->attr
.contiguous
4140 && (expr
->symtree
->n
.sym
->attr
.pointer
4141 || expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)))
4144 if (!ar
|| ar
->type
== AR_FULL
)
4147 gcc_assert (ar
->type
== AR_SECTION
);
4149 /* Check for simply contiguous array */
4151 for (i
= 0; i
< ar
->dimen
; i
++)
4153 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4156 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4162 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4165 /* If the previous section was not contiguous, that's an error,
4166 unless we have effective only one element and checking is not
4168 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4169 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4170 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4171 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4172 ar
->end
[i
]->value
.integer
) != 0))
4175 /* Following the standard, "(::1)" or - if known at compile time -
4176 "(lbound:ubound)" are not simply contigous; if strict
4177 is false, they are regarded as simply contiguous. */
4178 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4179 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4180 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4184 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4185 || !ar
->as
->lower
[i
]
4186 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4187 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4188 ar
->as
->lower
[i
]->value
.integer
) != 0))
4192 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4193 || !ar
->as
->upper
[i
]
4194 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4195 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4196 ar
->as
->upper
[i
]->value
.integer
) != 0))