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_init_set_si (p
->value
.integer
, value
);
224 /* Get a new expression node that is a logical constant. */
227 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
230 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
231 where
? where
: &gfc_current_locus
);
233 p
->value
.logical
= value
;
240 gfc_get_iokind_expr (locus
*where
, io_kind k
)
244 /* Set the types to something compatible with iokind. This is needed to
245 get through gfc_free_expr later since iokind really has no Basic Type,
249 e
->expr_type
= EXPR_CONSTANT
;
250 e
->ts
.type
= BT_LOGICAL
;
258 /* Given an expression pointer, return a copy of the expression. This
259 subroutine is recursive. */
262 gfc_copy_expr (gfc_expr
*p
)
274 switch (q
->expr_type
)
277 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
278 q
->value
.character
.string
= s
;
279 memcpy (s
, p
->value
.character
.string
,
280 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
284 /* Copy target representation, if it exists. */
285 if (p
->representation
.string
)
287 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
288 q
->representation
.string
= c
;
289 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
292 /* Copy the values of any pointer components of p->value. */
296 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
300 gfc_set_model_kind (q
->ts
.kind
);
301 mpfr_init (q
->value
.real
);
302 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
306 gfc_set_model_kind (q
->ts
.kind
);
307 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
308 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
312 if (p
->representation
.string
)
313 q
->value
.character
.string
314 = gfc_char_to_widechar (q
->representation
.string
);
317 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
318 q
->value
.character
.string
= s
;
320 /* This is the case for the C_NULL_CHAR named constant. */
321 if (p
->value
.character
.length
== 0
322 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
325 /* Need to set the length to 1 to make sure the NUL
326 terminator is copied. */
327 q
->value
.character
.length
= 1;
330 memcpy (s
, p
->value
.character
.string
,
331 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
339 break; /* Already done. */
343 /* Should never be reached. */
345 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
352 switch (q
->value
.op
.op
)
355 case INTRINSIC_PARENTHESES
:
356 case INTRINSIC_UPLUS
:
357 case INTRINSIC_UMINUS
:
358 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
361 default: /* Binary operators. */
362 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
363 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
370 q
->value
.function
.actual
=
371 gfc_copy_actual_arglist (p
->value
.function
.actual
);
376 q
->value
.compcall
.actual
=
377 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
378 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
383 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
391 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
393 q
->ref
= gfc_copy_ref (p
->ref
);
399 /* Workhorse function for gfc_free_expr() that frees everything
400 beneath an expression node, but not the node itself. This is
401 useful when we want to simplify a node and replace it with
402 something else or the expression node belongs to another structure. */
405 free_expr0 (gfc_expr
*e
)
409 switch (e
->expr_type
)
412 /* Free any parts of the value that need freeing. */
416 mpz_clear (e
->value
.integer
);
420 mpfr_clear (e
->value
.real
);
424 gfc_free (e
->value
.character
.string
);
428 mpc_clear (e
->value
.complex);
435 /* Free the representation. */
436 if (e
->representation
.string
)
437 gfc_free (e
->representation
.string
);
442 if (e
->value
.op
.op1
!= NULL
)
443 gfc_free_expr (e
->value
.op
.op1
);
444 if (e
->value
.op
.op2
!= NULL
)
445 gfc_free_expr (e
->value
.op
.op2
);
449 gfc_free_actual_arglist (e
->value
.function
.actual
);
454 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
462 gfc_constructor_free (e
->value
.constructor
);
466 gfc_free (e
->value
.character
.string
);
473 gfc_internal_error ("free_expr0(): Bad expr type");
476 /* Free a shape array. */
477 if (e
->shape
!= NULL
)
479 for (n
= 0; n
< e
->rank
; n
++)
480 mpz_clear (e
->shape
[n
]);
485 gfc_free_ref_list (e
->ref
);
487 memset (e
, '\0', sizeof (gfc_expr
));
491 /* Free an expression node and everything beneath it. */
494 gfc_free_expr (gfc_expr
*e
)
503 /* Free an argument list and everything below it. */
506 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
508 gfc_actual_arglist
*a2
;
513 gfc_free_expr (a1
->expr
);
520 /* Copy an arglist structure and all of the arguments. */
523 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
525 gfc_actual_arglist
*head
, *tail
, *new_arg
;
529 for (; p
; p
= p
->next
)
531 new_arg
= gfc_get_actual_arglist ();
534 new_arg
->expr
= gfc_copy_expr (p
->expr
);
535 new_arg
->next
= NULL
;
540 tail
->next
= new_arg
;
549 /* Free a list of reference structures. */
552 gfc_free_ref_list (gfc_ref
*p
)
564 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
566 gfc_free_expr (p
->u
.ar
.start
[i
]);
567 gfc_free_expr (p
->u
.ar
.end
[i
]);
568 gfc_free_expr (p
->u
.ar
.stride
[i
]);
574 gfc_free_expr (p
->u
.ss
.start
);
575 gfc_free_expr (p
->u
.ss
.end
);
587 /* Graft the *src expression onto the *dest subexpression. */
590 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
598 /* Try to extract an integer constant from the passed expression node.
599 Returns an error message or NULL if the result is set. It is
600 tempting to generate an error and return SUCCESS or FAILURE, but
601 failure is OK for some callers. */
604 gfc_extract_int (gfc_expr
*expr
, int *result
)
606 if (expr
->expr_type
!= EXPR_CONSTANT
)
607 return _("Constant expression required at %C");
609 if (expr
->ts
.type
!= BT_INTEGER
)
610 return _("Integer expression required at %C");
612 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
613 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
615 return _("Integer value too large in expression at %C");
618 *result
= (int) mpz_get_si (expr
->value
.integer
);
624 /* Recursively copy a list of reference structures. */
627 gfc_copy_ref (gfc_ref
*src
)
635 dest
= gfc_get_ref ();
636 dest
->type
= src
->type
;
641 ar
= gfc_copy_array_ref (&src
->u
.ar
);
647 dest
->u
.c
= src
->u
.c
;
651 dest
->u
.ss
= src
->u
.ss
;
652 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
653 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
657 dest
->next
= gfc_copy_ref (src
->next
);
663 /* Detect whether an expression has any vector index array references. */
666 gfc_has_vector_index (gfc_expr
*e
)
670 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
671 if (ref
->type
== REF_ARRAY
)
672 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
673 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
679 /* Insert a reference to the component of the given name.
680 Only to be used with CLASS containers. */
683 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
685 gfc_ref
**tail
= &(e
->ref
);
686 gfc_ref
*next
= NULL
;
687 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
688 while (*tail
!= NULL
)
690 if ((*tail
)->type
== REF_COMPONENT
)
691 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
692 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
694 tail
= &((*tail
)->next
);
696 if (*tail
!= NULL
&& strcmp (name
, "$data") == 0)
698 (*tail
) = gfc_get_ref();
699 (*tail
)->next
= next
;
700 (*tail
)->type
= REF_COMPONENT
;
701 (*tail
)->u
.c
.sym
= derived
;
702 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
703 gcc_assert((*tail
)->u
.c
.component
);
705 e
->ts
= (*tail
)->u
.c
.component
->ts
;
709 /* Copy a shape array. */
712 gfc_copy_shape (mpz_t
*shape
, int rank
)
720 new_shape
= gfc_get_shape (rank
);
722 for (n
= 0; n
< rank
; n
++)
723 mpz_init_set (new_shape
[n
], shape
[n
]);
729 /* Copy a shape array excluding dimension N, where N is an integer
730 constant expression. Dimensions are numbered in fortran style --
733 So, if the original shape array contains R elements
734 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
735 the result contains R-1 elements:
736 { s1 ... sN-1 sN+1 ... sR-1}
738 If anything goes wrong -- N is not a constant, its value is out
739 of range -- or anything else, just returns NULL. */
742 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
744 mpz_t
*new_shape
, *s
;
750 || dim
->expr_type
!= EXPR_CONSTANT
751 || dim
->ts
.type
!= BT_INTEGER
)
754 n
= mpz_get_si (dim
->value
.integer
);
755 n
--; /* Convert to zero based index. */
756 if (n
< 0 || n
>= rank
)
759 s
= new_shape
= gfc_get_shape (rank
- 1);
761 for (i
= 0; i
< rank
; i
++)
765 mpz_init_set (*s
, shape
[i
]);
773 /* Return the maximum kind of two expressions. In general, higher
774 kind numbers mean more precision for numeric types. */
777 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
779 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
783 /* Returns nonzero if the type is numeric, zero otherwise. */
786 numeric_type (bt type
)
788 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
792 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
795 gfc_numeric_ts (gfc_typespec
*ts
)
797 return numeric_type (ts
->type
);
801 /* Return an expression node with an optional argument list attached.
802 A variable number of gfc_expr pointers are strung together in an
803 argument list with a NULL pointer terminating the list. */
806 gfc_build_conversion (gfc_expr
*e
)
811 p
->expr_type
= EXPR_FUNCTION
;
813 p
->value
.function
.actual
= NULL
;
815 p
->value
.function
.actual
= gfc_get_actual_arglist ();
816 p
->value
.function
.actual
->expr
= e
;
822 /* Given an expression node with some sort of numeric binary
823 expression, insert type conversions required to make the operands
824 have the same type. Conversion warnings are disabled if wconversion
827 The exception is that the operands of an exponential don't have to
828 have the same type. If possible, the base is promoted to the type
829 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
830 1.0**2 stays as it is. */
833 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
837 op1
= e
->value
.op
.op1
;
838 op2
= e
->value
.op
.op2
;
840 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
842 gfc_clear_ts (&e
->ts
);
846 /* Kind conversions of same type. */
847 if (op1
->ts
.type
== op2
->ts
.type
)
849 if (op1
->ts
.kind
== op2
->ts
.kind
)
851 /* No type conversions. */
856 if (op1
->ts
.kind
> op2
->ts
.kind
)
857 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
859 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
865 /* Integer combined with real or complex. */
866 if (op2
->ts
.type
== BT_INTEGER
)
870 /* Special case for ** operator. */
871 if (e
->value
.op
.op
== INTRINSIC_POWER
)
874 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
878 if (op1
->ts
.type
== BT_INTEGER
)
881 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
885 /* Real combined with complex. */
886 e
->ts
.type
= BT_COMPLEX
;
887 if (op1
->ts
.kind
> op2
->ts
.kind
)
888 e
->ts
.kind
= op1
->ts
.kind
;
890 e
->ts
.kind
= op2
->ts
.kind
;
891 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
892 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
893 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
894 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
902 check_specification_function (gfc_expr
*e
)
909 sym
= e
->symtree
->n
.sym
;
911 /* F95, 7.1.6.2; F2003, 7.1.7 */
913 && sym
->attr
.function
915 && !sym
->attr
.intrinsic
916 && !sym
->attr
.recursive
917 && sym
->attr
.proc
!= PROC_INTERNAL
918 && sym
->attr
.proc
!= PROC_ST_FUNCTION
919 && sym
->attr
.proc
!= PROC_UNKNOWN
920 && sym
->formal
== NULL
)
926 /* Function to determine if an expression is constant or not. This
927 function expects that the expression has already been simplified. */
930 gfc_is_constant_expr (gfc_expr
*e
)
933 gfc_actual_arglist
*arg
;
938 switch (e
->expr_type
)
941 return (gfc_is_constant_expr (e
->value
.op
.op1
)
942 && (e
->value
.op
.op2
== NULL
943 || gfc_is_constant_expr (e
->value
.op
.op2
)));
951 /* Specification functions are constant. */
952 if (check_specification_function (e
) == MATCH_YES
)
955 /* Call to intrinsic with at least one argument. */
956 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
958 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
959 if (!gfc_is_constant_expr (arg
->expr
))
972 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
973 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
976 for (c
= gfc_constructor_first (e
->value
.constructor
);
977 c
; c
= gfc_constructor_next (c
))
978 if (!gfc_is_constant_expr (c
->expr
))
984 return gfc_constant_ac (e
);
987 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
993 /* Is true if an array reference is followed by a component or substring
996 is_subref_array (gfc_expr
* e
)
1001 if (e
->expr_type
!= EXPR_VARIABLE
)
1004 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
1008 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1010 if (ref
->type
== REF_ARRAY
1011 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1015 && ref
->type
!= REF_ARRAY
)
1022 /* Try to collapse intrinsic expressions. */
1025 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1027 gfc_intrinsic_op op
;
1028 gfc_expr
*op1
, *op2
, *result
;
1030 if (p
->value
.op
.op
== INTRINSIC_USER
)
1033 op1
= p
->value
.op
.op1
;
1034 op2
= p
->value
.op
.op2
;
1035 op
= p
->value
.op
.op
;
1037 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
1039 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
1042 if (!gfc_is_constant_expr (op1
)
1043 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1047 p
->value
.op
.op1
= NULL
;
1048 p
->value
.op
.op2
= NULL
;
1052 case INTRINSIC_PARENTHESES
:
1053 result
= gfc_parentheses (op1
);
1056 case INTRINSIC_UPLUS
:
1057 result
= gfc_uplus (op1
);
1060 case INTRINSIC_UMINUS
:
1061 result
= gfc_uminus (op1
);
1064 case INTRINSIC_PLUS
:
1065 result
= gfc_add (op1
, op2
);
1068 case INTRINSIC_MINUS
:
1069 result
= gfc_subtract (op1
, op2
);
1072 case INTRINSIC_TIMES
:
1073 result
= gfc_multiply (op1
, op2
);
1076 case INTRINSIC_DIVIDE
:
1077 result
= gfc_divide (op1
, op2
);
1080 case INTRINSIC_POWER
:
1081 result
= gfc_power (op1
, op2
);
1084 case INTRINSIC_CONCAT
:
1085 result
= gfc_concat (op1
, op2
);
1089 case INTRINSIC_EQ_OS
:
1090 result
= gfc_eq (op1
, op2
, op
);
1094 case INTRINSIC_NE_OS
:
1095 result
= gfc_ne (op1
, op2
, op
);
1099 case INTRINSIC_GT_OS
:
1100 result
= gfc_gt (op1
, op2
, op
);
1104 case INTRINSIC_GE_OS
:
1105 result
= gfc_ge (op1
, op2
, op
);
1109 case INTRINSIC_LT_OS
:
1110 result
= gfc_lt (op1
, op2
, op
);
1114 case INTRINSIC_LE_OS
:
1115 result
= gfc_le (op1
, op2
, op
);
1119 result
= gfc_not (op1
);
1123 result
= gfc_and (op1
, op2
);
1127 result
= gfc_or (op1
, op2
);
1131 result
= gfc_eqv (op1
, op2
);
1134 case INTRINSIC_NEQV
:
1135 result
= gfc_neqv (op1
, op2
);
1139 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1144 gfc_free_expr (op1
);
1145 gfc_free_expr (op2
);
1149 result
->rank
= p
->rank
;
1150 result
->where
= p
->where
;
1151 gfc_replace_expr (p
, result
);
1157 /* Subroutine to simplify constructor expressions. Mutually recursive
1158 with gfc_simplify_expr(). */
1161 simplify_constructor (gfc_constructor_base base
, int type
)
1166 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1169 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1170 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1171 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1176 /* Try and simplify a copy. Replace the original if successful
1177 but keep going through the constructor at all costs. Not
1178 doing so can make a dog's dinner of complicated things. */
1179 p
= gfc_copy_expr (c
->expr
);
1181 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1187 gfc_replace_expr (c
->expr
, p
);
1195 /* Pull a single array element out of an array constructor. */
1198 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1199 gfc_constructor
**rval
)
1201 unsigned long nelemen
;
1207 gfc_constructor
*cons
;
1214 mpz_init_set_ui (offset
, 0);
1217 mpz_init_set_ui (span
, 1);
1218 for (i
= 0; i
< ar
->dimen
; i
++)
1220 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1221 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1228 e
= gfc_copy_expr (ar
->start
[i
]);
1229 if (e
->expr_type
!= EXPR_CONSTANT
)
1235 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1236 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1238 /* Check the bounds. */
1239 if ((ar
->as
->upper
[i
]
1240 && mpz_cmp (e
->value
.integer
,
1241 ar
->as
->upper
[i
]->value
.integer
) > 0)
1242 || (mpz_cmp (e
->value
.integer
,
1243 ar
->as
->lower
[i
]->value
.integer
) < 0))
1245 gfc_error ("Index in dimension %d is out of bounds "
1246 "at %L", i
+ 1, &ar
->c_where
[i
]);
1252 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1253 mpz_mul (delta
, delta
, span
);
1254 mpz_add (offset
, offset
, delta
);
1256 mpz_set_ui (tmp
, 1);
1257 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1258 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1259 mpz_mul (span
, span
, tmp
);
1262 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1263 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1284 /* Find a component of a structure constructor. */
1286 static gfc_constructor
*
1287 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1289 gfc_component
*comp
;
1290 gfc_component
*pick
;
1291 gfc_constructor
*c
= gfc_constructor_first (base
);
1293 comp
= ref
->u
.c
.sym
->components
;
1294 pick
= ref
->u
.c
.component
;
1295 while (comp
!= pick
)
1298 c
= gfc_constructor_next (c
);
1305 /* Replace an expression with the contents of a constructor, removing
1306 the subobject reference in the process. */
1309 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1319 e
= gfc_copy_expr (p
);
1320 e
->ref
= p
->ref
->next
;
1321 p
->ref
->next
= NULL
;
1322 gfc_replace_expr (p
, e
);
1326 /* Pull an array section out of an array constructor. */
1329 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1336 long unsigned one
= 1;
1338 mpz_t start
[GFC_MAX_DIMENSIONS
];
1339 mpz_t end
[GFC_MAX_DIMENSIONS
];
1340 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1341 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1342 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1347 gfc_constructor_base base
;
1348 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1358 base
= expr
->value
.constructor
;
1359 expr
->value
.constructor
= NULL
;
1361 rank
= ref
->u
.ar
.as
->rank
;
1363 if (expr
->shape
== NULL
)
1364 expr
->shape
= gfc_get_shape (rank
);
1366 mpz_init_set_ui (delta_mpz
, one
);
1367 mpz_init_set_ui (nelts
, one
);
1370 /* Do the initialization now, so that we can cleanup without
1371 keeping track of where we were. */
1372 for (d
= 0; d
< rank
; d
++)
1374 mpz_init (delta
[d
]);
1375 mpz_init (start
[d
]);
1378 mpz_init (stride
[d
]);
1382 /* Build the counters to clock through the array reference. */
1384 for (d
= 0; d
< rank
; d
++)
1386 /* Make this stretch of code easier on the eye! */
1387 begin
= ref
->u
.ar
.start
[d
];
1388 finish
= ref
->u
.ar
.end
[d
];
1389 step
= ref
->u
.ar
.stride
[d
];
1390 lower
= ref
->u
.ar
.as
->lower
[d
];
1391 upper
= ref
->u
.ar
.as
->upper
[d
];
1393 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1395 gfc_constructor
*ci
;
1398 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1404 gcc_assert (begin
->rank
== 1);
1405 /* Zero-sized arrays have no shape and no elements, stop early. */
1408 mpz_init_set_ui (nelts
, 0);
1412 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1413 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1414 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1415 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1418 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1420 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1421 || mpz_cmp (ci
->expr
->value
.integer
,
1422 lower
->value
.integer
) < 0)
1424 gfc_error ("index in dimension %d is out of bounds "
1425 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1433 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1434 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1435 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1441 /* Obtain the stride. */
1443 mpz_set (stride
[d
], step
->value
.integer
);
1445 mpz_set_ui (stride
[d
], one
);
1447 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1448 mpz_set_ui (stride
[d
], one
);
1450 /* Obtain the start value for the index. */
1452 mpz_set (start
[d
], begin
->value
.integer
);
1454 mpz_set (start
[d
], lower
->value
.integer
);
1456 mpz_set (ctr
[d
], start
[d
]);
1458 /* Obtain the end value for the index. */
1460 mpz_set (end
[d
], finish
->value
.integer
);
1462 mpz_set (end
[d
], upper
->value
.integer
);
1464 /* Separate 'if' because elements sometimes arrive with
1466 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1467 mpz_set (end
[d
], begin
->value
.integer
);
1469 /* Check the bounds. */
1470 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1471 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1472 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1473 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1475 gfc_error ("index in dimension %d is out of bounds "
1476 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1481 /* Calculate the number of elements and the shape. */
1482 mpz_set (tmp_mpz
, stride
[d
]);
1483 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1484 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1485 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1486 mpz_mul (nelts
, nelts
, tmp_mpz
);
1488 /* An element reference reduces the rank of the expression; don't
1489 add anything to the shape array. */
1490 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1491 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1494 /* Calculate the 'stride' (=delta) for conversion of the
1495 counter values into the index along the constructor. */
1496 mpz_set (delta
[d
], delta_mpz
);
1497 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1498 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1499 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1503 cons
= gfc_constructor_first (base
);
1505 /* Now clock through the array reference, calculating the index in
1506 the source constructor and transferring the elements to the new
1508 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1510 if (ref
->u
.ar
.offset
)
1511 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1513 mpz_init_set_ui (ptr
, 0);
1516 for (d
= 0; d
< rank
; d
++)
1518 mpz_set (tmp_mpz
, ctr
[d
]);
1519 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1520 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1521 mpz_add (ptr
, ptr
, tmp_mpz
);
1523 if (!incr_ctr
) continue;
1525 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1527 gcc_assert(vecsub
[d
]);
1529 if (!gfc_constructor_next (vecsub
[d
]))
1530 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1533 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1536 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1540 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1542 if (mpz_cmp_ui (stride
[d
], 0) > 0
1543 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1544 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1545 mpz_set (ctr
[d
], start
[d
]);
1551 limit
= mpz_get_ui (ptr
);
1552 if (limit
>= gfc_option
.flag_max_array_constructor
)
1554 gfc_error ("The number of elements in the array constructor "
1555 "at %L requires an increase of the allowed %d "
1556 "upper limit. See -fmax-array-constructor "
1557 "option", &expr
->where
,
1558 gfc_option
.flag_max_array_constructor
);
1562 cons
= gfc_constructor_lookup (base
, limit
);
1564 gfc_constructor_append_expr (&expr
->value
.constructor
,
1565 gfc_copy_expr (cons
->expr
), NULL
);
1572 mpz_clear (delta_mpz
);
1573 mpz_clear (tmp_mpz
);
1575 for (d
= 0; d
< rank
; d
++)
1577 mpz_clear (delta
[d
]);
1578 mpz_clear (start
[d
]);
1581 mpz_clear (stride
[d
]);
1583 gfc_constructor_free (base
);
1587 /* Pull a substring out of an expression. */
1590 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1597 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1598 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1601 *newp
= gfc_copy_expr (p
);
1602 gfc_free ((*newp
)->value
.character
.string
);
1604 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1605 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1606 length
= end
- start
+ 1;
1608 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1609 (*newp
)->value
.character
.length
= length
;
1610 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1611 length
* sizeof (gfc_char_t
));
1618 /* Simplify a subobject reference of a constructor. This occurs when
1619 parameter variable values are substituted. */
1622 simplify_const_ref (gfc_expr
*p
)
1624 gfc_constructor
*cons
, *c
;
1630 switch (p
->ref
->type
)
1633 switch (p
->ref
->u
.ar
.type
)
1636 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1637 will generate this. */
1638 if (p
->expr_type
!= EXPR_ARRAY
)
1640 remove_subobject_ref (p
, NULL
);
1643 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1650 remove_subobject_ref (p
, cons
);
1654 if (find_array_section (p
, p
->ref
) == FAILURE
)
1656 p
->ref
->u
.ar
.type
= AR_FULL
;
1661 if (p
->ref
->next
!= NULL
1662 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1664 for (c
= gfc_constructor_first (p
->value
.constructor
);
1665 c
; c
= gfc_constructor_next (c
))
1667 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1668 if (simplify_const_ref (c
->expr
) == FAILURE
)
1672 if (p
->ts
.type
== BT_DERIVED
1674 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1676 /* There may have been component references. */
1677 p
->ts
= c
->expr
->ts
;
1681 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1683 if (p
->ts
.type
== BT_CHARACTER
1684 && last_ref
->type
== REF_SUBSTRING
)
1686 /* If this is a CHARACTER array and we possibly took
1687 a substring out of it, update the type-spec's
1688 character length according to the first element
1689 (as all should have the same length). */
1691 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1693 const gfc_expr
* first
= c
->expr
;
1694 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1695 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1696 string_len
= first
->value
.character
.length
;
1702 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1705 gfc_free_expr (p
->ts
.u
.cl
->length
);
1708 = gfc_get_int_expr (gfc_default_integer_kind
,
1712 gfc_free_ref_list (p
->ref
);
1723 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1724 remove_subobject_ref (p
, cons
);
1728 if (find_substring_ref (p
, &newp
) == FAILURE
)
1731 gfc_replace_expr (p
, newp
);
1732 gfc_free_ref_list (p
->ref
);
1742 /* Simplify a chain of references. */
1745 simplify_ref_chain (gfc_ref
*ref
, int type
)
1749 for (; ref
; ref
= ref
->next
)
1754 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1756 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1758 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1760 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1766 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1768 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1780 /* Try to substitute the value of a parameter variable. */
1783 simplify_parameter_variable (gfc_expr
*p
, int type
)
1788 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1794 /* Do not copy subobject refs for constant. */
1795 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1796 e
->ref
= gfc_copy_ref (p
->ref
);
1797 t
= gfc_simplify_expr (e
, type
);
1799 /* Only use the simplification if it eliminated all subobject references. */
1800 if (t
== SUCCESS
&& !e
->ref
)
1801 gfc_replace_expr (p
, e
);
1808 /* Given an expression, simplify it by collapsing constant
1809 expressions. Most simplification takes place when the expression
1810 tree is being constructed. If an intrinsic function is simplified
1811 at some point, we get called again to collapse the result against
1814 We work by recursively simplifying expression nodes, simplifying
1815 intrinsic functions where possible, which can lead to further
1816 constant collapsing. If an operator has constant operand(s), we
1817 rip the expression apart, and rebuild it, hoping that it becomes
1820 The expression type is defined for:
1821 0 Basic expression parsing
1822 1 Simplifying array constructors -- will substitute
1824 Returns FAILURE on error, SUCCESS otherwise.
1825 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1828 gfc_simplify_expr (gfc_expr
*p
, int type
)
1830 gfc_actual_arglist
*ap
;
1835 switch (p
->expr_type
)
1842 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1843 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1846 if (p
->value
.function
.isym
!= NULL
1847 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1852 case EXPR_SUBSTRING
:
1853 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1856 if (gfc_is_constant_expr (p
))
1862 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1864 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1865 start
--; /* Convert from one-based to zero-based. */
1868 end
= p
->value
.character
.length
;
1869 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1870 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1872 s
= gfc_get_wide_string (end
- start
+ 2);
1873 memcpy (s
, p
->value
.character
.string
+ start
,
1874 (end
- start
) * sizeof (gfc_char_t
));
1875 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1876 gfc_free (p
->value
.character
.string
);
1877 p
->value
.character
.string
= s
;
1878 p
->value
.character
.length
= end
- start
;
1879 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1880 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
1882 p
->value
.character
.length
);
1883 gfc_free_ref_list (p
->ref
);
1885 p
->expr_type
= EXPR_CONSTANT
;
1890 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1895 /* Only substitute array parameter variables if we are in an
1896 initialization expression, or we want a subsection. */
1897 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1898 && (gfc_init_expr
|| p
->ref
1899 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1901 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1908 gfc_simplify_iterator_var (p
);
1911 /* Simplify subcomponent references. */
1912 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1917 case EXPR_STRUCTURE
:
1919 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1922 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1925 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1926 && p
->ref
->u
.ar
.type
== AR_FULL
)
1927 gfc_expand_constructor (p
);
1929 if (simplify_const_ref (p
) == FAILURE
)
1944 /* Returns the type of an expression with the exception that iterator
1945 variables are automatically integers no matter what else they may
1951 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1958 /* Check an intrinsic arithmetic operation to see if it is consistent
1959 with some type of expression. */
1961 static gfc_try
check_init_expr (gfc_expr
*);
1964 /* Scalarize an expression for an elemental intrinsic call. */
1967 scalarize_intrinsic_call (gfc_expr
*e
)
1969 gfc_actual_arglist
*a
, *b
;
1970 gfc_constructor_base ctor
;
1971 gfc_constructor
*args
[5];
1972 gfc_constructor
*ci
, *new_ctor
;
1973 gfc_expr
*expr
, *old
;
1974 int n
, i
, rank
[5], array_arg
;
1976 /* Find which, if any, arguments are arrays. Assume that the old
1977 expression carries the type information and that the first arg
1978 that is an array expression carries all the shape information.*/
1980 a
= e
->value
.function
.actual
;
1981 for (; a
; a
= a
->next
)
1984 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1987 expr
= gfc_copy_expr (a
->expr
);
1994 old
= gfc_copy_expr (e
);
1996 gfc_constructor_free (expr
->value
.constructor
);
1997 expr
->value
.constructor
= NULL
;
1999 expr
->where
= old
->where
;
2000 expr
->expr_type
= EXPR_ARRAY
;
2002 /* Copy the array argument constructors into an array, with nulls
2005 a
= old
->value
.function
.actual
;
2006 for (; a
; a
= a
->next
)
2008 /* Check that this is OK for an initialization expression. */
2009 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
2013 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2015 rank
[n
] = a
->expr
->rank
;
2016 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2017 args
[n
] = gfc_constructor_first (ctor
);
2019 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2022 rank
[n
] = a
->expr
->rank
;
2025 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2026 args
[n
] = gfc_constructor_first (ctor
);
2035 /* Using the array argument as the master, step through the array
2036 calling the function for each element and advancing the array
2037 constructors together. */
2038 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2040 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2041 gfc_copy_expr (old
), NULL
);
2043 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2045 b
= old
->value
.function
.actual
;
2046 for (i
= 0; i
< n
; i
++)
2049 new_ctor
->expr
->value
.function
.actual
2050 = a
= gfc_get_actual_arglist ();
2053 a
->next
= gfc_get_actual_arglist ();
2058 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2060 a
->expr
= gfc_copy_expr (b
->expr
);
2065 /* Simplify the function calls. If the simplification fails, the
2066 error will be flagged up down-stream or the library will deal
2068 gfc_simplify_expr (new_ctor
->expr
, 0);
2070 for (i
= 0; i
< n
; i
++)
2072 args
[i
] = gfc_constructor_next (args
[i
]);
2074 for (i
= 1; i
< n
; i
++)
2075 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2076 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2082 gfc_free_expr (old
);
2086 gfc_error_now ("elemental function arguments at %C are not compliant");
2089 gfc_free_expr (expr
);
2090 gfc_free_expr (old
);
2096 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
2098 gfc_expr
*op1
= e
->value
.op
.op1
;
2099 gfc_expr
*op2
= e
->value
.op
.op2
;
2101 if ((*check_function
) (op1
) == FAILURE
)
2104 switch (e
->value
.op
.op
)
2106 case INTRINSIC_UPLUS
:
2107 case INTRINSIC_UMINUS
:
2108 if (!numeric_type (et0 (op1
)))
2113 case INTRINSIC_EQ_OS
:
2115 case INTRINSIC_NE_OS
:
2117 case INTRINSIC_GT_OS
:
2119 case INTRINSIC_GE_OS
:
2121 case INTRINSIC_LT_OS
:
2123 case INTRINSIC_LE_OS
:
2124 if ((*check_function
) (op2
) == FAILURE
)
2127 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2128 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2130 gfc_error ("Numeric or CHARACTER operands are required in "
2131 "expression at %L", &e
->where
);
2136 case INTRINSIC_PLUS
:
2137 case INTRINSIC_MINUS
:
2138 case INTRINSIC_TIMES
:
2139 case INTRINSIC_DIVIDE
:
2140 case INTRINSIC_POWER
:
2141 if ((*check_function
) (op2
) == FAILURE
)
2144 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2149 case INTRINSIC_CONCAT
:
2150 if ((*check_function
) (op2
) == FAILURE
)
2153 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2155 gfc_error ("Concatenation operator in expression at %L "
2156 "must have two CHARACTER operands", &op1
->where
);
2160 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2162 gfc_error ("Concat operator at %L must concatenate strings of the "
2163 "same kind", &e
->where
);
2170 if (et0 (op1
) != BT_LOGICAL
)
2172 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2173 "operand", &op1
->where
);
2182 case INTRINSIC_NEQV
:
2183 if ((*check_function
) (op2
) == FAILURE
)
2186 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2188 gfc_error ("LOGICAL operands are required in expression at %L",
2195 case INTRINSIC_PARENTHESES
:
2199 gfc_error ("Only intrinsic operators can be used in expression at %L",
2207 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2212 /* F2003, 7.1.7 (3): In init expression, allocatable components
2213 must not be data-initialized. */
2215 check_alloc_comp_init (gfc_expr
*e
)
2217 gfc_component
*comp
;
2218 gfc_constructor
*ctor
;
2220 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2221 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2223 for (comp
= e
->ts
.u
.derived
->components
,
2224 ctor
= gfc_constructor_first (e
->value
.constructor
);
2225 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2227 if (comp
->attr
.allocatable
2228 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2230 gfc_error("Invalid initialization expression for ALLOCATABLE "
2231 "component '%s' in structure constructor at %L",
2232 comp
->name
, &ctor
->expr
->where
);
2241 check_init_expr_arguments (gfc_expr
*e
)
2243 gfc_actual_arglist
*ap
;
2245 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2246 if (check_init_expr (ap
->expr
) == FAILURE
)
2252 static gfc_try
check_restricted (gfc_expr
*);
2254 /* F95, 7.1.6.1, Initialization expressions, (7)
2255 F2003, 7.1.7 Initialization expression, (8) */
2258 check_inquiry (gfc_expr
*e
, int not_restricted
)
2261 const char *const *functions
;
2263 static const char *const inquiry_func_f95
[] = {
2264 "lbound", "shape", "size", "ubound",
2265 "bit_size", "len", "kind",
2266 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2267 "precision", "radix", "range", "tiny",
2271 static const char *const inquiry_func_f2003
[] = {
2272 "lbound", "shape", "size", "ubound",
2273 "bit_size", "len", "kind",
2274 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2275 "precision", "radix", "range", "tiny",
2280 gfc_actual_arglist
*ap
;
2282 if (!e
->value
.function
.isym
2283 || !e
->value
.function
.isym
->inquiry
)
2286 /* An undeclared parameter will get us here (PR25018). */
2287 if (e
->symtree
== NULL
)
2290 name
= e
->symtree
->n
.sym
->name
;
2292 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2293 ? inquiry_func_f2003
: inquiry_func_f95
;
2295 for (i
= 0; functions
[i
]; i
++)
2296 if (strcmp (functions
[i
], name
) == 0)
2299 if (functions
[i
] == NULL
)
2302 /* At this point we have an inquiry function with a variable argument. The
2303 type of the variable might be undefined, but we need it now, because the
2304 arguments of these functions are not allowed to be undefined. */
2306 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2311 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2313 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2314 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2318 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2321 /* Assumed character length will not reduce to a constant expression
2322 with LEN, as required by the standard. */
2323 if (i
== 5 && not_restricted
2324 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2325 && ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
)
2327 gfc_error ("Assumed character length variable '%s' in constant "
2328 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2331 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2334 if (not_restricted
== 0
2335 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2336 && check_restricted (ap
->expr
) == FAILURE
)
2344 /* F95, 7.1.6.1, Initialization expressions, (5)
2345 F2003, 7.1.7 Initialization expression, (5) */
2348 check_transformational (gfc_expr
*e
)
2350 static const char * const trans_func_f95
[] = {
2351 "repeat", "reshape", "selected_int_kind",
2352 "selected_real_kind", "transfer", "trim", NULL
2355 static const char * const trans_func_f2003
[] = {
2356 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2357 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2358 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2359 "trim", "unpack", NULL
2364 const char *const *functions
;
2366 if (!e
->value
.function
.isym
2367 || !e
->value
.function
.isym
->transformational
)
2370 name
= e
->symtree
->n
.sym
->name
;
2372 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2373 ? trans_func_f2003
: trans_func_f95
;
2375 /* NULL() is dealt with below. */
2376 if (strcmp ("null", name
) == 0)
2379 for (i
= 0; functions
[i
]; i
++)
2380 if (strcmp (functions
[i
], name
) == 0)
2383 if (functions
[i
] == NULL
)
2385 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2386 "in an initialization expression", name
, &e
->where
);
2390 return check_init_expr_arguments (e
);
2394 /* F95, 7.1.6.1, Initialization expressions, (6)
2395 F2003, 7.1.7 Initialization expression, (6) */
2398 check_null (gfc_expr
*e
)
2400 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2403 return check_init_expr_arguments (e
);
2408 check_elemental (gfc_expr
*e
)
2410 if (!e
->value
.function
.isym
2411 || !e
->value
.function
.isym
->elemental
)
2414 if (e
->ts
.type
!= BT_INTEGER
2415 && e
->ts
.type
!= BT_CHARACTER
2416 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2417 "nonstandard initialization expression at %L",
2418 &e
->where
) == FAILURE
)
2421 return check_init_expr_arguments (e
);
2426 check_conversion (gfc_expr
*e
)
2428 if (!e
->value
.function
.isym
2429 || !e
->value
.function
.isym
->conversion
)
2432 return check_init_expr_arguments (e
);
2436 /* Verify that an expression is an initialization expression. A side
2437 effect is that the expression tree is reduced to a single constant
2438 node if all goes well. This would normally happen when the
2439 expression is constructed but function references are assumed to be
2440 intrinsics in the context of initialization expressions. If
2441 FAILURE is returned an error message has been generated. */
2444 check_init_expr (gfc_expr
*e
)
2452 switch (e
->expr_type
)
2455 t
= check_intrinsic_op (e
, check_init_expr
);
2457 t
= gfc_simplify_expr (e
, 0);
2465 gfc_intrinsic_sym
* isym
;
2468 sym
= e
->symtree
->n
.sym
;
2469 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2470 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2472 gfc_error ("Function '%s' in initialization expression at %L "
2473 "must be an intrinsic function",
2474 e
->symtree
->n
.sym
->name
, &e
->where
);
2478 if ((m
= check_conversion (e
)) == MATCH_NO
2479 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2480 && (m
= check_null (e
)) == MATCH_NO
2481 && (m
= check_transformational (e
)) == MATCH_NO
2482 && (m
= check_elemental (e
)) == MATCH_NO
)
2484 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2485 "in an initialization expression",
2486 e
->symtree
->n
.sym
->name
, &e
->where
);
2490 /* Try to scalarize an elemental intrinsic function that has an
2492 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2493 if (isym
&& isym
->elemental
2494 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2499 t
= gfc_simplify_expr (e
, 0);
2506 if (gfc_check_iter_variable (e
) == SUCCESS
)
2509 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2511 /* A PARAMETER shall not be used to define itself, i.e.
2512 REAL, PARAMETER :: x = transfer(0, x)
2514 if (!e
->symtree
->n
.sym
->value
)
2516 gfc_error("PARAMETER '%s' is used at %L before its definition "
2517 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2521 t
= simplify_parameter_variable (e
, 0);
2526 if (gfc_in_match_data ())
2531 if (e
->symtree
->n
.sym
->as
)
2533 switch (e
->symtree
->n
.sym
->as
->type
)
2535 case AS_ASSUMED_SIZE
:
2536 gfc_error ("Assumed size array '%s' at %L is not permitted "
2537 "in an initialization expression",
2538 e
->symtree
->n
.sym
->name
, &e
->where
);
2541 case AS_ASSUMED_SHAPE
:
2542 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2543 "in an initialization expression",
2544 e
->symtree
->n
.sym
->name
, &e
->where
);
2548 gfc_error ("Deferred array '%s' at %L is not permitted "
2549 "in an initialization expression",
2550 e
->symtree
->n
.sym
->name
, &e
->where
);
2554 gfc_error ("Array '%s' at %L is a variable, which does "
2555 "not reduce to a constant expression",
2556 e
->symtree
->n
.sym
->name
, &e
->where
);
2564 gfc_error ("Parameter '%s' at %L has not been declared or is "
2565 "a variable, which does not reduce to a constant "
2566 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2575 case EXPR_SUBSTRING
:
2576 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2580 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2582 t
= gfc_simplify_expr (e
, 0);
2586 case EXPR_STRUCTURE
:
2587 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2591 t
= check_alloc_comp_init (e
);
2595 t
= gfc_check_constructor (e
, check_init_expr
);
2602 t
= gfc_check_constructor (e
, check_init_expr
);
2606 t
= gfc_expand_constructor (e
);
2610 t
= gfc_check_constructor_type (e
);
2614 gfc_internal_error ("check_init_expr(): Unknown expression type");
2620 /* Reduces a general expression to an initialization expression (a constant).
2621 This used to be part of gfc_match_init_expr.
2622 Note that this function doesn't free the given expression on FAILURE. */
2625 gfc_reduce_init_expr (gfc_expr
*expr
)
2630 t
= gfc_resolve_expr (expr
);
2632 t
= check_init_expr (expr
);
2638 if (expr
->expr_type
== EXPR_ARRAY
)
2640 if (gfc_check_constructor_type (expr
) == FAILURE
)
2642 if (gfc_expand_constructor (expr
) == FAILURE
)
2650 /* Match an initialization expression. We work by first matching an
2651 expression, then reducing it to a constant. The reducing it to
2652 constant part requires a global variable to flag the prohibition
2653 of a non-integer exponent in -std=f95 mode. */
2655 bool init_flag
= false;
2658 gfc_match_init_expr (gfc_expr
**result
)
2668 m
= gfc_match_expr (&expr
);
2675 t
= gfc_reduce_init_expr (expr
);
2678 gfc_free_expr (expr
);
2690 /* Given an actual argument list, test to see that each argument is a
2691 restricted expression and optionally if the expression type is
2692 integer or character. */
2695 restricted_args (gfc_actual_arglist
*a
)
2697 for (; a
; a
= a
->next
)
2699 if (check_restricted (a
->expr
) == FAILURE
)
2707 /************* Restricted/specification expressions *************/
2710 /* Make sure a non-intrinsic function is a specification function. */
2713 external_spec_function (gfc_expr
*e
)
2717 f
= e
->value
.function
.esym
;
2719 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2721 gfc_error ("Specification function '%s' at %L cannot be a statement "
2722 "function", f
->name
, &e
->where
);
2726 if (f
->attr
.proc
== PROC_INTERNAL
)
2728 gfc_error ("Specification function '%s' at %L cannot be an internal "
2729 "function", f
->name
, &e
->where
);
2733 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2735 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2740 if (f
->attr
.recursive
)
2742 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2743 f
->name
, &e
->where
);
2747 return restricted_args (e
->value
.function
.actual
);
2751 /* Check to see that a function reference to an intrinsic is a
2752 restricted expression. */
2755 restricted_intrinsic (gfc_expr
*e
)
2757 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2758 if (check_inquiry (e
, 0) == MATCH_YES
)
2761 return restricted_args (e
->value
.function
.actual
);
2765 /* Check the expressions of an actual arglist. Used by check_restricted. */
2768 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2770 for (; arg
; arg
= arg
->next
)
2771 if (checker (arg
->expr
) == FAILURE
)
2778 /* Check the subscription expressions of a reference chain with a checking
2779 function; used by check_restricted. */
2782 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2792 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2794 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2796 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2798 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2804 /* Nothing needed, just proceed to next reference. */
2808 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2810 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2819 return check_references (ref
->next
, checker
);
2823 /* Verify that an expression is a restricted expression. Like its
2824 cousin check_init_expr(), an error message is generated if we
2828 check_restricted (gfc_expr
*e
)
2836 switch (e
->expr_type
)
2839 t
= check_intrinsic_op (e
, check_restricted
);
2841 t
= gfc_simplify_expr (e
, 0);
2846 if (e
->value
.function
.esym
)
2848 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2850 t
= external_spec_function (e
);
2854 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2857 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2860 t
= restricted_intrinsic (e
);
2865 sym
= e
->symtree
->n
.sym
;
2868 /* If a dummy argument appears in a context that is valid for a
2869 restricted expression in an elemental procedure, it will have
2870 already been simplified away once we get here. Therefore we
2871 don't need to jump through hoops to distinguish valid from
2873 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2874 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2876 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2877 sym
->name
, &e
->where
);
2881 if (sym
->attr
.optional
)
2883 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2884 sym
->name
, &e
->where
);
2888 if (sym
->attr
.intent
== INTENT_OUT
)
2890 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2891 sym
->name
, &e
->where
);
2895 /* Check reference chain if any. */
2896 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2899 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2900 processed in resolve.c(resolve_formal_arglist). This is done so
2901 that host associated dummy array indices are accepted (PR23446).
2902 This mechanism also does the same for the specification expressions
2903 of array-valued functions. */
2905 || sym
->attr
.in_common
2906 || sym
->attr
.use_assoc
2908 || sym
->attr
.implied_index
2909 || sym
->attr
.flavor
== FL_PARAMETER
2910 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2911 || (sym
->ns
&& gfc_current_ns
->parent
2912 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2913 || (sym
->ns
->proc_name
!= NULL
2914 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2915 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2921 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2922 sym
->name
, &e
->where
);
2923 /* Prevent a repetition of the error. */
2932 case EXPR_SUBSTRING
:
2933 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2937 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2939 t
= gfc_simplify_expr (e
, 0);
2943 case EXPR_STRUCTURE
:
2944 t
= gfc_check_constructor (e
, check_restricted
);
2948 t
= gfc_check_constructor (e
, check_restricted
);
2952 gfc_internal_error ("check_restricted(): Unknown expression type");
2959 /* Check to see that an expression is a specification expression. If
2960 we return FAILURE, an error has been generated. */
2963 gfc_specification_expr (gfc_expr
*e
)
2965 gfc_component
*comp
;
2970 if (e
->ts
.type
!= BT_INTEGER
)
2972 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2973 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2977 if (e
->expr_type
== EXPR_FUNCTION
2978 && !e
->value
.function
.isym
2979 && !e
->value
.function
.esym
2980 && !gfc_pure (e
->symtree
->n
.sym
)
2981 && (!gfc_is_proc_ptr_comp (e
, &comp
)
2982 || !comp
->attr
.pure
))
2984 gfc_error ("Function '%s' at %L must be PURE",
2985 e
->symtree
->n
.sym
->name
, &e
->where
);
2986 /* Prevent repeat error messages. */
2987 e
->symtree
->n
.sym
->attr
.pure
= 1;
2993 gfc_error ("Expression at %L must be scalar", &e
->where
);
2997 if (gfc_simplify_expr (e
, 0) == FAILURE
)
3000 return check_restricted (e
);
3004 /************** Expression conformance checks. *************/
3006 /* Given two expressions, make sure that the arrays are conformable. */
3009 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3011 int op1_flag
, op2_flag
, d
;
3012 mpz_t op1_size
, op2_size
;
3018 if (op1
->rank
== 0 || op2
->rank
== 0)
3021 va_start (argp
, optype_msgid
);
3022 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3025 if (op1
->rank
!= op2
->rank
)
3027 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3028 op1
->rank
, op2
->rank
, &op1
->where
);
3034 for (d
= 0; d
< op1
->rank
; d
++)
3036 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
3037 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
3039 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3041 gfc_error ("Different shape for %s at %L on dimension %d "
3042 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3043 (int) mpz_get_si (op1_size
),
3044 (int) mpz_get_si (op2_size
));
3050 mpz_clear (op1_size
);
3052 mpz_clear (op2_size
);
3062 /* Given an assignable expression and an arbitrary expression, make
3063 sure that the assignment can take place. */
3066 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
3072 sym
= lvalue
->symtree
->n
.sym
;
3074 /* Check INTENT(IN), unless the object itself is the component or
3075 sub-component of a pointer. */
3076 has_pointer
= sym
->attr
.pointer
;
3078 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3079 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3085 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
3087 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3088 sym
->name
, &lvalue
->where
);
3092 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3093 variable local to a function subprogram. Its existence begins when
3094 execution of the function is initiated and ends when execution of the
3095 function is terminated...
3096 Therefore, the left hand side is no longer a variable, when it is: */
3097 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3098 && !sym
->attr
.external
)
3103 /* (i) Use associated; */
3104 if (sym
->attr
.use_assoc
)
3107 /* (ii) The assignment is in the main program; or */
3108 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
3111 /* (iii) A module or internal procedure... */
3112 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3113 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3114 && gfc_current_ns
->parent
3115 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3116 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3117 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3119 /* ... that is not a function... */
3120 if (!gfc_current_ns
->proc_name
->attr
.function
)
3123 /* ... or is not an entry and has a different name. */
3124 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3128 /* (iv) Host associated and not the function symbol or the
3129 parent result. This picks up sibling references, which
3130 cannot be entries. */
3131 if (!sym
->attr
.entry
3132 && sym
->ns
== gfc_current_ns
->parent
3133 && sym
!= gfc_current_ns
->proc_name
3134 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3139 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3144 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3146 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3147 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3151 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3153 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3158 if (rvalue
->expr_type
== EXPR_NULL
)
3160 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3161 && lvalue
->symtree
->n
.sym
->attr
.data
)
3165 gfc_error ("NULL appears on right-hand side in assignment at %L",
3171 /* This is possibly a typo: x = f() instead of x => f(). */
3172 if (gfc_option
.warn_surprising
3173 && rvalue
->expr_type
== EXPR_FUNCTION
3174 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3175 gfc_warning ("POINTER valued function appears on right-hand side of "
3176 "assignment at %L", &rvalue
->where
);
3178 /* Check size of array assignments. */
3179 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3180 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3183 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3184 && lvalue
->symtree
->n
.sym
->attr
.data
3185 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3186 "initialize non-integer variable '%s'",
3187 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3190 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3191 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3192 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3193 &rvalue
->where
) == FAILURE
)
3196 /* Handle the case of a BOZ literal on the RHS. */
3197 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3200 if (gfc_option
.warn_surprising
)
3201 gfc_warning ("BOZ literal at %L is bitwise transferred "
3202 "non-integer symbol '%s'", &rvalue
->where
,
3203 lvalue
->symtree
->n
.sym
->name
);
3204 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3206 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3208 if (rc
== ARITH_UNDERFLOW
)
3209 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3210 ". This check can be disabled with the option "
3211 "-fno-range-check", &rvalue
->where
);
3212 else if (rc
== ARITH_OVERFLOW
)
3213 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3214 ". This check can be disabled with the option "
3215 "-fno-range-check", &rvalue
->where
);
3216 else if (rc
== ARITH_NAN
)
3217 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3218 ". This check can be disabled with the option "
3219 "-fno-range-check", &rvalue
->where
);
3224 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3227 /* Only DATA Statements come here. */
3230 /* Numeric can be converted to any other numeric. And Hollerith can be
3231 converted to any other type. */
3232 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3233 || rvalue
->ts
.type
== BT_HOLLERITH
)
3236 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3239 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3240 "conversion of %s to %s", &lvalue
->where
,
3241 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3246 /* Assignment is the only case where character variables of different
3247 kind values can be converted into one another. */
3248 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3250 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3251 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3256 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3260 /* Check that a pointer assignment is OK. We first check lvalue, and
3261 we only check rvalue if it's not an assignment to NULL() or a
3262 NULLIFY statement. */
3265 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3267 symbol_attribute attr
;
3270 int pointer
, check_intent_in
, proc_pointer
;
3272 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3273 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3275 gfc_error ("Pointer assignment target is not a POINTER at %L",
3280 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3281 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3282 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3284 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3285 "l-value since it is a procedure",
3286 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3291 /* Check INTENT(IN), unless the object itself is the component or
3292 sub-component of a pointer. */
3293 check_intent_in
= 1;
3294 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
3295 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3297 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3300 check_intent_in
= 0;
3302 if (ref
->type
== REF_COMPONENT
)
3304 pointer
= ref
->u
.c
.component
->attr
.pointer
;
3305 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3308 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3310 if (ref
->u
.ar
.type
== AR_FULL
)
3313 if (ref
->u
.ar
.type
!= AR_SECTION
)
3315 gfc_error ("Expected bounds specification for '%s' at %L",
3316 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3320 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3321 "specification for '%s' in pointer assignment "
3322 "at %L", lvalue
->symtree
->n
.sym
->name
,
3323 &lvalue
->where
) == FAILURE
)
3326 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3327 "in gfortran", &lvalue
->where
);
3328 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3329 either never or always the upper-bound; strides shall not be
3335 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3337 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3338 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3342 if (!pointer
&& !proc_pointer
3343 && !(lvalue
->ts
.type
== BT_CLASS
3344 && lvalue
->ts
.u
.derived
->components
->attr
.pointer
))
3346 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
3350 is_pure
= gfc_pure (NULL
);
3352 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
3353 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
3355 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
3359 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3360 kind, etc for lvalue and rvalue must match, and rvalue must be a
3361 pure variable if we're in a pure function. */
3362 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3365 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3366 if (lvalue
->expr_type
== EXPR_VARIABLE
3367 && gfc_is_coindexed (lvalue
))
3370 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3371 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3373 gfc_error ("Pointer object at %L shall not have a coindex",
3379 /* Checks on rvalue for procedure pointer assignments. */
3384 gfc_component
*comp
;
3387 attr
= gfc_expr_attr (rvalue
);
3388 if (!((rvalue
->expr_type
== EXPR_NULL
)
3389 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3390 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3391 || (rvalue
->expr_type
== EXPR_VARIABLE
3392 && attr
.flavor
== FL_PROCEDURE
)))
3394 gfc_error ("Invalid procedure pointer assignment at %L",
3400 gfc_error ("Abstract interface '%s' is invalid "
3401 "in procedure pointer assignment at %L",
3402 rvalue
->symtree
->name
, &rvalue
->where
);
3405 /* Check for C727. */
3406 if (attr
.flavor
== FL_PROCEDURE
)
3408 if (attr
.proc
== PROC_ST_FUNCTION
)
3410 gfc_error ("Statement function '%s' is invalid "
3411 "in procedure pointer assignment at %L",
3412 rvalue
->symtree
->name
, &rvalue
->where
);
3415 if (attr
.proc
== PROC_INTERNAL
&&
3416 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3417 "invalid in procedure pointer assignment at %L",
3418 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3422 /* Ensure that the calling convention is the same. As other attributes
3423 such as DLLEXPORT may differ, one explicitly only tests for the
3424 calling conventions. */
3425 if (rvalue
->expr_type
== EXPR_VARIABLE
3426 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3427 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3429 symbol_attribute calls
;
3432 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3433 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3434 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3436 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3437 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3439 gfc_error ("Mismatch in the procedure pointer assignment "
3440 "at %L: mismatch in the calling convention",
3446 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3447 s1
= comp
->ts
.interface
;
3449 s1
= lvalue
->symtree
->n
.sym
;
3451 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3453 s2
= comp
->ts
.interface
;
3456 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3458 s2
= rvalue
->symtree
->n
.sym
->result
;
3459 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3463 s2
= rvalue
->symtree
->n
.sym
;
3464 name
= rvalue
->symtree
->n
.sym
->name
;
3467 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3470 gfc_error ("Interface mismatch in procedure pointer assignment "
3471 "at %L: %s", &rvalue
->where
, err
);
3478 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3480 gfc_error ("Different types in pointer assignment at %L; attempted "
3481 "assignment of %s to %s", &lvalue
->where
,
3482 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3486 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3488 gfc_error ("Different kind type parameters in pointer "
3489 "assignment at %L", &lvalue
->where
);
3493 if (lvalue
->rank
!= rvalue
->rank
)
3495 gfc_error ("Different ranks in pointer assignment at %L",
3500 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3501 if (rvalue
->expr_type
== EXPR_NULL
)
3504 if (lvalue
->ts
.type
== BT_CHARACTER
)
3506 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3511 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3512 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3514 attr
= gfc_expr_attr (rvalue
);
3515 if (!attr
.target
&& !attr
.pointer
)
3517 gfc_error ("Pointer assignment target is neither TARGET "
3518 "nor POINTER at %L", &rvalue
->where
);
3522 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3524 gfc_error ("Bad target in pointer assignment in PURE "
3525 "procedure at %L", &rvalue
->where
);
3528 if (gfc_has_vector_index (rvalue
))
3530 gfc_error ("Pointer assignment with vector subscript "
3531 "on rhs at %L", &rvalue
->where
);
3535 if (attr
.is_protected
&& attr
.use_assoc
3536 && !(attr
.pointer
|| attr
.proc_pointer
))
3538 gfc_error ("Pointer assignment target has PROTECTED "
3539 "attribute at %L", &rvalue
->where
);
3543 /* F2008, C725. For PURE also C1283. */
3544 if (rvalue
->expr_type
== EXPR_VARIABLE
3545 && gfc_is_coindexed (rvalue
))
3548 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3549 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3551 gfc_error ("Data target at %L shall not have a coindex",
3561 /* Relative of gfc_check_assign() except that the lvalue is a single
3562 symbol. Used for initialization assignments. */
3565 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3570 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3572 lvalue
.expr_type
= EXPR_VARIABLE
;
3573 lvalue
.ts
= sym
->ts
;
3575 lvalue
.rank
= sym
->as
->rank
;
3576 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
3577 lvalue
.symtree
->n
.sym
= sym
;
3578 lvalue
.where
= sym
->declared_at
;
3580 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3581 || (sym
->ts
.type
== BT_CLASS
3582 && sym
->ts
.u
.derived
->components
->attr
.pointer
3583 && rvalue
->expr_type
== EXPR_NULL
))
3584 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3586 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3588 gfc_free (lvalue
.symtree
);
3594 /* Get an expression for a default initializer. */
3597 gfc_default_initializer (gfc_typespec
*ts
)
3600 gfc_component
*comp
;
3602 /* See if we have a default initializer. */
3603 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3604 if (comp
->initializer
|| comp
->attr
.allocatable
)
3610 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
3611 &ts
->u
.derived
->declared_at
);
3614 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
3616 gfc_constructor
*ctor
= gfc_constructor_get();
3618 if (comp
->initializer
)
3619 ctor
->expr
= gfc_copy_expr (comp
->initializer
);
3621 if (comp
->attr
.allocatable
)
3623 ctor
->expr
= gfc_get_expr ();
3624 ctor
->expr
->expr_type
= EXPR_NULL
;
3625 ctor
->expr
->ts
= comp
->ts
;
3628 gfc_constructor_append (&init
->value
.constructor
, ctor
);
3635 /* Given a symbol, create an expression node with that symbol as a
3636 variable. If the symbol is array valued, setup a reference of the
3640 gfc_get_variable_expr (gfc_symtree
*var
)
3644 e
= gfc_get_expr ();
3645 e
->expr_type
= EXPR_VARIABLE
;
3647 e
->ts
= var
->n
.sym
->ts
;
3649 if (var
->n
.sym
->as
!= NULL
)
3651 e
->rank
= var
->n
.sym
->as
->rank
;
3652 e
->ref
= gfc_get_ref ();
3653 e
->ref
->type
= REF_ARRAY
;
3654 e
->ref
->u
.ar
.type
= AR_FULL
;
3661 /* Returns the array_spec of a full array expression. A NULL is
3662 returned otherwise. */
3664 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
3669 if (expr
->rank
== 0)
3672 /* Follow any component references. */
3673 if (expr
->expr_type
== EXPR_VARIABLE
3674 || expr
->expr_type
== EXPR_CONSTANT
)
3676 as
= expr
->symtree
->n
.sym
->as
;
3677 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3682 as
= ref
->u
.c
.component
->as
;
3690 switch (ref
->u
.ar
.type
)
3713 /* General expression traversal function. */
3716 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3717 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3722 gfc_actual_arglist
*args
;
3729 if ((*func
) (expr
, sym
, &f
))
3732 if (expr
->ts
.type
== BT_CHARACTER
3734 && expr
->ts
.u
.cl
->length
3735 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3736 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3739 switch (expr
->expr_type
)
3744 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3746 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3754 case EXPR_SUBSTRING
:
3757 case EXPR_STRUCTURE
:
3759 for (c
= gfc_constructor_first (expr
->value
.constructor
);
3760 c
; c
= gfc_constructor_next (c
))
3762 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3766 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3768 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3770 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3772 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3779 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3781 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3797 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3799 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3801 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3803 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3809 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3811 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3816 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3817 && ref
->u
.c
.component
->ts
.u
.cl
3818 && ref
->u
.c
.component
->ts
.u
.cl
->length
3819 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
3821 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
3825 if (ref
->u
.c
.component
->as
)
3826 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
3827 + ref
->u
.c
.component
->as
->corank
; i
++)
3829 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3832 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3846 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3849 expr_set_symbols_referenced (gfc_expr
*expr
,
3850 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3851 int *f ATTRIBUTE_UNUSED
)
3853 if (expr
->expr_type
!= EXPR_VARIABLE
)
3855 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3860 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3862 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
3866 /* Determine if an expression is a procedure pointer component. If yes, the
3867 argument 'comp' will point to the component (provided that 'comp' was
3871 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
3876 if (!expr
|| !expr
->ref
)
3883 if (ref
->type
== REF_COMPONENT
)
3885 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
3887 *comp
= ref
->u
.c
.component
;
3894 /* Walk an expression tree and check each variable encountered for being typed.
3895 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3896 mode as is a basic arithmetic expression using those; this is for things in
3899 INTEGER :: arr(n), n
3900 INTEGER :: arr(n + 1), n
3902 The namespace is needed for IMPLICIT typing. */
3904 static gfc_namespace
* check_typed_ns
;
3907 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3908 int* f ATTRIBUTE_UNUSED
)
3912 if (e
->expr_type
!= EXPR_VARIABLE
)
3915 gcc_assert (e
->symtree
);
3916 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
3919 return (t
== FAILURE
);
3923 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
3927 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3931 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
3932 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
3934 if (e
->expr_type
== EXPR_OP
)
3936 gfc_try t
= SUCCESS
;
3938 gcc_assert (e
->value
.op
.op1
);
3939 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
3941 if (t
== SUCCESS
&& e
->value
.op
.op2
)
3942 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
3948 /* Otherwise, walk the expression and do it strictly. */
3949 check_typed_ns
= ns
;
3950 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
3952 return error_found
? FAILURE
: SUCCESS
;
3955 /* Walk an expression tree and replace all symbols with a corresponding symbol
3956 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3957 statements. The boolean return value is required by gfc_traverse_expr. */
3960 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3962 if ((expr
->expr_type
== EXPR_VARIABLE
3963 || (expr
->expr_type
== EXPR_FUNCTION
3964 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
3965 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
3968 gfc_namespace
*ns
= sym
->formal_ns
;
3969 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3970 the symtree rather than create a new one (and probably fail later). */
3971 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
3972 expr
->symtree
->n
.sym
->name
);
3974 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
3975 expr
->symtree
= stree
;
3981 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
3983 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
3986 /* The following is analogous to 'replace_symbol', and needed for copying
3987 interfaces for procedure pointer components. The argument 'sym' must formally
3988 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3989 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3990 component in whose formal_ns the arguments have to be). */
3993 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3995 gfc_component
*comp
;
3996 comp
= (gfc_component
*)sym
;
3997 if ((expr
->expr_type
== EXPR_VARIABLE
3998 || (expr
->expr_type
== EXPR_FUNCTION
3999 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
4000 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
4003 gfc_namespace
*ns
= comp
->formal_ns
;
4004 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4005 the symtree rather than create a new one (and probably fail later). */
4006 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
4007 expr
->symtree
->n
.sym
->name
);
4009 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
4010 expr
->symtree
= stree
;
4016 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
4018 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);
4023 gfc_is_coindexed (gfc_expr
*e
)
4027 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4028 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4035 /* Check whether the expression has an ultimate allocatable component.
4036 Being itself allocatable does not count. */
4038 gfc_has_ultimate_allocatable (gfc_expr
*e
)
4040 gfc_ref
*ref
, *last
= NULL
;
4042 if (e
->expr_type
!= EXPR_VARIABLE
)
4045 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4046 if (ref
->type
== REF_COMPONENT
)
4049 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4050 return last
->u
.c
.component
->ts
.u
.derived
->components
->attr
.alloc_comp
;
4051 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4052 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
4056 if (e
->ts
.type
== BT_CLASS
)
4057 return e
->ts
.u
.derived
->components
->attr
.alloc_comp
;
4058 else if (e
->ts
.type
== BT_DERIVED
)
4059 return e
->ts
.u
.derived
->attr
.alloc_comp
;
4065 /* Check whether the expression has an pointer component.
4066 Being itself a pointer does not count. */
4068 gfc_has_ultimate_pointer (gfc_expr
*e
)
4070 gfc_ref
*ref
, *last
= NULL
;
4072 if (e
->expr_type
!= EXPR_VARIABLE
)
4075 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4076 if (ref
->type
== REF_COMPONENT
)
4079 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
4080 return last
->u
.c
.component
->ts
.u
.derived
->components
->attr
.pointer_comp
;
4081 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
4082 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
4086 if (e
->ts
.type
== BT_CLASS
)
4087 return e
->ts
.u
.derived
->components
->attr
.pointer_comp
;
4088 else if (e
->ts
.type
== BT_DERIVED
)
4089 return e
->ts
.u
.derived
->attr
.pointer_comp
;