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 free (e
->value
.character
.string
);
428 mpc_clear (e
->value
.complex);
435 /* Free the representation. */
436 free (e
->representation
.string
);
441 if (e
->value
.op
.op1
!= NULL
)
442 gfc_free_expr (e
->value
.op
.op1
);
443 if (e
->value
.op
.op2
!= NULL
)
444 gfc_free_expr (e
->value
.op
.op2
);
448 gfc_free_actual_arglist (e
->value
.function
.actual
);
453 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
461 gfc_constructor_free (e
->value
.constructor
);
465 free (e
->value
.character
.string
);
472 gfc_internal_error ("free_expr0(): Bad expr type");
475 /* Free a shape array. */
476 if (e
->shape
!= NULL
)
478 for (n
= 0; n
< e
->rank
; n
++)
479 mpz_clear (e
->shape
[n
]);
484 gfc_free_ref_list (e
->ref
);
486 memset (e
, '\0', sizeof (gfc_expr
));
490 /* Free an expression node and everything beneath it. */
493 gfc_free_expr (gfc_expr
*e
)
502 /* Free an argument list and everything below it. */
505 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
507 gfc_actual_arglist
*a2
;
512 gfc_free_expr (a1
->expr
);
519 /* Copy an arglist structure and all of the arguments. */
522 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
524 gfc_actual_arglist
*head
, *tail
, *new_arg
;
528 for (; p
; p
= p
->next
)
530 new_arg
= gfc_get_actual_arglist ();
533 new_arg
->expr
= gfc_copy_expr (p
->expr
);
534 new_arg
->next
= NULL
;
539 tail
->next
= new_arg
;
548 /* Free a list of reference structures. */
551 gfc_free_ref_list (gfc_ref
*p
)
563 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
565 gfc_free_expr (p
->u
.ar
.start
[i
]);
566 gfc_free_expr (p
->u
.ar
.end
[i
]);
567 gfc_free_expr (p
->u
.ar
.stride
[i
]);
573 gfc_free_expr (p
->u
.ss
.start
);
574 gfc_free_expr (p
->u
.ss
.end
);
586 /* Graft the *src expression onto the *dest subexpression. */
589 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
597 /* Try to extract an integer constant from the passed expression node.
598 Returns an error message or NULL if the result is set. It is
599 tempting to generate an error and return SUCCESS or FAILURE, but
600 failure is OK for some callers. */
603 gfc_extract_int (gfc_expr
*expr
, int *result
)
605 if (expr
->expr_type
!= EXPR_CONSTANT
)
606 return _("Constant expression required at %C");
608 if (expr
->ts
.type
!= BT_INTEGER
)
609 return _("Integer expression required at %C");
611 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
612 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
614 return _("Integer value too large in expression at %C");
617 *result
= (int) mpz_get_si (expr
->value
.integer
);
623 /* Recursively copy a list of reference structures. */
626 gfc_copy_ref (gfc_ref
*src
)
634 dest
= gfc_get_ref ();
635 dest
->type
= src
->type
;
640 ar
= gfc_copy_array_ref (&src
->u
.ar
);
646 dest
->u
.c
= src
->u
.c
;
650 dest
->u
.ss
= src
->u
.ss
;
651 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
652 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
656 dest
->next
= gfc_copy_ref (src
->next
);
662 /* Detect whether an expression has any vector index array references. */
665 gfc_has_vector_index (gfc_expr
*e
)
669 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
670 if (ref
->type
== REF_ARRAY
)
671 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
672 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
678 /* Copy a shape array. */
681 gfc_copy_shape (mpz_t
*shape
, int rank
)
689 new_shape
= gfc_get_shape (rank
);
691 for (n
= 0; n
< rank
; n
++)
692 mpz_init_set (new_shape
[n
], shape
[n
]);
698 /* Copy a shape array excluding dimension N, where N is an integer
699 constant expression. Dimensions are numbered in fortran style --
702 So, if the original shape array contains R elements
703 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
704 the result contains R-1 elements:
705 { s1 ... sN-1 sN+1 ... sR-1}
707 If anything goes wrong -- N is not a constant, its value is out
708 of range -- or anything else, just returns NULL. */
711 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
713 mpz_t
*new_shape
, *s
;
719 || dim
->expr_type
!= EXPR_CONSTANT
720 || dim
->ts
.type
!= BT_INTEGER
)
723 n
= mpz_get_si (dim
->value
.integer
);
724 n
--; /* Convert to zero based index. */
725 if (n
< 0 || n
>= rank
)
728 s
= new_shape
= gfc_get_shape (rank
- 1);
730 for (i
= 0; i
< rank
; i
++)
734 mpz_init_set (*s
, shape
[i
]);
742 /* Return the maximum kind of two expressions. In general, higher
743 kind numbers mean more precision for numeric types. */
746 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
748 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
752 /* Returns nonzero if the type is numeric, zero otherwise. */
755 numeric_type (bt type
)
757 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
761 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
764 gfc_numeric_ts (gfc_typespec
*ts
)
766 return numeric_type (ts
->type
);
770 /* Return an expression node with an optional argument list attached.
771 A variable number of gfc_expr pointers are strung together in an
772 argument list with a NULL pointer terminating the list. */
775 gfc_build_conversion (gfc_expr
*e
)
780 p
->expr_type
= EXPR_FUNCTION
;
782 p
->value
.function
.actual
= NULL
;
784 p
->value
.function
.actual
= gfc_get_actual_arglist ();
785 p
->value
.function
.actual
->expr
= e
;
791 /* Given an expression node with some sort of numeric binary
792 expression, insert type conversions required to make the operands
793 have the same type. Conversion warnings are disabled if wconversion
796 The exception is that the operands of an exponential don't have to
797 have the same type. If possible, the base is promoted to the type
798 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
799 1.0**2 stays as it is. */
802 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
806 op1
= e
->value
.op
.op1
;
807 op2
= e
->value
.op
.op2
;
809 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
811 gfc_clear_ts (&e
->ts
);
815 /* Kind conversions of same type. */
816 if (op1
->ts
.type
== op2
->ts
.type
)
818 if (op1
->ts
.kind
== op2
->ts
.kind
)
820 /* No type conversions. */
825 if (op1
->ts
.kind
> op2
->ts
.kind
)
826 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
828 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
834 /* Integer combined with real or complex. */
835 if (op2
->ts
.type
== BT_INTEGER
)
839 /* Special case for ** operator. */
840 if (e
->value
.op
.op
== INTRINSIC_POWER
)
843 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
847 if (op1
->ts
.type
== BT_INTEGER
)
850 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
854 /* Real combined with complex. */
855 e
->ts
.type
= BT_COMPLEX
;
856 if (op1
->ts
.kind
> op2
->ts
.kind
)
857 e
->ts
.kind
= op1
->ts
.kind
;
859 e
->ts
.kind
= op2
->ts
.kind
;
860 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
861 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
862 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
863 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
870 /* Function to determine if an expression is constant or not. This
871 function expects that the expression has already been simplified. */
874 gfc_is_constant_expr (gfc_expr
*e
)
877 gfc_actual_arglist
*arg
;
883 switch (e
->expr_type
)
886 return (gfc_is_constant_expr (e
->value
.op
.op1
)
887 && (e
->value
.op
.op2
== NULL
888 || gfc_is_constant_expr (e
->value
.op
.op2
)));
896 /* Call to intrinsic with at least one argument. */
897 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
899 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
900 if (!gfc_is_constant_expr (arg
->expr
))
904 /* Make sure we have a symbol. */
905 gcc_assert (e
->symtree
);
907 sym
= e
->symtree
->n
.sym
;
909 /* Specification functions are constant. */
910 /* F95, 7.1.6.2; F2003, 7.1.7 */
912 && sym
->attr
.function
914 && !sym
->attr
.intrinsic
915 && !sym
->attr
.recursive
916 && sym
->attr
.proc
!= PROC_INTERNAL
917 && sym
->attr
.proc
!= PROC_ST_FUNCTION
918 && sym
->attr
.proc
!= PROC_UNKNOWN
919 && sym
->formal
== NULL
)
922 if (e
->value
.function
.isym
923 && (e
->value
.function
.isym
->elemental
924 || e
->value
.function
.isym
->pure
925 || e
->value
.function
.isym
->inquiry
926 || e
->value
.function
.isym
->transformational
))
936 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
937 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
941 c
= gfc_constructor_first (e
->value
.constructor
);
942 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
943 return gfc_constant_ac (e
);
945 for (; c
; c
= gfc_constructor_next (c
))
946 if (!gfc_is_constant_expr (c
->expr
))
953 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
959 /* Is true if an array reference is followed by a component or substring
962 is_subref_array (gfc_expr
* e
)
967 if (e
->expr_type
!= EXPR_VARIABLE
)
970 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
974 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
976 if (ref
->type
== REF_ARRAY
977 && ref
->u
.ar
.type
!= AR_ELEMENT
)
981 && ref
->type
!= REF_ARRAY
)
988 /* Try to collapse intrinsic expressions. */
991 simplify_intrinsic_op (gfc_expr
*p
, int type
)
994 gfc_expr
*op1
, *op2
, *result
;
996 if (p
->value
.op
.op
== INTRINSIC_USER
)
999 op1
= p
->value
.op
.op1
;
1000 op2
= p
->value
.op
.op2
;
1001 op
= p
->value
.op
.op
;
1003 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1005 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1008 if (!gfc_is_constant_expr (op1
)
1009 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1013 p
->value
.op
.op1
= NULL
;
1014 p
->value
.op
.op2
= NULL
;
1018 case INTRINSIC_PARENTHESES
:
1019 result
= gfc_parentheses (op1
);
1022 case INTRINSIC_UPLUS
:
1023 result
= gfc_uplus (op1
);
1026 case INTRINSIC_UMINUS
:
1027 result
= gfc_uminus (op1
);
1030 case INTRINSIC_PLUS
:
1031 result
= gfc_add (op1
, op2
);
1034 case INTRINSIC_MINUS
:
1035 result
= gfc_subtract (op1
, op2
);
1038 case INTRINSIC_TIMES
:
1039 result
= gfc_multiply (op1
, op2
);
1042 case INTRINSIC_DIVIDE
:
1043 result
= gfc_divide (op1
, op2
);
1046 case INTRINSIC_POWER
:
1047 result
= gfc_power (op1
, op2
);
1050 case INTRINSIC_CONCAT
:
1051 result
= gfc_concat (op1
, op2
);
1055 case INTRINSIC_EQ_OS
:
1056 result
= gfc_eq (op1
, op2
, op
);
1060 case INTRINSIC_NE_OS
:
1061 result
= gfc_ne (op1
, op2
, op
);
1065 case INTRINSIC_GT_OS
:
1066 result
= gfc_gt (op1
, op2
, op
);
1070 case INTRINSIC_GE_OS
:
1071 result
= gfc_ge (op1
, op2
, op
);
1075 case INTRINSIC_LT_OS
:
1076 result
= gfc_lt (op1
, op2
, op
);
1080 case INTRINSIC_LE_OS
:
1081 result
= gfc_le (op1
, op2
, op
);
1085 result
= gfc_not (op1
);
1089 result
= gfc_and (op1
, op2
);
1093 result
= gfc_or (op1
, op2
);
1097 result
= gfc_eqv (op1
, op2
);
1100 case INTRINSIC_NEQV
:
1101 result
= gfc_neqv (op1
, op2
);
1105 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1110 gfc_free_expr (op1
);
1111 gfc_free_expr (op2
);
1115 result
->rank
= p
->rank
;
1116 result
->where
= p
->where
;
1117 gfc_replace_expr (p
, result
);
1123 /* Subroutine to simplify constructor expressions. Mutually recursive
1124 with gfc_simplify_expr(). */
1127 simplify_constructor (gfc_constructor_base base
, int type
)
1132 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1135 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1136 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1137 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1142 /* Try and simplify a copy. Replace the original if successful
1143 but keep going through the constructor at all costs. Not
1144 doing so can make a dog's dinner of complicated things. */
1145 p
= gfc_copy_expr (c
->expr
);
1147 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1153 gfc_replace_expr (c
->expr
, p
);
1161 /* Pull a single array element out of an array constructor. */
1164 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1165 gfc_constructor
**rval
)
1167 unsigned long nelemen
;
1173 gfc_constructor
*cons
;
1180 mpz_init_set_ui (offset
, 0);
1183 mpz_init_set_ui (span
, 1);
1184 for (i
= 0; i
< ar
->dimen
; i
++)
1186 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1187 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1194 e
= gfc_copy_expr (ar
->start
[i
]);
1195 if (e
->expr_type
!= EXPR_CONSTANT
)
1201 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1202 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1204 /* Check the bounds. */
1205 if ((ar
->as
->upper
[i
]
1206 && mpz_cmp (e
->value
.integer
,
1207 ar
->as
->upper
[i
]->value
.integer
) > 0)
1208 || (mpz_cmp (e
->value
.integer
,
1209 ar
->as
->lower
[i
]->value
.integer
) < 0))
1211 gfc_error ("Index in dimension %d is out of bounds "
1212 "at %L", i
+ 1, &ar
->c_where
[i
]);
1218 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1219 mpz_mul (delta
, delta
, span
);
1220 mpz_add (offset
, offset
, delta
);
1222 mpz_set_ui (tmp
, 1);
1223 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1224 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1225 mpz_mul (span
, span
, tmp
);
1228 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1229 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1250 /* Find a component of a structure constructor. */
1252 static gfc_constructor
*
1253 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1255 gfc_component
*comp
;
1256 gfc_component
*pick
;
1257 gfc_constructor
*c
= gfc_constructor_first (base
);
1259 comp
= ref
->u
.c
.sym
->components
;
1260 pick
= ref
->u
.c
.component
;
1261 while (comp
!= pick
)
1264 c
= gfc_constructor_next (c
);
1271 /* Replace an expression with the contents of a constructor, removing
1272 the subobject reference in the process. */
1275 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1285 e
= gfc_copy_expr (p
);
1286 e
->ref
= p
->ref
->next
;
1287 p
->ref
->next
= NULL
;
1288 gfc_replace_expr (p
, e
);
1292 /* Pull an array section out of an array constructor. */
1295 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1302 long unsigned one
= 1;
1304 mpz_t start
[GFC_MAX_DIMENSIONS
];
1305 mpz_t end
[GFC_MAX_DIMENSIONS
];
1306 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1307 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1308 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1313 gfc_constructor_base base
;
1314 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1324 base
= expr
->value
.constructor
;
1325 expr
->value
.constructor
= NULL
;
1327 rank
= ref
->u
.ar
.as
->rank
;
1329 if (expr
->shape
== NULL
)
1330 expr
->shape
= gfc_get_shape (rank
);
1332 mpz_init_set_ui (delta_mpz
, one
);
1333 mpz_init_set_ui (nelts
, one
);
1336 /* Do the initialization now, so that we can cleanup without
1337 keeping track of where we were. */
1338 for (d
= 0; d
< rank
; d
++)
1340 mpz_init (delta
[d
]);
1341 mpz_init (start
[d
]);
1344 mpz_init (stride
[d
]);
1348 /* Build the counters to clock through the array reference. */
1350 for (d
= 0; d
< rank
; d
++)
1352 /* Make this stretch of code easier on the eye! */
1353 begin
= ref
->u
.ar
.start
[d
];
1354 finish
= ref
->u
.ar
.end
[d
];
1355 step
= ref
->u
.ar
.stride
[d
];
1356 lower
= ref
->u
.ar
.as
->lower
[d
];
1357 upper
= ref
->u
.ar
.as
->upper
[d
];
1359 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1361 gfc_constructor
*ci
;
1364 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1370 gcc_assert (begin
->rank
== 1);
1371 /* Zero-sized arrays have no shape and no elements, stop early. */
1374 mpz_init_set_ui (nelts
, 0);
1378 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1379 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1380 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1381 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1384 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1386 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1387 || mpz_cmp (ci
->expr
->value
.integer
,
1388 lower
->value
.integer
) < 0)
1390 gfc_error ("index in dimension %d is out of bounds "
1391 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1399 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1400 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1401 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1407 /* Obtain the stride. */
1409 mpz_set (stride
[d
], step
->value
.integer
);
1411 mpz_set_ui (stride
[d
], one
);
1413 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1414 mpz_set_ui (stride
[d
], one
);
1416 /* Obtain the start value for the index. */
1418 mpz_set (start
[d
], begin
->value
.integer
);
1420 mpz_set (start
[d
], lower
->value
.integer
);
1422 mpz_set (ctr
[d
], start
[d
]);
1424 /* Obtain the end value for the index. */
1426 mpz_set (end
[d
], finish
->value
.integer
);
1428 mpz_set (end
[d
], upper
->value
.integer
);
1430 /* Separate 'if' because elements sometimes arrive with
1432 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1433 mpz_set (end
[d
], begin
->value
.integer
);
1435 /* Check the bounds. */
1436 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1437 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1438 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1439 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1441 gfc_error ("index in dimension %d is out of bounds "
1442 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1447 /* Calculate the number of elements and the shape. */
1448 mpz_set (tmp_mpz
, stride
[d
]);
1449 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1450 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1451 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1452 mpz_mul (nelts
, nelts
, tmp_mpz
);
1454 /* An element reference reduces the rank of the expression; don't
1455 add anything to the shape array. */
1456 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1457 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1460 /* Calculate the 'stride' (=delta) for conversion of the
1461 counter values into the index along the constructor. */
1462 mpz_set (delta
[d
], delta_mpz
);
1463 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1464 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1465 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1469 cons
= gfc_constructor_first (base
);
1471 /* Now clock through the array reference, calculating the index in
1472 the source constructor and transferring the elements to the new
1474 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1476 if (ref
->u
.ar
.offset
)
1477 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1479 mpz_init_set_ui (ptr
, 0);
1482 for (d
= 0; d
< rank
; d
++)
1484 mpz_set (tmp_mpz
, ctr
[d
]);
1485 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1486 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1487 mpz_add (ptr
, ptr
, tmp_mpz
);
1489 if (!incr_ctr
) continue;
1491 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1493 gcc_assert(vecsub
[d
]);
1495 if (!gfc_constructor_next (vecsub
[d
]))
1496 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1499 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1502 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1506 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1508 if (mpz_cmp_ui (stride
[d
], 0) > 0
1509 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1510 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1511 mpz_set (ctr
[d
], start
[d
]);
1517 limit
= mpz_get_ui (ptr
);
1518 if (limit
>= gfc_option
.flag_max_array_constructor
)
1520 gfc_error ("The number of elements in the array constructor "
1521 "at %L requires an increase of the allowed %d "
1522 "upper limit. See -fmax-array-constructor "
1523 "option", &expr
->where
,
1524 gfc_option
.flag_max_array_constructor
);
1528 cons
= gfc_constructor_lookup (base
, limit
);
1530 gfc_constructor_append_expr (&expr
->value
.constructor
,
1531 gfc_copy_expr (cons
->expr
), NULL
);
1538 mpz_clear (delta_mpz
);
1539 mpz_clear (tmp_mpz
);
1541 for (d
= 0; d
< rank
; d
++)
1543 mpz_clear (delta
[d
]);
1544 mpz_clear (start
[d
]);
1547 mpz_clear (stride
[d
]);
1549 gfc_constructor_free (base
);
1553 /* Pull a substring out of an expression. */
1556 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1563 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1564 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1567 *newp
= gfc_copy_expr (p
);
1568 free ((*newp
)->value
.character
.string
);
1570 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1571 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1572 length
= end
- start
+ 1;
1574 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1575 (*newp
)->value
.character
.length
= length
;
1576 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1577 length
* sizeof (gfc_char_t
));
1584 /* Simplify a subobject reference of a constructor. This occurs when
1585 parameter variable values are substituted. */
1588 simplify_const_ref (gfc_expr
*p
)
1590 gfc_constructor
*cons
, *c
;
1596 switch (p
->ref
->type
)
1599 switch (p
->ref
->u
.ar
.type
)
1602 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1603 will generate this. */
1604 if (p
->expr_type
!= EXPR_ARRAY
)
1606 remove_subobject_ref (p
, NULL
);
1609 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1616 remove_subobject_ref (p
, cons
);
1620 if (find_array_section (p
, p
->ref
) == FAILURE
)
1622 p
->ref
->u
.ar
.type
= AR_FULL
;
1627 if (p
->ref
->next
!= NULL
1628 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1630 for (c
= gfc_constructor_first (p
->value
.constructor
);
1631 c
; c
= gfc_constructor_next (c
))
1633 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1634 if (simplify_const_ref (c
->expr
) == FAILURE
)
1638 if (p
->ts
.type
== BT_DERIVED
1640 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1642 /* There may have been component references. */
1643 p
->ts
= c
->expr
->ts
;
1647 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1649 if (p
->ts
.type
== BT_CHARACTER
1650 && last_ref
->type
== REF_SUBSTRING
)
1652 /* If this is a CHARACTER array and we possibly took
1653 a substring out of it, update the type-spec's
1654 character length according to the first element
1655 (as all should have the same length). */
1657 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1659 const gfc_expr
* first
= c
->expr
;
1660 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1661 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1662 string_len
= first
->value
.character
.length
;
1668 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1671 gfc_free_expr (p
->ts
.u
.cl
->length
);
1674 = gfc_get_int_expr (gfc_default_integer_kind
,
1678 gfc_free_ref_list (p
->ref
);
1689 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1690 remove_subobject_ref (p
, cons
);
1694 if (find_substring_ref (p
, &newp
) == FAILURE
)
1697 gfc_replace_expr (p
, newp
);
1698 gfc_free_ref_list (p
->ref
);
1708 /* Simplify a chain of references. */
1711 simplify_ref_chain (gfc_ref
*ref
, int type
)
1715 for (; ref
; ref
= ref
->next
)
1720 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1722 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1724 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1726 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1732 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1734 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1746 /* Try to substitute the value of a parameter variable. */
1749 simplify_parameter_variable (gfc_expr
*p
, int type
)
1754 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1760 /* Do not copy subobject refs for constant. */
1761 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1762 e
->ref
= gfc_copy_ref (p
->ref
);
1763 t
= gfc_simplify_expr (e
, type
);
1765 /* Only use the simplification if it eliminated all subobject references. */
1766 if (t
== SUCCESS
&& !e
->ref
)
1767 gfc_replace_expr (p
, e
);
1774 /* Given an expression, simplify it by collapsing constant
1775 expressions. Most simplification takes place when the expression
1776 tree is being constructed. If an intrinsic function is simplified
1777 at some point, we get called again to collapse the result against
1780 We work by recursively simplifying expression nodes, simplifying
1781 intrinsic functions where possible, which can lead to further
1782 constant collapsing. If an operator has constant operand(s), we
1783 rip the expression apart, and rebuild it, hoping that it becomes
1786 The expression type is defined for:
1787 0 Basic expression parsing
1788 1 Simplifying array constructors -- will substitute
1790 Returns FAILURE on error, SUCCESS otherwise.
1791 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1794 gfc_simplify_expr (gfc_expr
*p
, int type
)
1796 gfc_actual_arglist
*ap
;
1801 switch (p
->expr_type
)
1808 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1809 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1812 if (p
->value
.function
.isym
!= NULL
1813 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1818 case EXPR_SUBSTRING
:
1819 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1822 if (gfc_is_constant_expr (p
))
1828 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1830 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1831 start
--; /* Convert from one-based to zero-based. */
1834 end
= p
->value
.character
.length
;
1835 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1836 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1838 s
= gfc_get_wide_string (end
- start
+ 2);
1839 memcpy (s
, p
->value
.character
.string
+ start
,
1840 (end
- start
) * sizeof (gfc_char_t
));
1841 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1842 free (p
->value
.character
.string
);
1843 p
->value
.character
.string
= s
;
1844 p
->value
.character
.length
= end
- start
;
1845 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1846 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1848 p
->value
.character
.length
);
1849 gfc_free_ref_list (p
->ref
);
1851 p
->expr_type
= EXPR_CONSTANT
;
1856 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1861 /* Only substitute array parameter variables if we are in an
1862 initialization expression, or we want a subsection. */
1863 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1864 && (gfc_init_expr_flag
|| p
->ref
1865 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1867 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1874 gfc_simplify_iterator_var (p
);
1877 /* Simplify subcomponent references. */
1878 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1883 case EXPR_STRUCTURE
:
1885 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1888 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1891 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1892 && p
->ref
->u
.ar
.type
== AR_FULL
)
1893 gfc_expand_constructor (p
, false);
1895 if (simplify_const_ref (p
) == FAILURE
)
1910 /* Returns the type of an expression with the exception that iterator
1911 variables are automatically integers no matter what else they may
1917 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1924 /* Check an intrinsic arithmetic operation to see if it is consistent
1925 with some type of expression. */
1927 static gfc_try
check_init_expr (gfc_expr
*);
1930 /* Scalarize an expression for an elemental intrinsic call. */
1933 scalarize_intrinsic_call (gfc_expr
*e
)
1935 gfc_actual_arglist
*a
, *b
;
1936 gfc_constructor_base ctor
;
1937 gfc_constructor
*args
[5];
1938 gfc_constructor
*ci
, *new_ctor
;
1939 gfc_expr
*expr
, *old
;
1940 int n
, i
, rank
[5], array_arg
;
1942 /* Find which, if any, arguments are arrays. Assume that the old
1943 expression carries the type information and that the first arg
1944 that is an array expression carries all the shape information.*/
1946 a
= e
->value
.function
.actual
;
1947 for (; a
; a
= a
->next
)
1950 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1953 expr
= gfc_copy_expr (a
->expr
);
1960 old
= gfc_copy_expr (e
);
1962 gfc_constructor_free (expr
->value
.constructor
);
1963 expr
->value
.constructor
= NULL
;
1965 expr
->where
= old
->where
;
1966 expr
->expr_type
= EXPR_ARRAY
;
1968 /* Copy the array argument constructors into an array, with nulls
1971 a
= old
->value
.function
.actual
;
1972 for (; a
; a
= a
->next
)
1974 /* Check that this is OK for an initialization expression. */
1975 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1979 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1981 rank
[n
] = a
->expr
->rank
;
1982 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1983 args
[n
] = gfc_constructor_first (ctor
);
1985 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1988 rank
[n
] = a
->expr
->rank
;
1991 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
1992 args
[n
] = gfc_constructor_first (ctor
);
2001 /* Using the array argument as the master, step through the array
2002 calling the function for each element and advancing the array
2003 constructors together. */
2004 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2006 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2007 gfc_copy_expr (old
), NULL
);
2009 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2011 b
= old
->value
.function
.actual
;
2012 for (i
= 0; i
< n
; i
++)
2015 new_ctor
->expr
->value
.function
.actual
2016 = a
= gfc_get_actual_arglist ();
2019 a
->next
= gfc_get_actual_arglist ();
2024 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2026 a
->expr
= gfc_copy_expr (b
->expr
);
2031 /* Simplify the function calls. If the simplification fails, the
2032 error will be flagged up down-stream or the library will deal
2034 gfc_simplify_expr (new_ctor
->expr
, 0);
2036 for (i
= 0; i
< n
; i
++)
2038 args
[i
] = gfc_constructor_next (args
[i
]);
2040 for (i
= 1; i
< n
; i
++)
2041 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2042 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2048 gfc_free_expr (old
);
2052 gfc_error_now ("elemental function arguments at %C are not compliant");
2055 gfc_free_expr (expr
);
2056 gfc_free_expr (old
);
2062 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2064 gfc_expr
*op1
= e
->value
.op
.op1
;
2065 gfc_expr
*op2
= e
->value
.op
.op2
;
2067 if ((*check_function
) (op1
) == FAILURE
)
2070 switch (e
->value
.op
.op
)
2072 case INTRINSIC_UPLUS
:
2073 case INTRINSIC_UMINUS
:
2074 if (!numeric_type (et0 (op1
)))
2079 case INTRINSIC_EQ_OS
:
2081 case INTRINSIC_NE_OS
:
2083 case INTRINSIC_GT_OS
:
2085 case INTRINSIC_GE_OS
:
2087 case INTRINSIC_LT_OS
:
2089 case INTRINSIC_LE_OS
:
2090 if ((*check_function
) (op2
) == FAILURE
)
2093 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2094 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2096 gfc_error ("Numeric or CHARACTER operands are required in "
2097 "expression at %L", &e
->where
);
2102 case INTRINSIC_PLUS
:
2103 case INTRINSIC_MINUS
:
2104 case INTRINSIC_TIMES
:
2105 case INTRINSIC_DIVIDE
:
2106 case INTRINSIC_POWER
:
2107 if ((*check_function
) (op2
) == FAILURE
)
2110 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2115 case INTRINSIC_CONCAT
:
2116 if ((*check_function
) (op2
) == FAILURE
)
2119 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2121 gfc_error ("Concatenation operator in expression at %L "
2122 "must have two CHARACTER operands", &op1
->where
);
2126 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2128 gfc_error ("Concat operator at %L must concatenate strings of the "
2129 "same kind", &e
->where
);
2136 if (et0 (op1
) != BT_LOGICAL
)
2138 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2139 "operand", &op1
->where
);
2148 case INTRINSIC_NEQV
:
2149 if ((*check_function
) (op2
) == FAILURE
)
2152 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2154 gfc_error ("LOGICAL operands are required in expression at %L",
2161 case INTRINSIC_PARENTHESES
:
2165 gfc_error ("Only intrinsic operators can be used in expression at %L",
2173 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2178 /* F2003, 7.1.7 (3): In init expression, allocatable components
2179 must not be data-initialized. */
2181 check_alloc_comp_init (gfc_expr
*e
)
2183 gfc_component
*comp
;
2184 gfc_constructor
*ctor
;
2186 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2187 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2189 for (comp
= e
->ts
.u
.derived
->components
,
2190 ctor
= gfc_constructor_first (e
->value
.constructor
);
2191 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2193 if (comp
->attr
.allocatable
2194 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2196 gfc_error("Invalid initialization expression for ALLOCATABLE "
2197 "component '%s' in structure constructor at %L",
2198 comp
->name
, &ctor
->expr
->where
);
2207 check_init_expr_arguments (gfc_expr
*e
)
2209 gfc_actual_arglist
*ap
;
2211 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2212 if (check_init_expr (ap
->expr
) == FAILURE
)
2218 static gfc_try
check_restricted (gfc_expr
*);
2220 /* F95, 7.1.6.1, Initialization expressions, (7)
2221 F2003, 7.1.7 Initialization expression, (8) */
2224 check_inquiry (gfc_expr
*e
, int not_restricted
)
2227 const char *const *functions
;
2229 static const char *const inquiry_func_f95
[] = {
2230 "lbound", "shape", "size", "ubound",
2231 "bit_size", "len", "kind",
2232 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2233 "precision", "radix", "range", "tiny",
2237 static const char *const inquiry_func_f2003
[] = {
2238 "lbound", "shape", "size", "ubound",
2239 "bit_size", "len", "kind",
2240 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2241 "precision", "radix", "range", "tiny",
2246 gfc_actual_arglist
*ap
;
2248 if (!e
->value
.function
.isym
2249 || !e
->value
.function
.isym
->inquiry
)
2252 /* An undeclared parameter will get us here (PR25018). */
2253 if (e
->symtree
== NULL
)
2256 name
= e
->symtree
->n
.sym
->name
;
2258 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2259 ? inquiry_func_f2003
: inquiry_func_f95
;
2261 for (i
= 0; functions
[i
]; i
++)
2262 if (strcmp (functions
[i
], name
) == 0)
2265 if (functions
[i
] == NULL
)
2268 /* At this point we have an inquiry function with a variable argument. The
2269 type of the variable might be undefined, but we need it now, because the
2270 arguments of these functions are not allowed to be undefined. */
2272 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2277 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2279 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2280 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2284 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2287 /* Assumed character length will not reduce to a constant expression
2288 with LEN, as required by the standard. */
2289 if (i
== 5 && not_restricted
2290 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2291 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2292 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2294 gfc_error ("Assumed or deferred character length variable '%s' "
2295 " in constant expression at %L",
2296 ap
->expr
->symtree
->n
.sym
->name
,
2300 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2303 if (not_restricted
== 0
2304 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2305 && check_restricted (ap
->expr
) == FAILURE
)
2308 if (not_restricted
== 0
2309 && ap
->expr
->expr_type
== EXPR_VARIABLE
2310 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2311 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2319 /* F95, 7.1.6.1, Initialization expressions, (5)
2320 F2003, 7.1.7 Initialization expression, (5) */
2323 check_transformational (gfc_expr
*e
)
2325 static const char * const trans_func_f95
[] = {
2326 "repeat", "reshape", "selected_int_kind",
2327 "selected_real_kind", "transfer", "trim", NULL
2330 static const char * const trans_func_f2003
[] = {
2331 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2332 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2333 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2334 "trim", "unpack", NULL
2339 const char *const *functions
;
2341 if (!e
->value
.function
.isym
2342 || !e
->value
.function
.isym
->transformational
)
2345 name
= e
->symtree
->n
.sym
->name
;
2347 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2348 ? trans_func_f2003
: trans_func_f95
;
2350 /* NULL() is dealt with below. */
2351 if (strcmp ("null", name
) == 0)
2354 for (i
= 0; functions
[i
]; i
++)
2355 if (strcmp (functions
[i
], name
) == 0)
2358 if (functions
[i
] == NULL
)
2360 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2361 "in an initialization expression", name
, &e
->where
);
2365 return check_init_expr_arguments (e
);
2369 /* F95, 7.1.6.1, Initialization expressions, (6)
2370 F2003, 7.1.7 Initialization expression, (6) */
2373 check_null (gfc_expr
*e
)
2375 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2378 return check_init_expr_arguments (e
);
2383 check_elemental (gfc_expr
*e
)
2385 if (!e
->value
.function
.isym
2386 || !e
->value
.function
.isym
->elemental
)
2389 if (e
->ts
.type
!= BT_INTEGER
2390 && e
->ts
.type
!= BT_CHARACTER
2391 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2392 "nonstandard initialization expression at %L",
2393 &e
->where
) == FAILURE
)
2396 return check_init_expr_arguments (e
);
2401 check_conversion (gfc_expr
*e
)
2403 if (!e
->value
.function
.isym
2404 || !e
->value
.function
.isym
->conversion
)
2407 return check_init_expr_arguments (e
);
2411 /* Verify that an expression is an initialization expression. A side
2412 effect is that the expression tree is reduced to a single constant
2413 node if all goes well. This would normally happen when the
2414 expression is constructed but function references are assumed to be
2415 intrinsics in the context of initialization expressions. If
2416 FAILURE is returned an error message has been generated. */
2419 check_init_expr (gfc_expr
*e
)
2427 switch (e
->expr_type
)
2430 t
= check_intrinsic_op (e
, check_init_expr
);
2432 t
= gfc_simplify_expr (e
, 0);
2440 gfc_intrinsic_sym
* isym
;
2443 sym
= e
->symtree
->n
.sym
;
2444 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2445 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2447 gfc_error ("Function '%s' in initialization expression at %L "
2448 "must be an intrinsic function",
2449 e
->symtree
->n
.sym
->name
, &e
->where
);
2453 if ((m
= check_conversion (e
)) == MATCH_NO
2454 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2455 && (m
= check_null (e
)) == MATCH_NO
2456 && (m
= check_transformational (e
)) == MATCH_NO
2457 && (m
= check_elemental (e
)) == MATCH_NO
)
2459 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2460 "in an initialization expression",
2461 e
->symtree
->n
.sym
->name
, &e
->where
);
2465 /* Try to scalarize an elemental intrinsic function that has an
2467 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2468 if (isym
&& isym
->elemental
2469 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2474 t
= gfc_simplify_expr (e
, 0);
2481 if (gfc_check_iter_variable (e
) == SUCCESS
)
2484 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2486 /* A PARAMETER shall not be used to define itself, i.e.
2487 REAL, PARAMETER :: x = transfer(0, x)
2489 if (!e
->symtree
->n
.sym
->value
)
2491 gfc_error("PARAMETER '%s' is used at %L before its definition "
2492 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2496 t
= simplify_parameter_variable (e
, 0);
2501 if (gfc_in_match_data ())
2506 if (e
->symtree
->n
.sym
->as
)
2508 switch (e
->symtree
->n
.sym
->as
->type
)
2510 case AS_ASSUMED_SIZE
:
2511 gfc_error ("Assumed size array '%s' at %L is not permitted "
2512 "in an initialization expression",
2513 e
->symtree
->n
.sym
->name
, &e
->where
);
2516 case AS_ASSUMED_SHAPE
:
2517 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2518 "in an initialization expression",
2519 e
->symtree
->n
.sym
->name
, &e
->where
);
2523 gfc_error ("Deferred array '%s' at %L is not permitted "
2524 "in an initialization expression",
2525 e
->symtree
->n
.sym
->name
, &e
->where
);
2529 gfc_error ("Array '%s' at %L is a variable, which does "
2530 "not reduce to a constant expression",
2531 e
->symtree
->n
.sym
->name
, &e
->where
);
2539 gfc_error ("Parameter '%s' at %L has not been declared or is "
2540 "a variable, which does not reduce to a constant "
2541 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2550 case EXPR_SUBSTRING
:
2551 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2555 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2557 t
= gfc_simplify_expr (e
, 0);
2561 case EXPR_STRUCTURE
:
2562 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2566 t
= check_alloc_comp_init (e
);
2570 t
= gfc_check_constructor (e
, check_init_expr
);
2577 t
= gfc_check_constructor (e
, check_init_expr
);
2581 t
= gfc_expand_constructor (e
, true);
2585 t
= gfc_check_constructor_type (e
);
2589 gfc_internal_error ("check_init_expr(): Unknown expression type");
2595 /* Reduces a general expression to an initialization expression (a constant).
2596 This used to be part of gfc_match_init_expr.
2597 Note that this function doesn't free the given expression on FAILURE. */
2600 gfc_reduce_init_expr (gfc_expr
*expr
)
2604 gfc_init_expr_flag
= true;
2605 t
= gfc_resolve_expr (expr
);
2607 t
= check_init_expr (expr
);
2608 gfc_init_expr_flag
= false;
2613 if (expr
->expr_type
== EXPR_ARRAY
)
2615 if (gfc_check_constructor_type (expr
) == FAILURE
)
2617 if (gfc_expand_constructor (expr
, true) == FAILURE
)
2625 /* Match an initialization expression. We work by first matching an
2626 expression, then reducing it to a constant. */
2629 gfc_match_init_expr (gfc_expr
**result
)
2637 gfc_init_expr_flag
= true;
2639 m
= gfc_match_expr (&expr
);
2642 gfc_init_expr_flag
= false;
2646 t
= gfc_reduce_init_expr (expr
);
2649 gfc_free_expr (expr
);
2650 gfc_init_expr_flag
= false;
2655 gfc_init_expr_flag
= false;
2661 /* Given an actual argument list, test to see that each argument is a
2662 restricted expression and optionally if the expression type is
2663 integer or character. */
2666 restricted_args (gfc_actual_arglist
*a
)
2668 for (; a
; a
= a
->next
)
2670 if (check_restricted (a
->expr
) == FAILURE
)
2678 /************* Restricted/specification expressions *************/
2681 /* Make sure a non-intrinsic function is a specification function. */
2684 external_spec_function (gfc_expr
*e
)
2688 f
= e
->value
.function
.esym
;
2690 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2692 gfc_error ("Specification function '%s' at %L cannot be a statement "
2693 "function", f
->name
, &e
->where
);
2697 if (f
->attr
.proc
== PROC_INTERNAL
)
2699 gfc_error ("Specification function '%s' at %L cannot be an internal "
2700 "function", f
->name
, &e
->where
);
2704 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2706 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2711 if (f
->attr
.recursive
)
2713 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2714 f
->name
, &e
->where
);
2718 return restricted_args (e
->value
.function
.actual
);
2722 /* Check to see that a function reference to an intrinsic is a
2723 restricted expression. */
2726 restricted_intrinsic (gfc_expr
*e
)
2728 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2729 if (check_inquiry (e
, 0) == MATCH_YES
)
2732 return restricted_args (e
->value
.function
.actual
);
2736 /* Check the expressions of an actual arglist. Used by check_restricted. */
2739 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2741 for (; arg
; arg
= arg
->next
)
2742 if (checker (arg
->expr
) == FAILURE
)
2749 /* Check the subscription expressions of a reference chain with a checking
2750 function; used by check_restricted. */
2753 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2763 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2765 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2767 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2769 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2775 /* Nothing needed, just proceed to next reference. */
2779 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2781 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2790 return check_references (ref
->next
, checker
);
2794 /* Verify that an expression is a restricted expression. Like its
2795 cousin check_init_expr(), an error message is generated if we
2799 check_restricted (gfc_expr
*e
)
2807 switch (e
->expr_type
)
2810 t
= check_intrinsic_op (e
, check_restricted
);
2812 t
= gfc_simplify_expr (e
, 0);
2817 if (e
->value
.function
.esym
)
2819 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2821 t
= external_spec_function (e
);
2825 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2828 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2831 t
= restricted_intrinsic (e
);
2836 sym
= e
->symtree
->n
.sym
;
2839 /* If a dummy argument appears in a context that is valid for a
2840 restricted expression in an elemental procedure, it will have
2841 already been simplified away once we get here. Therefore we
2842 don't need to jump through hoops to distinguish valid from
2844 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2845 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2847 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2848 sym
->name
, &e
->where
);
2852 if (sym
->attr
.optional
)
2854 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2855 sym
->name
, &e
->where
);
2859 if (sym
->attr
.intent
== INTENT_OUT
)
2861 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2862 sym
->name
, &e
->where
);
2866 /* Check reference chain if any. */
2867 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2870 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2871 processed in resolve.c(resolve_formal_arglist). This is done so
2872 that host associated dummy array indices are accepted (PR23446).
2873 This mechanism also does the same for the specification expressions
2874 of array-valued functions. */
2876 || sym
->attr
.in_common
2877 || sym
->attr
.use_assoc
2879 || sym
->attr
.implied_index
2880 || sym
->attr
.flavor
== FL_PARAMETER
2881 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2882 || (sym
->ns
&& gfc_current_ns
->parent
2883 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2884 || (sym
->ns
->proc_name
!= NULL
2885 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2886 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2892 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2893 sym
->name
, &e
->where
);
2894 /* Prevent a repetition of the error. */
2903 case EXPR_SUBSTRING
:
2904 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2908 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2910 t
= gfc_simplify_expr (e
, 0);
2914 case EXPR_STRUCTURE
:
2915 t
= gfc_check_constructor (e
, check_restricted
);
2919 t
= gfc_check_constructor (e
, check_restricted
);
2923 gfc_internal_error ("check_restricted(): Unknown expression type");
2930 /* Check to see that an expression is a specification expression. If
2931 we return FAILURE, an error has been generated. */
2934 gfc_specification_expr (gfc_expr
*e
)
2936 gfc_component
*comp
;
2941 if (e
->ts
.type
!= BT_INTEGER
)
2943 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2944 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2948 if (e
->expr_type
== EXPR_FUNCTION
2949 && !e
->value
.function
.isym
2950 && !e
->value
.function
.esym
2951 && !gfc_pure (e
->symtree
->n
.sym
)
2952 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2953 || !comp
->attr
.pure
))
2955 gfc_error ("Function '%s' at %L must be PURE",
2956 e
->symtree
->n
.sym
->name
, &e
->where
);
2957 /* Prevent repeat error messages. */
2958 e
->symtree
->n
.sym
->attr
.pure
= 1;
2964 gfc_error ("Expression at %L must be scalar", &e
->where
);
2968 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2971 return check_restricted (e
);
2975 /************** Expression conformance checks. *************/
2977 /* Given two expressions, make sure that the arrays are conformable. */
2980 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
2982 int op1_flag
, op2_flag
, d
;
2983 mpz_t op1_size
, op2_size
;
2989 if (op1
->rank
== 0 || op2
->rank
== 0)
2992 va_start (argp
, optype_msgid
);
2993 vsnprintf (buffer
, 240, optype_msgid
, argp
);
2996 if (op1
->rank
!= op2
->rank
)
2998 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
2999 op1
->rank
, op2
->rank
, &op1
->where
);
3005 for (d
= 0; d
< op1
->rank
; d
++)
3007 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3008 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3010 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3012 gfc_error ("Different shape for %s at %L on dimension %d "
3013 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3014 (int) mpz_get_si (op1_size
),
3015 (int) mpz_get_si (op2_size
));
3021 mpz_clear (op1_size
);
3023 mpz_clear (op2_size
);
3033 /* Given an assignable expression and an arbitrary expression, make
3034 sure that the assignment can take place. */
3037 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3043 sym
= lvalue
->symtree
->n
.sym
;
3045 /* See if this is the component or subcomponent of a pointer. */
3046 has_pointer
= sym
->attr
.pointer
;
3047 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3048 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3054 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3055 variable local to a function subprogram. Its existence begins when
3056 execution of the function is initiated and ends when execution of the
3057 function is terminated...
3058 Therefore, the left hand side is no longer a variable, when it is: */
3059 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3060 && !sym
->attr
.external
)
3065 /* (i) Use associated; */
3066 if (sym
->attr
.use_assoc
)
3069 /* (ii) The assignment is in the main program; or */
3070 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3073 /* (iii) A module or internal procedure... */
3074 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3075 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3076 && gfc_current_ns
->parent
3077 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3078 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3079 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3081 /* ... that is not a function... */
3082 if (!gfc_current_ns
->proc_name
->attr
.function
)
3085 /* ... or is not an entry and has a different name. */
3086 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3090 /* (iv) Host associated and not the function symbol or the
3091 parent result. This picks up sibling references, which
3092 cannot be entries. */
3093 if (!sym
->attr
.entry
3094 && sym
->ns
== gfc_current_ns
->parent
3095 && sym
!= gfc_current_ns
->proc_name
3096 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3101 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3106 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3108 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3109 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3113 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3115 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3120 if (rvalue
->expr_type
== EXPR_NULL
)
3122 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3123 && lvalue
->symtree
->n
.sym
->attr
.data
)
3127 gfc_error ("NULL appears on right-hand side in assignment at %L",
3133 /* This is possibly a typo: x = f() instead of x => f(). */
3134 if (gfc_option
.warn_surprising
3135 && rvalue
->expr_type
== EXPR_FUNCTION
3136 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3137 gfc_warning ("POINTER valued function appears on right-hand side of "
3138 "assignment at %L", &rvalue
->where
);
3140 /* Check size of array assignments. */
3141 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3142 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3145 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3146 && lvalue
->symtree
->n
.sym
->attr
.data
3147 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3148 "initialize non-integer variable '%s'",
3149 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3152 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3153 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3154 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3155 &rvalue
->where
) == FAILURE
)
3158 /* Handle the case of a BOZ literal on the RHS. */
3159 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3162 if (gfc_option
.warn_surprising
)
3163 gfc_warning ("BOZ literal at %L is bitwise transferred "
3164 "non-integer symbol '%s'", &rvalue
->where
,
3165 lvalue
->symtree
->n
.sym
->name
);
3166 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3168 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3170 if (rc
== ARITH_UNDERFLOW
)
3171 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3172 ". This check can be disabled with the option "
3173 "-fno-range-check", &rvalue
->where
);
3174 else if (rc
== ARITH_OVERFLOW
)
3175 gfc_error ("Arithmetic overflow 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_NAN
)
3179 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3180 ". This check can be disabled with the option "
3181 "-fno-range-check", &rvalue
->where
);
3186 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3189 /* Only DATA Statements come here. */
3192 /* Numeric can be converted to any other numeric. And Hollerith can be
3193 converted to any other type. */
3194 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3195 || rvalue
->ts
.type
== BT_HOLLERITH
)
3198 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3201 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3202 "conversion of %s to %s", &lvalue
->where
,
3203 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3208 /* Assignment is the only case where character variables of different
3209 kind values can be converted into one another. */
3210 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3212 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3213 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3218 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3222 /* Check that a pointer assignment is OK. We first check lvalue, and
3223 we only check rvalue if it's not an assignment to NULL() or a
3224 NULLIFY statement. */
3227 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3229 symbol_attribute attr
;
3231 bool is_pure
, is_implicit_pure
, rank_remap
;
3234 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3235 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3237 gfc_error ("Pointer assignment target is not a POINTER at %L",
3242 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3243 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3244 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3246 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3247 "l-value since it is a procedure",
3248 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3252 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3255 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3257 if (ref
->type
== REF_COMPONENT
)
3258 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3260 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3264 if (ref
->u
.ar
.type
== AR_FULL
)
3267 if (ref
->u
.ar
.type
!= AR_SECTION
)
3269 gfc_error ("Expected bounds specification for '%s' at %L",
3270 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3274 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3275 "specification for '%s' in pointer assignment "
3276 "at %L", lvalue
->symtree
->n
.sym
->name
,
3277 &lvalue
->where
) == FAILURE
)
3280 /* When bounds are given, all lbounds are necessary and either all
3281 or none of the upper bounds; no strides are allowed. If the
3282 upper bounds are present, we may do rank remapping. */
3283 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3285 if (!ref
->u
.ar
.start
[dim
])
3287 gfc_error ("Lower bound has to be present at %L",
3291 if (ref
->u
.ar
.stride
[dim
])
3293 gfc_error ("Stride must not be present at %L",
3299 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3302 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3303 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3305 gfc_error ("Either all or none of the upper bounds"
3306 " must be specified at %L", &lvalue
->where
);
3314 is_pure
= gfc_pure (NULL
);
3315 is_implicit_pure
= gfc_implicit_pure (NULL
);
3317 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3318 kind, etc for lvalue and rvalue must match, and rvalue must be a
3319 pure variable if we're in a pure function. */
3320 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3323 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3324 if (lvalue
->expr_type
== EXPR_VARIABLE
3325 && gfc_is_coindexed (lvalue
))
3328 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3329 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3331 gfc_error ("Pointer object at %L shall not have a coindex",
3337 /* Checks on rvalue for procedure pointer assignments. */
3342 gfc_component
*comp
;
3345 attr
= gfc_expr_attr (rvalue
);
3346 if (!((rvalue
->expr_type
== EXPR_NULL
)
3347 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3348 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3349 || (rvalue
->expr_type
== EXPR_VARIABLE
3350 && attr
.flavor
== FL_PROCEDURE
)))
3352 gfc_error ("Invalid procedure pointer assignment at %L",
3358 gfc_error ("Abstract interface '%s' is invalid "
3359 "in procedure pointer assignment at %L",
3360 rvalue
->symtree
->name
, &rvalue
->where
);
3363 /* Check for C727. */
3364 if (attr
.flavor
== FL_PROCEDURE
)
3366 if (attr
.proc
== PROC_ST_FUNCTION
)
3368 gfc_error ("Statement function '%s' is invalid "
3369 "in procedure pointer assignment at %L",
3370 rvalue
->symtree
->name
, &rvalue
->where
);
3373 if (attr
.proc
== PROC_INTERNAL
&&
3374 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3375 "invalid in procedure pointer assignment at %L",
3376 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3380 /* Ensure that the calling convention is the same. As other attributes
3381 such as DLLEXPORT may differ, one explicitly only tests for the
3382 calling conventions. */
3383 if (rvalue
->expr_type
== EXPR_VARIABLE
3384 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3385 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3387 symbol_attribute calls
;
3390 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3391 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3392 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3394 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3395 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3397 gfc_error ("Mismatch in the procedure pointer assignment "
3398 "at %L: mismatch in the calling convention",
3404 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3405 s1
= comp
->ts
.interface
;
3407 s1
= lvalue
->symtree
->n
.sym
;
3409 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3411 s2
= comp
->ts
.interface
;
3414 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3416 s2
= rvalue
->symtree
->n
.sym
->result
;
3417 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3421 s2
= rvalue
->symtree
->n
.sym
;
3422 name
= rvalue
->symtree
->n
.sym
->name
;
3425 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3428 gfc_error ("Interface mismatch in procedure pointer assignment "
3429 "at %L: %s", &rvalue
->where
, err
);
3436 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3438 gfc_error ("Different types in pointer assignment at %L; attempted "
3439 "assignment of %s to %s", &lvalue
->where
,
3440 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3444 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3446 gfc_error ("Different kind type parameters in pointer "
3447 "assignment at %L", &lvalue
->where
);
3451 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3453 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3457 if (lvalue
->ts
.type
== BT_CLASS
&& rvalue
->ts
.type
== BT_DERIVED
)
3458 /* Make sure the vtab is present. */
3459 gfc_find_derived_vtab (rvalue
->ts
.u
.derived
);
3461 /* Check rank remapping. */
3466 /* If this can be determined, check that the target must be at least as
3467 large as the pointer assigned to it is. */
3468 if (gfc_array_size (lvalue
, &lsize
) == SUCCESS
3469 && gfc_array_size (rvalue
, &rsize
) == SUCCESS
3470 && mpz_cmp (rsize
, lsize
) < 0)
3472 gfc_error ("Rank remapping target is smaller than size of the"
3473 " pointer (%ld < %ld) at %L",
3474 mpz_get_si (rsize
), mpz_get_si (lsize
),
3479 /* The target must be either rank one or it must be simply contiguous
3480 and F2008 must be allowed. */
3481 if (rvalue
->rank
!= 1)
3483 if (!gfc_is_simply_contiguous (rvalue
, true))
3485 gfc_error ("Rank remapping target must be rank 1 or"
3486 " simply contiguous at %L", &rvalue
->where
);
3489 if (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Rank remapping"
3490 " target is not rank 1 at %L", &rvalue
->where
)
3496 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3497 if (rvalue
->expr_type
== EXPR_NULL
)
3500 if (lvalue
->ts
.type
== BT_CHARACTER
)
3502 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3507 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3508 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3510 attr
= gfc_expr_attr (rvalue
);
3512 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3514 gfc_error ("Target expression in pointer assignment "
3515 "at %L must deliver a pointer result",
3520 if (!attr
.target
&& !attr
.pointer
)
3522 gfc_error ("Pointer assignment target is neither TARGET "
3523 "nor POINTER at %L", &rvalue
->where
);
3527 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3529 gfc_error ("Bad target in pointer assignment in PURE "
3530 "procedure at %L", &rvalue
->where
);
3533 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3534 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3537 if (gfc_has_vector_index (rvalue
))
3539 gfc_error ("Pointer assignment with vector subscript "
3540 "on rhs at %L", &rvalue
->where
);
3544 if (attr
.is_protected
&& attr
.use_assoc
3545 && !(attr
.pointer
|| attr
.proc_pointer
))
3547 gfc_error ("Pointer assignment target has PROTECTED "
3548 "attribute at %L", &rvalue
->where
);
3552 /* F2008, C725. For PURE also C1283. */
3553 if (rvalue
->expr_type
== EXPR_VARIABLE
3554 && gfc_is_coindexed (rvalue
))
3557 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3558 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3560 gfc_error ("Data target at %L shall not have a coindex",
3570 /* Relative of gfc_check_assign() except that the lvalue is a single
3571 symbol. Used for initialization assignments. */
3574 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3579 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3581 lvalue
.expr_type
= EXPR_VARIABLE
;
3582 lvalue
.ts
= sym
->ts
;
3584 lvalue
.rank
= sym
->as
->rank
;
3585 lvalue
.symtree
= XCNEW (gfc_symtree
);
3586 lvalue
.symtree
->n
.sym
= sym
;
3587 lvalue
.where
= sym
->declared_at
;
3589 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3590 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.class_pointer
3591 && rvalue
->expr_type
== EXPR_NULL
))
3592 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3594 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3596 free (lvalue
.symtree
);
3601 if (sym
->attr
.pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3603 /* F08:C461. Additional checks for pointer initialization. */
3604 symbol_attribute attr
;
3605 attr
= gfc_expr_attr (rvalue
);
3606 if (attr
.allocatable
)
3608 gfc_error ("Pointer initialization target at %C "
3609 "must not be ALLOCATABLE ");
3612 if (!attr
.target
|| attr
.pointer
)
3614 gfc_error ("Pointer initialization target at %C "
3615 "must have the TARGET attribute");
3620 gfc_error ("Pointer initialization target at %C "
3621 "must have the SAVE attribute");
3626 if (sym
->attr
.proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
3628 /* F08:C1220. Additional checks for procedure pointer initialization. */
3629 symbol_attribute attr
= gfc_expr_attr (rvalue
);
3630 if (attr
.proc_pointer
)
3632 gfc_error ("Procedure pointer initialization target at %L "
3633 "may not be a procedure pointer", &rvalue
->where
);
3642 /* Check for default initializer; sym->value is not enough
3643 as it is also set for EXPR_NULL of allocatables. */
3646 gfc_has_default_initializer (gfc_symbol
*der
)
3650 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
3651 for (c
= der
->components
; c
; c
= c
->next
)
3652 if (c
->ts
.type
== BT_DERIVED
)
3654 if (!c
->attr
.pointer
3655 && gfc_has_default_initializer (c
->ts
.u
.derived
))
3667 /* Get an expression for a default initializer. */
3670 gfc_default_initializer (gfc_typespec
*ts
)
3673 gfc_component
*comp
;
3675 /* See if we have a default initializer in this, but not in nested
3676 types (otherwise we could use gfc_has_default_initializer()). */
3677 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3678 if (comp
->initializer
|| comp
->attr
.allocatable
3679 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3685 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3686 &ts
->u
.derived
->declared_at
);
3689 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3691 gfc_constructor
*ctor
= gfc_constructor_get();
3693 if (comp
->initializer
)
3694 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3696 if (comp
->attr
.allocatable
3697 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
3699 ctor
->expr
= gfc_get_expr ();
3700 ctor
->expr
->expr_type
= EXPR_NULL
;
3701 ctor
->expr
->ts
= comp
->ts
;
3704 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3711 /* Given a symbol, create an expression node with that symbol as a
3712 variable. If the symbol is array valued, setup a reference of the
3716 gfc_get_variable_expr (gfc_symtree
*var
)
3720 e
= gfc_get_expr ();
3721 e
->expr_type
= EXPR_VARIABLE
;
3723 e
->ts
= var
->n
.sym
->ts
;
3725 if (var
->n
.sym
->as
!= NULL
)
3727 e
->rank
= var
->n
.sym
->as
->rank
;
3728 e
->ref
= gfc_get_ref ();
3729 e
->ref
->type
= REF_ARRAY
;
3730 e
->ref
->u
.ar
.type
= AR_FULL
;
3738 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
3741 lval
= gfc_get_expr ();
3742 lval
->expr_type
= EXPR_VARIABLE
;
3743 lval
->where
= sym
->declared_at
;
3745 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
3747 /* It will always be a full array. */
3748 lval
->rank
= sym
->as
? sym
->as
->rank
: 0;
3751 lval
->ref
= gfc_get_ref ();
3752 lval
->ref
->type
= REF_ARRAY
;
3753 lval
->ref
->u
.ar
.type
= AR_FULL
;
3754 lval
->ref
->u
.ar
.dimen
= lval
->rank
;
3755 lval
->ref
->u
.ar
.where
= sym
->declared_at
;
3756 lval
->ref
->u
.ar
.as
= sym
->as
;
3763 /* Returns the array_spec of a full array expression. A NULL is
3764 returned otherwise. */
3766 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3771 if (expr
->rank
== 0)
3774 /* Follow any component references. */
3775 if (expr
->expr_type
== EXPR_VARIABLE
3776 || expr
->expr_type
== EXPR_CONSTANT
)
3778 as
= expr
->symtree
->n
.sym
->as
;
3779 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3784 as
= ref
->u
.c
.component
->as
;
3792 switch (ref
->u
.ar
.type
)
3815 /* General expression traversal function. */
3818 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3819 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3824 gfc_actual_arglist
*args
;
3831 if ((*func
) (expr
, sym
, &f
))
3834 if (expr
->ts
.type
== BT_CHARACTER
3836 && expr
->ts
.u
.cl
->length
3837 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3838 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3841 switch (expr
->expr_type
)
3846 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3848 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3856 case EXPR_SUBSTRING
:
3859 case EXPR_STRUCTURE
:
3861 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3862 c
; c
= gfc_constructor_next (c
))
3864 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3868 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3870 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3872 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3874 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3881 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3883 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3899 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3901 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3903 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3905 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3911 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3913 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3918 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3919 && ref
->u
.c
.component
->ts
.u
.cl
3920 && ref
->u
.c
.component
->ts
.u
.cl
->length
3921 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
3923 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
3927 if (ref
->u
.c
.component
->as
)
3928 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
3929 + ref
->u
.c
.component
->as
->corank
; i
++)
3931 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3934 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3948 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3951 expr_set_symbols_referenced (gfc_expr
*expr
,
3952 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3953 int *f ATTRIBUTE_UNUSED
)
3955 if (expr
->expr_type
!= EXPR_VARIABLE
)
3957 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3962 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3964 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
3968 /* Determine if an expression is a procedure pointer component. If yes, the
3969 argument 'comp' will point to the component (provided that 'comp' was
3973 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
3978 if (!expr
|| !expr
->ref
)
3985 if (ref
->type
== REF_COMPONENT
)
3987 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
3989 *comp
= ref
->u
.c
.component
;
3996 /* Walk an expression tree and check each variable encountered for being typed.
3997 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3998 mode as is a basic arithmetic expression using those; this is for things in
4001 INTEGER :: arr(n), n
4002 INTEGER :: arr(n + 1), n
4004 The namespace is needed for IMPLICIT typing. */
4006 static gfc_namespace
* check_typed_ns
;
4009 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4010 int* f ATTRIBUTE_UNUSED
)
4014 if (e
->expr_type
!= EXPR_VARIABLE
)
4017 gcc_assert (e
->symtree
);
4018 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4021 return (t
== FAILURE
);
4025 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4029 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4033 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4034 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4036 if (e
->expr_type
== EXPR_OP
)
4038 gfc_try t
= SUCCESS
;
4040 gcc_assert (e
->value
.op
.op1
);
4041 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4043 if (t
== SUCCESS
&& e
->value
.op
.op2
)
4044 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4050 /* Otherwise, walk the expression and do it strictly. */
4051 check_typed_ns
= ns
;
4052 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4054 return error_found
? FAILURE
: SUCCESS
;
4057 /* Walk an expression tree and replace all symbols with a corresponding symbol
4058 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4059 statements. The boolean return value is required by gfc_traverse_expr. */
4062 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4064 if ((expr
->expr_type
== EXPR_VARIABLE
4065 || (expr
->expr_type
== EXPR_FUNCTION
4066 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4067 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
4070 gfc_namespace
*ns
= sym
->formal_ns
;
4071 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4072 the symtree rather than create a new one (and probably fail later). */
4073 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4074 expr
->symtree
->n
.sym
->name
);
4076 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4077 expr
->symtree
= stree
;
4083 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
4085 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
4088 /* The following is analogous to 'replace_symbol', and needed for copying
4089 interfaces for procedure pointer components. The argument 'sym' must formally
4090 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4091 However, it gets actually passed a gfc_component (i.e. the procedure pointer
4092 component in whose formal_ns the arguments have to be). */
4095 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
4097 gfc_component
*comp
;
4098 comp
= (gfc_component
*)sym
;
4099 if ((expr
->expr_type
== EXPR_VARIABLE
4100 || (expr
->expr_type
== EXPR_FUNCTION
4101 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4102 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4105 gfc_namespace
*ns
= comp
->formal_ns
;
4106 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4107 the symtree rather than create a new one (and probably fail later). */
4108 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4109 expr
->symtree
->n
.sym
->name
);
4111 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4112 expr
->symtree
= stree
;
4118 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4120 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4125 gfc_is_coindexed (gfc_expr
*e
)
4129 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4130 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4133 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4134 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
4143 gfc_get_corank (gfc_expr
*e
)
4147 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
4148 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4150 if (ref
->type
== REF_ARRAY
)
4151 corank
= ref
->u
.ar
.as
->corank
;
4152 gcc_assert (ref
->type
!= REF_SUBSTRING
);
4158 /* Check whether the expression has an ultimate allocatable component.
4159 Being itself allocatable does not count. */
4161 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4163 gfc_ref
*ref
, *last
= NULL
;
4165 if (e
->expr_type
!= EXPR_VARIABLE
)
4168 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4169 if (ref
->type
== REF_COMPONENT
)
4172 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4173 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
4174 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4175 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4179 if (e
->ts
.type
== BT_CLASS
)
4180 return CLASS_DATA (e
)->attr
.alloc_comp
;
4181 else if (e
->ts
.type
== BT_DERIVED
)
4182 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4188 /* Check whether the expression has an pointer component.
4189 Being itself a pointer does not count. */
4191 gfc_has_ultimate_pointer (gfc_expr
*e
)
4193 gfc_ref
*ref
, *last
= NULL
;
4195 if (e
->expr_type
!= EXPR_VARIABLE
)
4198 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4199 if (ref
->type
== REF_COMPONENT
)
4202 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4203 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
4204 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4205 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4209 if (e
->ts
.type
== BT_CLASS
)
4210 return CLASS_DATA (e
)->attr
.pointer_comp
;
4211 else if (e
->ts
.type
== BT_DERIVED
)
4212 return e
->ts
.u
.derived
->attr
.pointer_comp
;
4218 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4219 Note: A scalar is not regarded as "simply contiguous" by the standard.
4220 if bool is not strict, some futher checks are done - for instance,
4221 a "(::1)" is accepted. */
4224 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
)
4228 gfc_array_ref
*ar
= NULL
;
4229 gfc_ref
*ref
, *part_ref
= NULL
;
4231 if (expr
->expr_type
== EXPR_FUNCTION
)
4232 return expr
->value
.function
.esym
4233 ? expr
->value
.function
.esym
->result
->attr
.contiguous
: false;
4234 else if (expr
->expr_type
!= EXPR_VARIABLE
)
4237 if (expr
->rank
== 0)
4240 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4243 return false; /* Array shall be last part-ref. */
4245 if (ref
->type
== REF_COMPONENT
)
4247 else if (ref
->type
== REF_SUBSTRING
)
4249 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
4253 if ((part_ref
&& !part_ref
->u
.c
.component
->attr
.contiguous
4254 && part_ref
->u
.c
.component
->attr
.pointer
)
4255 || (!part_ref
&& !expr
->symtree
->n
.sym
->attr
.contiguous
4256 && (expr
->symtree
->n
.sym
->attr
.pointer
4257 || expr
->symtree
->n
.sym
->as
->type
== AS_ASSUMED_SHAPE
)))
4260 if (!ar
|| ar
->type
== AR_FULL
)
4263 gcc_assert (ar
->type
== AR_SECTION
);
4265 /* Check for simply contiguous array */
4267 for (i
= 0; i
< ar
->dimen
; i
++)
4269 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4272 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
4278 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
4281 /* If the previous section was not contiguous, that's an error,
4282 unless we have effective only one element and checking is not
4284 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
4285 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4286 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4287 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4288 ar
->end
[i
]->value
.integer
) != 0))
4291 /* Following the standard, "(::1)" or - if known at compile time -
4292 "(lbound:ubound)" are not simply contigous; if strict
4293 is false, they are regarded as simply contiguous. */
4294 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
4295 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
4296 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
4300 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
4301 || !ar
->as
->lower
[i
]
4302 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
4303 || mpz_cmp (ar
->start
[i
]->value
.integer
,
4304 ar
->as
->lower
[i
]->value
.integer
) != 0))
4308 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
4309 || !ar
->as
->upper
[i
]
4310 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
4311 || mpz_cmp (ar
->end
[i
]->value
.integer
,
4312 ar
->as
->upper
[i
]->value
.integer
) != 0))
4320 /* Build call to an intrinsic procedure. The number of arguments has to be
4321 passed (rather than ending the list with a NULL value) because we may
4322 want to add arguments but with a NULL-expression. */
4325 gfc_build_intrinsic_call (const char* name
, locus where
, unsigned numarg
, ...)
4328 gfc_actual_arglist
* atail
;
4329 gfc_intrinsic_sym
* isym
;
4333 isym
= gfc_find_function (name
);
4336 result
= gfc_get_expr ();
4337 result
->expr_type
= EXPR_FUNCTION
;
4338 result
->ts
= isym
->ts
;
4339 result
->where
= where
;
4340 result
->value
.function
.name
= name
;
4341 result
->value
.function
.isym
= isym
;
4343 va_start (ap
, numarg
);
4345 for (i
= 0; i
< numarg
; ++i
)
4349 atail
->next
= gfc_get_actual_arglist ();
4350 atail
= atail
->next
;
4353 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
4355 atail
->expr
= va_arg (ap
, gfc_expr
*);
4363 /* Check if an expression may appear in a variable definition context
4364 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
4365 This is called from the various places when resolving
4366 the pieces that make up such a context.
4368 Optionally, a possible error message can be suppressed if context is NULL
4369 and just the return status (SUCCESS / FAILURE) be requested. */
4372 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, const char* context
)
4376 bool check_intentin
;
4378 symbol_attribute attr
;
4381 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
4382 && e
->symtree
->n
.sym
->result
->attr
.pointer
)
4384 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
4387 gfc_error ("Fortran 2008: Pointer functions in variable definition"
4388 " context (%s) at %L", context
, &e
->where
);
4392 else if (e
->expr_type
!= EXPR_VARIABLE
)
4395 gfc_error ("Non-variable expression in variable definition context (%s)"
4396 " at %L", context
, &e
->where
);
4400 gcc_assert (e
->symtree
);
4401 sym
= e
->symtree
->n
.sym
;
4403 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
4406 gfc_error ("Named constant '%s' in variable definition context (%s)"
4407 " at %L", sym
->name
, context
, &e
->where
);
4410 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
4411 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
4412 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
4415 gfc_error ("'%s' in variable definition context (%s) at %L is not"
4416 " a variable", sym
->name
, context
, &e
->where
);
4420 /* Find out whether the expr is a pointer; this also means following
4421 component references to the last one. */
4422 attr
= gfc_expr_attr (e
);
4423 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
4424 if (pointer
&& !is_pointer
)
4427 gfc_error ("Non-POINTER in pointer association context (%s)"
4428 " at %L", context
, &e
->where
);
4432 /* INTENT(IN) dummy argument. Check this, unless the object itself is
4433 the component of sub-component of a pointer. Obviously,
4434 procedure pointers are of no interest here. */
4435 check_intentin
= true;
4436 ptr_component
= sym
->attr
.pointer
;
4437 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
4439 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
4440 check_intentin
= false;
4441 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
4442 ptr_component
= true;
4444 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
4446 if (pointer
&& is_pointer
)
4449 gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
4450 " association context (%s) at %L",
4451 sym
->name
, context
, &e
->where
);
4454 if (!pointer
&& !is_pointer
)
4457 gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
4458 " definition context (%s) at %L",
4459 sym
->name
, context
, &e
->where
);
4464 /* PROTECTED and use-associated. */
4465 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
4467 if (pointer
&& is_pointer
)
4470 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4471 " pointer association context (%s) at %L",
4472 sym
->name
, context
, &e
->where
);
4475 if (!pointer
&& !is_pointer
)
4478 gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
4479 " variable definition context (%s) at %L",
4480 sym
->name
, context
, &e
->where
);
4485 /* Variable not assignable from a PURE procedure but appears in
4486 variable definition context. */
4487 if (!pointer
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
4490 gfc_error ("Variable '%s' can not appear in a variable definition"
4491 " context (%s) at %L in PURE procedure",
4492 sym
->name
, context
, &e
->where
);
4496 if (!pointer
&& gfc_implicit_pure (NULL
) && gfc_impure_variable (sym
))
4497 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
4499 /* Check variable definition context for associate-names. */
4500 if (!pointer
&& sym
->assoc
)
4503 gfc_association_list
* assoc
;
4505 gcc_assert (sym
->assoc
->target
);
4507 /* If this is a SELECT TYPE temporary (the association is used internally
4508 for SELECT TYPE), silently go over to the target. */
4509 if (sym
->attr
.select_type_temporary
)
4511 gfc_expr
* t
= sym
->assoc
->target
;
4513 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
4514 name
= t
->symtree
->name
;
4516 if (t
->symtree
->n
.sym
->assoc
)
4517 assoc
= t
->symtree
->n
.sym
->assoc
;
4526 gcc_assert (name
&& assoc
);
4528 /* Is association to a valid variable? */
4529 if (!assoc
->variable
)
4533 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
4534 gfc_error ("'%s' at %L associated to vector-indexed target can"
4535 " not be used in a variable definition context (%s)",
4536 name
, &e
->where
, context
);
4538 gfc_error ("'%s' at %L associated to expression can"
4539 " not be used in a variable definition context (%s)",
4540 name
, &e
->where
, context
);
4545 /* Target must be allowed to appear in a variable definition context. */
4546 if (gfc_check_vardef_context (assoc
->target
, pointer
, NULL
) == FAILURE
)
4549 gfc_error ("Associate-name '%s' can not appear in a variable"
4550 " definition context (%s) at %L because its target"
4551 " at %L can not, either",
4552 name
, context
, &e
->where
,
4553 &assoc
->target
->where
);