1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
27 #include "target-memory.h" /* for gfc_convert_boz */
29 /* Get a new expr node. */
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new_arg
;
72 for (; p
; p
= p
->next
)
74 new_arg
= gfc_get_actual_arglist ();
77 new_arg
->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
109 gfc_free_expr (p
->u
.ar
.start
[i
]);
110 gfc_free_expr (p
->u
.ar
.end
[i
]);
111 gfc_free_expr (p
->u
.ar
.stride
[i
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
160 mpc_clear (e
->value
.complex);
162 mpfr_clear (e
->value
.complex.r
);
163 mpfr_clear (e
->value
.complex.i
);
171 /* Free the representation. */
172 if (e
->representation
.string
)
173 gfc_free (e
->representation
.string
);
178 if (e
->value
.op
.op1
!= NULL
)
179 gfc_free_expr (e
->value
.op
.op1
);
180 if (e
->value
.op
.op2
!= NULL
)
181 gfc_free_expr (e
->value
.op
.op2
);
185 gfc_free_actual_arglist (e
->value
.function
.actual
);
190 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
198 gfc_free_constructor (e
->value
.constructor
);
202 gfc_free (e
->value
.character
.string
);
209 gfc_internal_error ("free_expr0(): Bad expr type");
212 /* Free a shape array. */
213 if (e
->shape
!= NULL
)
215 for (n
= 0; n
< e
->rank
; n
++)
216 mpz_clear (e
->shape
[n
]);
221 gfc_free_ref_list (e
->ref
);
223 memset (e
, '\0', sizeof (gfc_expr
));
227 /* Free an expression node and everything beneath it. */
230 gfc_free_expr (gfc_expr
*e
)
234 if (e
->con_by_offset
)
235 splay_tree_delete (e
->con_by_offset
);
241 /* Graft the *src expression onto the *dest subexpression. */
244 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
252 /* Try to extract an integer constant from the passed expression node.
253 Returns an error message or NULL if the result is set. It is
254 tempting to generate an error and return SUCCESS or FAILURE, but
255 failure is OK for some callers. */
258 gfc_extract_int (gfc_expr
*expr
, int *result
)
260 if (expr
->expr_type
!= EXPR_CONSTANT
)
261 return _("Constant expression required at %C");
263 if (expr
->ts
.type
!= BT_INTEGER
)
264 return _("Integer expression required at %C");
266 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
267 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
269 return _("Integer value too large in expression at %C");
272 *result
= (int) mpz_get_si (expr
->value
.integer
);
278 /* Recursively copy a list of reference structures. */
281 gfc_copy_ref (gfc_ref
*src
)
289 dest
= gfc_get_ref ();
290 dest
->type
= src
->type
;
295 ar
= gfc_copy_array_ref (&src
->u
.ar
);
301 dest
->u
.c
= src
->u
.c
;
305 dest
->u
.ss
= src
->u
.ss
;
306 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
307 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
311 dest
->next
= gfc_copy_ref (src
->next
);
317 /* Detect whether an expression has any vector index array references. */
320 gfc_has_vector_index (gfc_expr
*e
)
324 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
325 if (ref
->type
== REF_ARRAY
)
326 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
327 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
333 /* Copy a shape array. */
336 gfc_copy_shape (mpz_t
*shape
, int rank
)
344 new_shape
= gfc_get_shape (rank
);
346 for (n
= 0; n
< rank
; n
++)
347 mpz_init_set (new_shape
[n
], shape
[n
]);
353 /* Copy a shape array excluding dimension N, where N is an integer
354 constant expression. Dimensions are numbered in fortran style --
357 So, if the original shape array contains R elements
358 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
359 the result contains R-1 elements:
360 { s1 ... sN-1 sN+1 ... sR-1}
362 If anything goes wrong -- N is not a constant, its value is out
363 of range -- or anything else, just returns NULL. */
366 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
368 mpz_t
*new_shape
, *s
;
374 || dim
->expr_type
!= EXPR_CONSTANT
375 || dim
->ts
.type
!= BT_INTEGER
)
378 n
= mpz_get_si (dim
->value
.integer
);
379 n
--; /* Convert to zero based index. */
380 if (n
< 0 || n
>= rank
)
383 s
= new_shape
= gfc_get_shape (rank
- 1);
385 for (i
= 0; i
< rank
; i
++)
389 mpz_init_set (*s
, shape
[i
]);
397 /* Given an expression pointer, return a copy of the expression. This
398 subroutine is recursive. */
401 gfc_copy_expr (gfc_expr
*p
)
413 switch (q
->expr_type
)
416 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
417 q
->value
.character
.string
= s
;
418 memcpy (s
, p
->value
.character
.string
,
419 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
423 /* Copy target representation, if it exists. */
424 if (p
->representation
.string
)
426 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
427 q
->representation
.string
= c
;
428 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
431 /* Copy the values of any pointer components of p->value. */
435 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
439 gfc_set_model_kind (q
->ts
.kind
);
440 mpfr_init (q
->value
.real
);
441 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
445 gfc_set_model_kind (q
->ts
.kind
);
447 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
448 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
450 mpfr_init (q
->value
.complex.r
);
451 mpfr_init (q
->value
.complex.i
);
452 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
453 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
458 if (p
->representation
.string
)
459 q
->value
.character
.string
460 = gfc_char_to_widechar (q
->representation
.string
);
463 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
464 q
->value
.character
.string
= s
;
466 /* This is the case for the C_NULL_CHAR named constant. */
467 if (p
->value
.character
.length
== 0
468 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
471 /* Need to set the length to 1 to make sure the NUL
472 terminator is copied. */
473 q
->value
.character
.length
= 1;
476 memcpy (s
, p
->value
.character
.string
,
477 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
484 break; /* Already done. */
488 /* Should never be reached. */
490 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
497 switch (q
->value
.op
.op
)
500 case INTRINSIC_PARENTHESES
:
501 case INTRINSIC_UPLUS
:
502 case INTRINSIC_UMINUS
:
503 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
506 default: /* Binary operators. */
507 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
508 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
515 q
->value
.function
.actual
=
516 gfc_copy_actual_arglist (p
->value
.function
.actual
);
521 q
->value
.compcall
.actual
=
522 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
523 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
528 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
536 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
538 q
->ref
= gfc_copy_ref (p
->ref
);
544 /* Return the maximum kind of two expressions. In general, higher
545 kind numbers mean more precision for numeric types. */
548 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
550 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
554 /* Returns nonzero if the type is numeric, zero otherwise. */
557 numeric_type (bt type
)
559 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
563 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
566 gfc_numeric_ts (gfc_typespec
*ts
)
568 return numeric_type (ts
->type
);
572 /* Returns an expression node that is an integer constant. */
581 p
->expr_type
= EXPR_CONSTANT
;
582 p
->ts
.type
= BT_INTEGER
;
583 p
->ts
.kind
= gfc_default_integer_kind
;
585 p
->where
= gfc_current_locus
;
586 mpz_init_set_si (p
->value
.integer
, i
);
592 /* Returns an expression node that is a logical constant. */
595 gfc_logical_expr (int i
, locus
*where
)
601 p
->expr_type
= EXPR_CONSTANT
;
602 p
->ts
.type
= BT_LOGICAL
;
603 p
->ts
.kind
= gfc_default_logical_kind
;
606 where
= &gfc_current_locus
;
608 p
->value
.logical
= i
;
614 /* Return an expression node with an optional argument list attached.
615 A variable number of gfc_expr pointers are strung together in an
616 argument list with a NULL pointer terminating the list. */
619 gfc_build_conversion (gfc_expr
*e
)
624 p
->expr_type
= EXPR_FUNCTION
;
626 p
->value
.function
.actual
= NULL
;
628 p
->value
.function
.actual
= gfc_get_actual_arglist ();
629 p
->value
.function
.actual
->expr
= e
;
635 /* Given an expression node with some sort of numeric binary
636 expression, insert type conversions required to make the operands
639 The exception is that the operands of an exponential don't have to
640 have the same type. If possible, the base is promoted to the type
641 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
642 1.0**2 stays as it is. */
645 gfc_type_convert_binary (gfc_expr
*e
)
649 op1
= e
->value
.op
.op1
;
650 op2
= e
->value
.op
.op2
;
652 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
654 gfc_clear_ts (&e
->ts
);
658 /* Kind conversions of same type. */
659 if (op1
->ts
.type
== op2
->ts
.type
)
661 if (op1
->ts
.kind
== op2
->ts
.kind
)
663 /* No type conversions. */
668 if (op1
->ts
.kind
> op2
->ts
.kind
)
669 gfc_convert_type (op2
, &op1
->ts
, 2);
671 gfc_convert_type (op1
, &op2
->ts
, 2);
677 /* Integer combined with real or complex. */
678 if (op2
->ts
.type
== BT_INTEGER
)
682 /* Special case for ** operator. */
683 if (e
->value
.op
.op
== INTRINSIC_POWER
)
686 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
690 if (op1
->ts
.type
== BT_INTEGER
)
693 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
697 /* Real combined with complex. */
698 e
->ts
.type
= BT_COMPLEX
;
699 if (op1
->ts
.kind
> op2
->ts
.kind
)
700 e
->ts
.kind
= op1
->ts
.kind
;
702 e
->ts
.kind
= op2
->ts
.kind
;
703 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
704 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
705 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
706 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
714 check_specification_function (gfc_expr
*e
)
721 sym
= e
->symtree
->n
.sym
;
723 /* F95, 7.1.6.2; F2003, 7.1.7 */
725 && sym
->attr
.function
727 && !sym
->attr
.intrinsic
728 && !sym
->attr
.recursive
729 && sym
->attr
.proc
!= PROC_INTERNAL
730 && sym
->attr
.proc
!= PROC_ST_FUNCTION
731 && sym
->attr
.proc
!= PROC_UNKNOWN
732 && sym
->formal
== NULL
)
738 /* Function to determine if an expression is constant or not. This
739 function expects that the expression has already been simplified. */
742 gfc_is_constant_expr (gfc_expr
*e
)
745 gfc_actual_arglist
*arg
;
751 switch (e
->expr_type
)
754 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
755 && (e
->value
.op
.op2
== NULL
756 || gfc_is_constant_expr (e
->value
.op
.op2
)));
764 /* Specification functions are constant. */
765 if (check_specification_function (e
) == MATCH_YES
)
771 /* Call to intrinsic with at least one argument. */
773 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
775 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
777 if (!gfc_is_constant_expr (arg
->expr
))
791 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
792 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
797 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
798 if (!gfc_is_constant_expr (c
->expr
))
806 rv
= gfc_constant_ac (e
);
810 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
817 /* Is true if an array reference is followed by a component or substring
820 is_subref_array (gfc_expr
* e
)
825 if (e
->expr_type
!= EXPR_VARIABLE
)
828 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
832 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
834 if (ref
->type
== REF_ARRAY
835 && ref
->u
.ar
.type
!= AR_ELEMENT
)
839 && ref
->type
!= REF_ARRAY
)
846 /* Try to collapse intrinsic expressions. */
849 simplify_intrinsic_op (gfc_expr
*p
, int type
)
852 gfc_expr
*op1
, *op2
, *result
;
854 if (p
->value
.op
.op
== INTRINSIC_USER
)
857 op1
= p
->value
.op
.op1
;
858 op2
= p
->value
.op
.op2
;
861 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
863 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
866 if (!gfc_is_constant_expr (op1
)
867 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
871 p
->value
.op
.op1
= NULL
;
872 p
->value
.op
.op2
= NULL
;
876 case INTRINSIC_PARENTHESES
:
877 result
= gfc_parentheses (op1
);
880 case INTRINSIC_UPLUS
:
881 result
= gfc_uplus (op1
);
884 case INTRINSIC_UMINUS
:
885 result
= gfc_uminus (op1
);
889 result
= gfc_add (op1
, op2
);
892 case INTRINSIC_MINUS
:
893 result
= gfc_subtract (op1
, op2
);
896 case INTRINSIC_TIMES
:
897 result
= gfc_multiply (op1
, op2
);
900 case INTRINSIC_DIVIDE
:
901 result
= gfc_divide (op1
, op2
);
904 case INTRINSIC_POWER
:
905 result
= gfc_power (op1
, op2
);
908 case INTRINSIC_CONCAT
:
909 result
= gfc_concat (op1
, op2
);
913 case INTRINSIC_EQ_OS
:
914 result
= gfc_eq (op1
, op2
, op
);
918 case INTRINSIC_NE_OS
:
919 result
= gfc_ne (op1
, op2
, op
);
923 case INTRINSIC_GT_OS
:
924 result
= gfc_gt (op1
, op2
, op
);
928 case INTRINSIC_GE_OS
:
929 result
= gfc_ge (op1
, op2
, op
);
933 case INTRINSIC_LT_OS
:
934 result
= gfc_lt (op1
, op2
, op
);
938 case INTRINSIC_LE_OS
:
939 result
= gfc_le (op1
, op2
, op
);
943 result
= gfc_not (op1
);
947 result
= gfc_and (op1
, op2
);
951 result
= gfc_or (op1
, op2
);
955 result
= gfc_eqv (op1
, op2
);
959 result
= gfc_neqv (op1
, op2
);
963 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
973 result
->rank
= p
->rank
;
974 result
->where
= p
->where
;
975 gfc_replace_expr (p
, result
);
981 /* Subroutine to simplify constructor expressions. Mutually recursive
982 with gfc_simplify_expr(). */
985 simplify_constructor (gfc_constructor
*c
, int type
)
989 for (; c
; c
= c
->next
)
992 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
993 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
994 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
999 /* Try and simplify a copy. Replace the original if successful
1000 but keep going through the constructor at all costs. Not
1001 doing so can make a dog's dinner of complicated things. */
1002 p
= gfc_copy_expr (c
->expr
);
1004 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1010 gfc_replace_expr (c
->expr
, p
);
1018 /* Pull a single array element out of an array constructor. */
1021 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
1022 gfc_constructor
**rval
)
1024 unsigned long nelemen
;
1036 mpz_init_set_ui (offset
, 0);
1039 mpz_init_set_ui (span
, 1);
1040 for (i
= 0; i
< ar
->dimen
; i
++)
1042 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1043 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1050 e
= gfc_copy_expr (ar
->start
[i
]);
1051 if (e
->expr_type
!= EXPR_CONSTANT
)
1057 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1058 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1060 /* Check the bounds. */
1061 if ((ar
->as
->upper
[i
]
1062 && mpz_cmp (e
->value
.integer
,
1063 ar
->as
->upper
[i
]->value
.integer
) > 0)
1064 || (mpz_cmp (e
->value
.integer
,
1065 ar
->as
->lower
[i
]->value
.integer
) < 0))
1067 gfc_error ("Index in dimension %d is out of bounds "
1068 "at %L", i
+ 1, &ar
->c_where
[i
]);
1074 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1075 mpz_mul (delta
, delta
, span
);
1076 mpz_add (offset
, offset
, delta
);
1078 mpz_set_ui (tmp
, 1);
1079 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1080 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1081 mpz_mul (span
, span
, tmp
);
1084 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1109 /* Find a component of a structure constructor. */
1111 static gfc_constructor
*
1112 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1114 gfc_component
*comp
;
1115 gfc_component
*pick
;
1117 comp
= ref
->u
.c
.sym
->components
;
1118 pick
= ref
->u
.c
.component
;
1119 while (comp
!= pick
)
1129 /* Replace an expression with the contents of a constructor, removing
1130 the subobject reference in the process. */
1133 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1139 e
->ref
= p
->ref
->next
;
1140 p
->ref
->next
= NULL
;
1141 gfc_replace_expr (p
, e
);
1145 /* Pull an array section out of an array constructor. */
1148 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1154 long unsigned one
= 1;
1156 mpz_t start
[GFC_MAX_DIMENSIONS
];
1157 mpz_t end
[GFC_MAX_DIMENSIONS
];
1158 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1159 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1160 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1166 gfc_constructor
*cons
;
1167 gfc_constructor
*base
;
1173 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1178 base
= expr
->value
.constructor
;
1179 expr
->value
.constructor
= NULL
;
1181 rank
= ref
->u
.ar
.as
->rank
;
1183 if (expr
->shape
== NULL
)
1184 expr
->shape
= gfc_get_shape (rank
);
1186 mpz_init_set_ui (delta_mpz
, one
);
1187 mpz_init_set_ui (nelts
, one
);
1190 /* Do the initialization now, so that we can cleanup without
1191 keeping track of where we were. */
1192 for (d
= 0; d
< rank
; d
++)
1194 mpz_init (delta
[d
]);
1195 mpz_init (start
[d
]);
1198 mpz_init (stride
[d
]);
1202 /* Build the counters to clock through the array reference. */
1204 for (d
= 0; d
< rank
; d
++)
1206 /* Make this stretch of code easier on the eye! */
1207 begin
= ref
->u
.ar
.start
[d
];
1208 finish
= ref
->u
.ar
.end
[d
];
1209 step
= ref
->u
.ar
.stride
[d
];
1210 lower
= ref
->u
.ar
.as
->lower
[d
];
1211 upper
= ref
->u
.ar
.as
->upper
[d
];
1213 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1217 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1223 gcc_assert (begin
->rank
== 1);
1224 /* Zero-sized arrays have no shape and no elements, stop early. */
1227 mpz_init_set_ui (nelts
, 0);
1231 vecsub
[d
] = begin
->value
.constructor
;
1232 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1233 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1234 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1237 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1239 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1240 || mpz_cmp (c
->expr
->value
.integer
,
1241 lower
->value
.integer
) < 0)
1243 gfc_error ("index in dimension %d is out of bounds "
1244 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1252 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1253 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1254 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1260 /* Obtain the stride. */
1262 mpz_set (stride
[d
], step
->value
.integer
);
1264 mpz_set_ui (stride
[d
], one
);
1266 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1267 mpz_set_ui (stride
[d
], one
);
1269 /* Obtain the start value for the index. */
1271 mpz_set (start
[d
], begin
->value
.integer
);
1273 mpz_set (start
[d
], lower
->value
.integer
);
1275 mpz_set (ctr
[d
], start
[d
]);
1277 /* Obtain the end value for the index. */
1279 mpz_set (end
[d
], finish
->value
.integer
);
1281 mpz_set (end
[d
], upper
->value
.integer
);
1283 /* Separate 'if' because elements sometimes arrive with
1285 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1286 mpz_set (end
[d
], begin
->value
.integer
);
1288 /* Check the bounds. */
1289 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1290 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1291 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1292 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1294 gfc_error ("index in dimension %d is out of bounds "
1295 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1300 /* Calculate the number of elements and the shape. */
1301 mpz_set (tmp_mpz
, stride
[d
]);
1302 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1303 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1304 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1305 mpz_mul (nelts
, nelts
, tmp_mpz
);
1307 /* An element reference reduces the rank of the expression; don't
1308 add anything to the shape array. */
1309 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1310 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1313 /* Calculate the 'stride' (=delta) for conversion of the
1314 counter values into the index along the constructor. */
1315 mpz_set (delta
[d
], delta_mpz
);
1316 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1317 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1318 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1325 /* Now clock through the array reference, calculating the index in
1326 the source constructor and transferring the elements to the new
1328 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1330 if (ref
->u
.ar
.offset
)
1331 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1333 mpz_init_set_ui (ptr
, 0);
1336 for (d
= 0; d
< rank
; d
++)
1338 mpz_set (tmp_mpz
, ctr
[d
]);
1339 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1340 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1341 mpz_add (ptr
, ptr
, tmp_mpz
);
1343 if (!incr_ctr
) continue;
1345 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1347 gcc_assert(vecsub
[d
]);
1349 if (!vecsub
[d
]->next
)
1350 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1353 vecsub
[d
] = vecsub
[d
]->next
;
1356 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1360 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1362 if (mpz_cmp_ui (stride
[d
], 0) > 0
1363 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1364 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1365 mpz_set (ctr
[d
], start
[d
]);
1371 /* There must be a better way of dealing with negative strides
1372 than resetting the index and the constructor pointer! */
1373 if (mpz_cmp (ptr
, index
) < 0)
1375 mpz_set_ui (index
, 0);
1379 while (cons
&& cons
->next
&& mpz_cmp (ptr
, index
) > 0)
1381 mpz_add_ui (index
, index
, one
);
1385 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1393 mpz_clear (delta_mpz
);
1394 mpz_clear (tmp_mpz
);
1396 for (d
= 0; d
< rank
; d
++)
1398 mpz_clear (delta
[d
]);
1399 mpz_clear (start
[d
]);
1402 mpz_clear (stride
[d
]);
1404 gfc_free_constructor (base
);
1408 /* Pull a substring out of an expression. */
1411 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1418 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1419 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1422 *newp
= gfc_copy_expr (p
);
1423 gfc_free ((*newp
)->value
.character
.string
);
1425 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1426 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1427 length
= end
- start
+ 1;
1429 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1430 (*newp
)->value
.character
.length
= length
;
1431 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1432 length
* sizeof (gfc_char_t
));
1439 /* Simplify a subobject reference of a constructor. This occurs when
1440 parameter variable values are substituted. */
1443 simplify_const_ref (gfc_expr
*p
)
1445 gfc_constructor
*cons
;
1450 switch (p
->ref
->type
)
1453 switch (p
->ref
->u
.ar
.type
)
1456 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1463 remove_subobject_ref (p
, cons
);
1467 if (find_array_section (p
, p
->ref
) == FAILURE
)
1469 p
->ref
->u
.ar
.type
= AR_FULL
;
1474 if (p
->ref
->next
!= NULL
1475 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1477 cons
= p
->value
.constructor
;
1478 for (; cons
; cons
= cons
->next
)
1480 cons
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1481 if (simplify_const_ref (cons
->expr
) == FAILURE
)
1485 /* If this is a CHARACTER array and we possibly took a
1486 substring out of it, update the type-spec's character
1487 length according to the first element (as all should have
1488 the same length). */
1489 if (p
->ts
.type
== BT_CHARACTER
)
1493 gcc_assert (p
->ref
->next
);
1494 gcc_assert (!p
->ref
->next
->next
);
1495 gcc_assert (p
->ref
->next
->type
== REF_SUBSTRING
);
1497 if (p
->value
.constructor
)
1499 const gfc_expr
* first
= p
->value
.constructor
->expr
;
1500 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1501 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1502 string_len
= first
->value
.character
.length
;
1509 p
->ts
.cl
= gfc_get_charlen ();
1510 p
->ts
.cl
->next
= NULL
;
1511 p
->ts
.cl
->length
= NULL
;
1513 gfc_free_expr (p
->ts
.cl
->length
);
1514 p
->ts
.cl
->length
= gfc_int_expr (string_len
);
1517 gfc_free_ref_list (p
->ref
);
1528 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1529 remove_subobject_ref (p
, cons
);
1533 if (find_substring_ref (p
, &newp
) == FAILURE
)
1536 gfc_replace_expr (p
, newp
);
1537 gfc_free_ref_list (p
->ref
);
1547 /* Simplify a chain of references. */
1550 simplify_ref_chain (gfc_ref
*ref
, int type
)
1554 for (; ref
; ref
= ref
->next
)
1559 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1561 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1563 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1565 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1571 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1573 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1585 /* Try to substitute the value of a parameter variable. */
1588 simplify_parameter_variable (gfc_expr
*p
, int type
)
1593 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1599 /* Do not copy subobject refs for constant. */
1600 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1601 e
->ref
= gfc_copy_ref (p
->ref
);
1602 t
= gfc_simplify_expr (e
, type
);
1604 /* Only use the simplification if it eliminated all subobject references. */
1605 if (t
== SUCCESS
&& !e
->ref
)
1606 gfc_replace_expr (p
, e
);
1613 /* Given an expression, simplify it by collapsing constant
1614 expressions. Most simplification takes place when the expression
1615 tree is being constructed. If an intrinsic function is simplified
1616 at some point, we get called again to collapse the result against
1619 We work by recursively simplifying expression nodes, simplifying
1620 intrinsic functions where possible, which can lead to further
1621 constant collapsing. If an operator has constant operand(s), we
1622 rip the expression apart, and rebuild it, hoping that it becomes
1625 The expression type is defined for:
1626 0 Basic expression parsing
1627 1 Simplifying array constructors -- will substitute
1629 Returns FAILURE on error, SUCCESS otherwise.
1630 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1633 gfc_simplify_expr (gfc_expr
*p
, int type
)
1635 gfc_actual_arglist
*ap
;
1640 switch (p
->expr_type
)
1647 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1648 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1651 if (p
->value
.function
.isym
!= NULL
1652 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1657 case EXPR_SUBSTRING
:
1658 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1661 if (gfc_is_constant_expr (p
))
1667 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1669 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1670 start
--; /* Convert from one-based to zero-based. */
1673 end
= p
->value
.character
.length
;
1674 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1675 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1677 s
= gfc_get_wide_string (end
- start
+ 2);
1678 memcpy (s
, p
->value
.character
.string
+ start
,
1679 (end
- start
) * sizeof (gfc_char_t
));
1680 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1681 gfc_free (p
->value
.character
.string
);
1682 p
->value
.character
.string
= s
;
1683 p
->value
.character
.length
= end
- start
;
1684 p
->ts
.cl
= gfc_get_charlen ();
1685 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1686 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1687 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1688 gfc_free_ref_list (p
->ref
);
1690 p
->expr_type
= EXPR_CONSTANT
;
1695 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1700 /* Only substitute array parameter variables if we are in an
1701 initialization expression, or we want a subsection. */
1702 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1703 && (gfc_init_expr
|| p
->ref
1704 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1706 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1713 gfc_simplify_iterator_var (p
);
1716 /* Simplify subcomponent references. */
1717 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1722 case EXPR_STRUCTURE
:
1724 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1727 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1730 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1731 && p
->ref
->u
.ar
.type
== AR_FULL
)
1732 gfc_expand_constructor (p
);
1734 if (simplify_const_ref (p
) == FAILURE
)
1749 /* Returns the type of an expression with the exception that iterator
1750 variables are automatically integers no matter what else they may
1756 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1763 /* Check an intrinsic arithmetic operation to see if it is consistent
1764 with some type of expression. */
1766 static gfc_try
check_init_expr (gfc_expr
*);
1769 /* Scalarize an expression for an elemental intrinsic call. */
1772 scalarize_intrinsic_call (gfc_expr
*e
)
1774 gfc_actual_arglist
*a
, *b
;
1775 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1776 gfc_expr
*expr
, *old
;
1777 int n
, i
, rank
[5], array_arg
;
1779 /* Find which, if any, arguments are arrays. Assume that the old
1780 expression carries the type information and that the first arg
1781 that is an array expression carries all the shape information.*/
1783 a
= e
->value
.function
.actual
;
1784 for (; a
; a
= a
->next
)
1787 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1790 expr
= gfc_copy_expr (a
->expr
);
1797 old
= gfc_copy_expr (e
);
1799 gfc_free_constructor (expr
->value
.constructor
);
1800 expr
->value
.constructor
= NULL
;
1803 expr
->where
= old
->where
;
1804 expr
->expr_type
= EXPR_ARRAY
;
1806 /* Copy the array argument constructors into an array, with nulls
1809 a
= old
->value
.function
.actual
;
1810 for (; a
; a
= a
->next
)
1812 /* Check that this is OK for an initialization expression. */
1813 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1817 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1819 rank
[n
] = a
->expr
->rank
;
1820 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1821 args
[n
] = gfc_copy_constructor (ctor
);
1823 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1826 rank
[n
] = a
->expr
->rank
;
1829 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1837 /* Using the array argument as the master, step through the array
1838 calling the function for each element and advancing the array
1839 constructors together. */
1840 ctor
= args
[array_arg
- 1];
1842 for (; ctor
; ctor
= ctor
->next
)
1844 if (expr
->value
.constructor
== NULL
)
1845 expr
->value
.constructor
1846 = new_ctor
= gfc_get_constructor ();
1849 new_ctor
->next
= gfc_get_constructor ();
1850 new_ctor
= new_ctor
->next
;
1852 new_ctor
->expr
= gfc_copy_expr (old
);
1853 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1855 b
= old
->value
.function
.actual
;
1856 for (i
= 0; i
< n
; i
++)
1859 new_ctor
->expr
->value
.function
.actual
1860 = a
= gfc_get_actual_arglist ();
1863 a
->next
= gfc_get_actual_arglist ();
1867 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1869 a
->expr
= gfc_copy_expr (b
->expr
);
1874 /* Simplify the function calls. If the simplification fails, the
1875 error will be flagged up down-stream or the library will deal
1877 gfc_simplify_expr (new_ctor
->expr
, 0);
1879 for (i
= 0; i
< n
; i
++)
1881 args
[i
] = args
[i
]->next
;
1883 for (i
= 1; i
< n
; i
++)
1884 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
1885 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
1891 gfc_free_expr (old
);
1895 gfc_error_now ("elemental function arguments at %C are not compliant");
1898 gfc_free_expr (expr
);
1899 gfc_free_expr (old
);
1905 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
1907 gfc_expr
*op1
= e
->value
.op
.op1
;
1908 gfc_expr
*op2
= e
->value
.op
.op2
;
1910 if ((*check_function
) (op1
) == FAILURE
)
1913 switch (e
->value
.op
.op
)
1915 case INTRINSIC_UPLUS
:
1916 case INTRINSIC_UMINUS
:
1917 if (!numeric_type (et0 (op1
)))
1922 case INTRINSIC_EQ_OS
:
1924 case INTRINSIC_NE_OS
:
1926 case INTRINSIC_GT_OS
:
1928 case INTRINSIC_GE_OS
:
1930 case INTRINSIC_LT_OS
:
1932 case INTRINSIC_LE_OS
:
1933 if ((*check_function
) (op2
) == FAILURE
)
1936 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1937 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1939 gfc_error ("Numeric or CHARACTER operands are required in "
1940 "expression at %L", &e
->where
);
1945 case INTRINSIC_PLUS
:
1946 case INTRINSIC_MINUS
:
1947 case INTRINSIC_TIMES
:
1948 case INTRINSIC_DIVIDE
:
1949 case INTRINSIC_POWER
:
1950 if ((*check_function
) (op2
) == FAILURE
)
1953 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1958 case INTRINSIC_CONCAT
:
1959 if ((*check_function
) (op2
) == FAILURE
)
1962 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1964 gfc_error ("Concatenation operator in expression at %L "
1965 "must have two CHARACTER operands", &op1
->where
);
1969 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1971 gfc_error ("Concat operator at %L must concatenate strings of the "
1972 "same kind", &e
->where
);
1979 if (et0 (op1
) != BT_LOGICAL
)
1981 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1982 "operand", &op1
->where
);
1991 case INTRINSIC_NEQV
:
1992 if ((*check_function
) (op2
) == FAILURE
)
1995 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1997 gfc_error ("LOGICAL operands are required in expression at %L",
2004 case INTRINSIC_PARENTHESES
:
2008 gfc_error ("Only intrinsic operators can be used in expression at %L",
2016 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2023 check_init_expr_arguments (gfc_expr
*e
)
2025 gfc_actual_arglist
*ap
;
2027 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2028 if (check_init_expr (ap
->expr
) == FAILURE
)
2034 static gfc_try
check_restricted (gfc_expr
*);
2036 /* F95, 7.1.6.1, Initialization expressions, (7)
2037 F2003, 7.1.7 Initialization expression, (8) */
2040 check_inquiry (gfc_expr
*e
, int not_restricted
)
2043 const char *const *functions
;
2045 static const char *const inquiry_func_f95
[] = {
2046 "lbound", "shape", "size", "ubound",
2047 "bit_size", "len", "kind",
2048 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2049 "precision", "radix", "range", "tiny",
2053 static const char *const inquiry_func_f2003
[] = {
2054 "lbound", "shape", "size", "ubound",
2055 "bit_size", "len", "kind",
2056 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2057 "precision", "radix", "range", "tiny",
2062 gfc_actual_arglist
*ap
;
2064 if (!e
->value
.function
.isym
2065 || !e
->value
.function
.isym
->inquiry
)
2068 /* An undeclared parameter will get us here (PR25018). */
2069 if (e
->symtree
== NULL
)
2072 name
= e
->symtree
->n
.sym
->name
;
2074 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2075 ? inquiry_func_f2003
: inquiry_func_f95
;
2077 for (i
= 0; functions
[i
]; i
++)
2078 if (strcmp (functions
[i
], name
) == 0)
2081 if (functions
[i
] == NULL
)
2084 /* At this point we have an inquiry function with a variable argument. The
2085 type of the variable might be undefined, but we need it now, because the
2086 arguments of these functions are not allowed to be undefined. */
2088 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2093 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2095 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2096 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2100 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2103 /* Assumed character length will not reduce to a constant expression
2104 with LEN, as required by the standard. */
2105 if (i
== 5 && not_restricted
2106 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2107 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2109 gfc_error ("Assumed character length variable '%s' in constant "
2110 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2113 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2116 if (not_restricted
== 0
2117 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2118 && check_restricted (ap
->expr
) == FAILURE
)
2126 /* F95, 7.1.6.1, Initialization expressions, (5)
2127 F2003, 7.1.7 Initialization expression, (5) */
2130 check_transformational (gfc_expr
*e
)
2132 static const char * const trans_func_f95
[] = {
2133 "repeat", "reshape", "selected_int_kind",
2134 "selected_real_kind", "transfer", "trim", NULL
2137 static const char * const trans_func_f2003
[] = {
2138 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2139 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2140 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2141 "trim", "unpack", NULL
2146 const char *const *functions
;
2148 if (!e
->value
.function
.isym
2149 || !e
->value
.function
.isym
->transformational
)
2152 name
= e
->symtree
->n
.sym
->name
;
2154 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2155 ? trans_func_f2003
: trans_func_f95
;
2157 /* NULL() is dealt with below. */
2158 if (strcmp ("null", name
) == 0)
2161 for (i
= 0; functions
[i
]; i
++)
2162 if (strcmp (functions
[i
], name
) == 0)
2165 if (functions
[i
] == NULL
)
2167 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2168 "in an initialization expression", name
, &e
->where
);
2172 return check_init_expr_arguments (e
);
2176 /* F95, 7.1.6.1, Initialization expressions, (6)
2177 F2003, 7.1.7 Initialization expression, (6) */
2180 check_null (gfc_expr
*e
)
2182 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2185 return check_init_expr_arguments (e
);
2190 check_elemental (gfc_expr
*e
)
2192 if (!e
->value
.function
.isym
2193 || !e
->value
.function
.isym
->elemental
)
2196 if (e
->ts
.type
!= BT_INTEGER
2197 && e
->ts
.type
!= BT_CHARACTER
2198 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2199 "nonstandard initialization expression at %L",
2200 &e
->where
) == FAILURE
)
2203 return check_init_expr_arguments (e
);
2208 check_conversion (gfc_expr
*e
)
2210 if (!e
->value
.function
.isym
2211 || !e
->value
.function
.isym
->conversion
)
2214 return check_init_expr_arguments (e
);
2218 /* Verify that an expression is an initialization expression. A side
2219 effect is that the expression tree is reduced to a single constant
2220 node if all goes well. This would normally happen when the
2221 expression is constructed but function references are assumed to be
2222 intrinsics in the context of initialization expressions. If
2223 FAILURE is returned an error message has been generated. */
2226 check_init_expr (gfc_expr
*e
)
2234 switch (e
->expr_type
)
2237 t
= check_intrinsic_op (e
, check_init_expr
);
2239 t
= gfc_simplify_expr (e
, 0);
2246 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2248 gfc_intrinsic_sym
* isym
;
2251 sym
= e
->symtree
->n
.sym
;
2252 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2253 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2255 gfc_error ("Function '%s' in initialization expression at %L "
2256 "must be an intrinsic or a specification function",
2257 e
->symtree
->n
.sym
->name
, &e
->where
);
2261 if ((m
= check_conversion (e
)) == MATCH_NO
2262 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2263 && (m
= check_null (e
)) == MATCH_NO
2264 && (m
= check_transformational (e
)) == MATCH_NO
2265 && (m
= check_elemental (e
)) == MATCH_NO
)
2267 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2268 "in an initialization expression",
2269 e
->symtree
->n
.sym
->name
, &e
->where
);
2273 /* Try to scalarize an elemental intrinsic function that has an
2275 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2276 if (isym
&& isym
->elemental
2277 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2282 t
= gfc_simplify_expr (e
, 0);
2289 if (gfc_check_iter_variable (e
) == SUCCESS
)
2292 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2294 /* A PARAMETER shall not be used to define itself, i.e.
2295 REAL, PARAMETER :: x = transfer(0, x)
2297 if (!e
->symtree
->n
.sym
->value
)
2299 gfc_error("PARAMETER '%s' is used at %L before its definition "
2300 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2304 t
= simplify_parameter_variable (e
, 0);
2309 if (gfc_in_match_data ())
2314 if (e
->symtree
->n
.sym
->as
)
2316 switch (e
->symtree
->n
.sym
->as
->type
)
2318 case AS_ASSUMED_SIZE
:
2319 gfc_error ("Assumed size array '%s' at %L is not permitted "
2320 "in an initialization expression",
2321 e
->symtree
->n
.sym
->name
, &e
->where
);
2324 case AS_ASSUMED_SHAPE
:
2325 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2326 "in an initialization expression",
2327 e
->symtree
->n
.sym
->name
, &e
->where
);
2331 gfc_error ("Deferred array '%s' at %L is not permitted "
2332 "in an initialization expression",
2333 e
->symtree
->n
.sym
->name
, &e
->where
);
2337 gfc_error ("Array '%s' at %L is a variable, which does "
2338 "not reduce to a constant expression",
2339 e
->symtree
->n
.sym
->name
, &e
->where
);
2347 gfc_error ("Parameter '%s' at %L has not been declared or is "
2348 "a variable, which does not reduce to a constant "
2349 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2358 case EXPR_SUBSTRING
:
2359 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2363 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2365 t
= gfc_simplify_expr (e
, 0);
2369 case EXPR_STRUCTURE
:
2373 t
= gfc_check_constructor (e
, check_init_expr
);
2377 t
= gfc_check_constructor (e
, check_init_expr
);
2381 t
= gfc_expand_constructor (e
);
2385 t
= gfc_check_constructor_type (e
);
2389 gfc_internal_error ("check_init_expr(): Unknown expression type");
2395 /* Reduces a general expression to an initialization expression (a constant).
2396 This used to be part of gfc_match_init_expr.
2397 Note that this function doesn't free the given expression on FAILURE. */
2400 gfc_reduce_init_expr (gfc_expr
*expr
)
2405 t
= gfc_resolve_expr (expr
);
2407 t
= check_init_expr (expr
);
2413 if (expr
->expr_type
== EXPR_ARRAY
2414 && (gfc_check_constructor_type (expr
) == FAILURE
2415 || gfc_expand_constructor (expr
) == FAILURE
))
2418 /* Not all inquiry functions are simplified to constant expressions
2419 so it is necessary to call check_inquiry again. */
2420 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2421 && !gfc_in_match_data ())
2423 gfc_error ("Initialization expression didn't reduce %C");
2431 /* Match an initialization expression. We work by first matching an
2432 expression, then reducing it to a constant. The reducing it to
2433 constant part requires a global variable to flag the prohibition
2434 of a non-integer exponent in -std=f95 mode. */
2436 bool init_flag
= false;
2439 gfc_match_init_expr (gfc_expr
**result
)
2449 m
= gfc_match_expr (&expr
);
2456 t
= gfc_reduce_init_expr (expr
);
2459 gfc_free_expr (expr
);
2471 /* Given an actual argument list, test to see that each argument is a
2472 restricted expression and optionally if the expression type is
2473 integer or character. */
2476 restricted_args (gfc_actual_arglist
*a
)
2478 for (; a
; a
= a
->next
)
2480 if (check_restricted (a
->expr
) == FAILURE
)
2488 /************* Restricted/specification expressions *************/
2491 /* Make sure a non-intrinsic function is a specification function. */
2494 external_spec_function (gfc_expr
*e
)
2498 f
= e
->value
.function
.esym
;
2500 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2502 gfc_error ("Specification function '%s' at %L cannot be a statement "
2503 "function", f
->name
, &e
->where
);
2507 if (f
->attr
.proc
== PROC_INTERNAL
)
2509 gfc_error ("Specification function '%s' at %L cannot be an internal "
2510 "function", f
->name
, &e
->where
);
2514 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2516 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2521 if (f
->attr
.recursive
)
2523 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2524 f
->name
, &e
->where
);
2528 return restricted_args (e
->value
.function
.actual
);
2532 /* Check to see that a function reference to an intrinsic is a
2533 restricted expression. */
2536 restricted_intrinsic (gfc_expr
*e
)
2538 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2539 if (check_inquiry (e
, 0) == MATCH_YES
)
2542 return restricted_args (e
->value
.function
.actual
);
2546 /* Check the expressions of an actual arglist. Used by check_restricted. */
2549 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2551 for (; arg
; arg
= arg
->next
)
2552 if (checker (arg
->expr
) == FAILURE
)
2559 /* Check the subscription expressions of a reference chain with a checking
2560 function; used by check_restricted. */
2563 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2573 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2575 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2577 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2579 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2585 /* Nothing needed, just proceed to next reference. */
2589 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2591 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2600 return check_references (ref
->next
, checker
);
2604 /* Verify that an expression is a restricted expression. Like its
2605 cousin check_init_expr(), an error message is generated if we
2609 check_restricted (gfc_expr
*e
)
2617 switch (e
->expr_type
)
2620 t
= check_intrinsic_op (e
, check_restricted
);
2622 t
= gfc_simplify_expr (e
, 0);
2627 if (e
->value
.function
.esym
)
2629 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2631 t
= external_spec_function (e
);
2635 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2638 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2641 t
= restricted_intrinsic (e
);
2646 sym
= e
->symtree
->n
.sym
;
2649 /* If a dummy argument appears in a context that is valid for a
2650 restricted expression in an elemental procedure, it will have
2651 already been simplified away once we get here. Therefore we
2652 don't need to jump through hoops to distinguish valid from
2654 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2655 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2657 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2658 sym
->name
, &e
->where
);
2662 if (sym
->attr
.optional
)
2664 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2665 sym
->name
, &e
->where
);
2669 if (sym
->attr
.intent
== INTENT_OUT
)
2671 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2672 sym
->name
, &e
->where
);
2676 /* Check reference chain if any. */
2677 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2680 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2681 processed in resolve.c(resolve_formal_arglist). This is done so
2682 that host associated dummy array indices are accepted (PR23446).
2683 This mechanism also does the same for the specification expressions
2684 of array-valued functions. */
2686 || sym
->attr
.in_common
2687 || sym
->attr
.use_assoc
2689 || sym
->attr
.implied_index
2690 || sym
->attr
.flavor
== FL_PARAMETER
2691 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2692 || (sym
->ns
&& gfc_current_ns
->parent
2693 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2694 || (sym
->ns
->proc_name
!= NULL
2695 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2696 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2702 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2703 sym
->name
, &e
->where
);
2704 /* Prevent a repetition of the error. */
2713 case EXPR_SUBSTRING
:
2714 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2718 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2720 t
= gfc_simplify_expr (e
, 0);
2724 case EXPR_STRUCTURE
:
2725 t
= gfc_check_constructor (e
, check_restricted
);
2729 t
= gfc_check_constructor (e
, check_restricted
);
2733 gfc_internal_error ("check_restricted(): Unknown expression type");
2740 /* Check to see that an expression is a specification expression. If
2741 we return FAILURE, an error has been generated. */
2744 gfc_specification_expr (gfc_expr
*e
)
2750 if (e
->ts
.type
!= BT_INTEGER
)
2752 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2753 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2757 if (e
->expr_type
== EXPR_FUNCTION
2758 && !e
->value
.function
.isym
2759 && !e
->value
.function
.esym
2760 && !gfc_pure (e
->symtree
->n
.sym
))
2762 gfc_error ("Function '%s' at %L must be PURE",
2763 e
->symtree
->n
.sym
->name
, &e
->where
);
2764 /* Prevent repeat error messages. */
2765 e
->symtree
->n
.sym
->attr
.pure
= 1;
2771 gfc_error ("Expression at %L must be scalar", &e
->where
);
2775 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2778 return check_restricted (e
);
2782 /************** Expression conformance checks. *************/
2784 /* Given two expressions, make sure that the arrays are conformable. */
2787 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
2789 int op1_flag
, op2_flag
, d
;
2790 mpz_t op1_size
, op2_size
;
2796 if (op1
->rank
== 0 || op2
->rank
== 0)
2799 va_start (argp
, optype_msgid
);
2800 vsnprintf (buffer
, 240, optype_msgid
, argp
);
2803 if (op1
->rank
!= op2
->rank
)
2805 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
2806 op1
->rank
, op2
->rank
, &op1
->where
);
2812 for (d
= 0; d
< op1
->rank
; d
++)
2814 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2815 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2817 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2819 gfc_error ("Different shape for %s at %L on dimension %d "
2820 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
2821 (int) mpz_get_si (op1_size
),
2822 (int) mpz_get_si (op2_size
));
2828 mpz_clear (op1_size
);
2830 mpz_clear (op2_size
);
2840 /* Given an assignable expression and an arbitrary expression, make
2841 sure that the assignment can take place. */
2844 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2850 sym
= lvalue
->symtree
->n
.sym
;
2852 /* Check INTENT(IN), unless the object itself is the component or
2853 sub-component of a pointer. */
2854 has_pointer
= sym
->attr
.pointer
;
2856 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2857 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
2863 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2865 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2866 sym
->name
, &lvalue
->where
);
2870 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2871 variable local to a function subprogram. Its existence begins when
2872 execution of the function is initiated and ends when execution of the
2873 function is terminated...
2874 Therefore, the left hand side is no longer a variable, when it is: */
2875 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2876 && !sym
->attr
.external
)
2881 /* (i) Use associated; */
2882 if (sym
->attr
.use_assoc
)
2885 /* (ii) The assignment is in the main program; or */
2886 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2889 /* (iii) A module or internal procedure... */
2890 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2891 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2892 && gfc_current_ns
->parent
2893 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2894 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2895 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2897 /* ... that is not a function... */
2898 if (!gfc_current_ns
->proc_name
->attr
.function
)
2901 /* ... or is not an entry and has a different name. */
2902 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2906 /* (iv) Host associated and not the function symbol or the
2907 parent result. This picks up sibling references, which
2908 cannot be entries. */
2909 if (!sym
->attr
.entry
2910 && sym
->ns
== gfc_current_ns
->parent
2911 && sym
!= gfc_current_ns
->proc_name
2912 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
2917 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2922 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2924 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2925 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2929 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2931 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2936 if (rvalue
->expr_type
== EXPR_NULL
)
2938 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
2939 && lvalue
->symtree
->n
.sym
->attr
.data
)
2943 gfc_error ("NULL appears on right-hand side in assignment at %L",
2949 if (sym
->attr
.cray_pointee
2950 && lvalue
->ref
!= NULL
2951 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2952 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2954 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2955 "is illegal", &lvalue
->where
);
2959 /* This is possibly a typo: x = f() instead of x => f(). */
2960 if (gfc_option
.warn_surprising
2961 && rvalue
->expr_type
== EXPR_FUNCTION
2962 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2963 gfc_warning ("POINTER valued function appears on right-hand side of "
2964 "assignment at %L", &rvalue
->where
);
2966 /* Check size of array assignments. */
2967 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2968 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
2971 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
2972 && lvalue
->symtree
->n
.sym
->attr
.data
2973 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
2974 "initialize non-integer variable '%s'",
2975 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
2978 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
2979 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
2980 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2981 &rvalue
->where
) == FAILURE
)
2984 /* Handle the case of a BOZ literal on the RHS. */
2985 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
2988 if (gfc_option
.warn_surprising
)
2989 gfc_warning ("BOZ literal at %L is bitwise transferred "
2990 "non-integer symbol '%s'", &rvalue
->where
,
2991 lvalue
->symtree
->n
.sym
->name
);
2992 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
2994 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
2996 if (rc
== ARITH_UNDERFLOW
)
2997 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2998 ". This check can be disabled with the option "
2999 "-fno-range-check", &rvalue
->where
);
3000 else if (rc
== ARITH_OVERFLOW
)
3001 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3002 ". This check can be disabled with the option "
3003 "-fno-range-check", &rvalue
->where
);
3004 else if (rc
== ARITH_NAN
)
3005 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3006 ". This check can be disabled with the option "
3007 "-fno-range-check", &rvalue
->where
);
3012 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3015 /* Only DATA Statements come here. */
3018 /* Numeric can be converted to any other numeric. And Hollerith can be
3019 converted to any other type. */
3020 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3021 || rvalue
->ts
.type
== BT_HOLLERITH
)
3024 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3027 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3028 "conversion of %s to %s", &lvalue
->where
,
3029 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3034 /* Assignment is the only case where character variables of different
3035 kind values can be converted into one another. */
3036 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3038 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3039 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3044 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3048 /* Check that a pointer assignment is OK. We first check lvalue, and
3049 we only check rvalue if it's not an assignment to NULL() or a
3050 NULLIFY statement. */
3053 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3055 symbol_attribute attr
;
3058 int pointer
, check_intent_in
, proc_pointer
;
3060 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3061 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3063 gfc_error ("Pointer assignment target is not a POINTER at %L",
3068 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3069 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3070 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3072 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3073 "l-value since it is a procedure",
3074 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3079 /* Check INTENT(IN), unless the object itself is the component or
3080 sub-component of a pointer. */
3081 check_intent_in
= 1;
3082 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
3083 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3085 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3088 check_intent_in
= 0;
3090 if (ref
->type
== REF_COMPONENT
)
3092 pointer
= ref
->u
.c
.component
->attr
.pointer
;
3093 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3096 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3098 if (ref
->u
.ar
.type
== AR_FULL
)
3101 if (ref
->u
.ar
.type
!= AR_SECTION
)
3103 gfc_error ("Expected bounds specification for '%s' at %L",
3104 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3108 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3109 "specification for '%s' in pointer assignment "
3110 "at %L", lvalue
->symtree
->n
.sym
->name
,
3111 &lvalue
->where
) == FAILURE
)
3114 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3115 "in gfortran", &lvalue
->where
);
3116 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3117 either never or always the upper-bound; strides shall not be
3123 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3125 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3126 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3130 if (!pointer
&& !proc_pointer
)
3132 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
3136 is_pure
= gfc_pure (NULL
);
3138 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
3139 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
3141 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
3145 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3146 kind, etc for lvalue and rvalue must match, and rvalue must be a
3147 pure variable if we're in a pure function. */
3148 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3151 /* Checks on rvalue for procedure pointer assignments. */
3155 attr
= gfc_expr_attr (rvalue
);
3156 if (!((rvalue
->expr_type
== EXPR_NULL
)
3157 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3158 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3159 || (rvalue
->expr_type
== EXPR_VARIABLE
3160 && attr
.flavor
== FL_PROCEDURE
)))
3162 gfc_error ("Invalid procedure pointer assignment at %L",
3168 gfc_error ("Abstract interface '%s' is invalid "
3169 "in procedure pointer assignment at %L",
3170 rvalue
->symtree
->name
, &rvalue
->where
);
3173 /* Check for C727. */
3174 if (attr
.flavor
== FL_PROCEDURE
)
3176 if (attr
.proc
== PROC_ST_FUNCTION
)
3178 gfc_error ("Statement function '%s' is invalid "
3179 "in procedure pointer assignment at %L",
3180 rvalue
->symtree
->name
, &rvalue
->where
);
3183 if (attr
.proc
== PROC_INTERNAL
&&
3184 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3185 "invalid in procedure pointer assignment at %L",
3186 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3190 /* Ensure that the calling convention is the same. As other attributes
3191 such as DLLEXPORT may differ, one explicitly only tests for the
3192 calling conventions. */
3193 if (rvalue
->expr_type
== EXPR_VARIABLE
3194 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3195 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3197 symbol_attribute
cdecl, stdcall, fastcall
;
3200 gfc_add_ext_attribute (&cdecl, (unsigned) EXT_ATTR_CDECL
, NULL
);
3201 gfc_add_ext_attribute (&stdcall, (unsigned) EXT_ATTR_STDCALL
, NULL
);
3202 gfc_add_ext_attribute (&fastcall
, (unsigned) EXT_ATTR_FASTCALL
, NULL
);
3203 calls
= cdecl.ext_attr
| stdcall.ext_attr
| fastcall
.ext_attr
;
3205 if ((calls
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3206 != (calls
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3208 gfc_error ("Mismatch in the procedure pointer assignment "
3209 "at %L: mismatch in the calling convention",
3215 /* TODO: Enable interface check for PPCs. */
3216 if (gfc_is_proc_ptr_comp (rvalue
, NULL
))
3218 if ((rvalue
->expr_type
== EXPR_VARIABLE
3219 && !gfc_compare_interfaces (lvalue
->symtree
->n
.sym
,
3220 rvalue
->symtree
->n
.sym
, 0, 1, err
,
3222 || (rvalue
->expr_type
== EXPR_FUNCTION
3223 && !gfc_compare_interfaces (lvalue
->symtree
->n
.sym
,
3224 rvalue
->symtree
->n
.sym
->result
, 0, 1,
3227 gfc_error ("Interface mismatch in procedure pointer assignment "
3228 "at %L: %s", &rvalue
->where
, err
);
3234 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3236 gfc_error ("Different types in pointer assignment at %L; attempted "
3237 "assignment of %s to %s", &lvalue
->where
,
3238 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3242 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3244 gfc_error ("Different kind type parameters in pointer "
3245 "assignment at %L", &lvalue
->where
);
3249 if (lvalue
->rank
!= rvalue
->rank
)
3251 gfc_error ("Different ranks in pointer assignment at %L",
3256 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3257 if (rvalue
->expr_type
== EXPR_NULL
)
3260 if (lvalue
->ts
.type
== BT_CHARACTER
)
3262 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3267 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3268 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3270 attr
= gfc_expr_attr (rvalue
);
3271 if (!attr
.target
&& !attr
.pointer
)
3273 gfc_error ("Pointer assignment target is neither TARGET "
3274 "nor POINTER at %L", &rvalue
->where
);
3278 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3280 gfc_error ("Bad target in pointer assignment in PURE "
3281 "procedure at %L", &rvalue
->where
);
3284 if (gfc_has_vector_index (rvalue
))
3286 gfc_error ("Pointer assignment with vector subscript "
3287 "on rhs at %L", &rvalue
->where
);
3291 if (attr
.is_protected
&& attr
.use_assoc
3292 && !(attr
.pointer
|| attr
.proc_pointer
))
3294 gfc_error ("Pointer assignment target has PROTECTED "
3295 "attribute at %L", &rvalue
->where
);
3303 /* Relative of gfc_check_assign() except that the lvalue is a single
3304 symbol. Used for initialization assignments. */
3307 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3312 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3314 lvalue
.expr_type
= EXPR_VARIABLE
;
3315 lvalue
.ts
= sym
->ts
;
3317 lvalue
.rank
= sym
->as
->rank
;
3318 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
3319 lvalue
.symtree
->n
.sym
= sym
;
3320 lvalue
.where
= sym
->declared_at
;
3322 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
)
3323 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3325 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3327 gfc_free (lvalue
.symtree
);
3333 /* Get an expression for a default initializer. */
3336 gfc_default_initializer (gfc_typespec
*ts
)
3338 gfc_constructor
*tail
;
3342 /* See if we have a default initializer. */
3343 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3344 if (c
->initializer
|| c
->attr
.allocatable
)
3350 /* Build the constructor. */
3351 init
= gfc_get_expr ();
3352 init
->expr_type
= EXPR_STRUCTURE
;
3354 init
->where
= ts
->derived
->declared_at
;
3357 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3360 init
->value
.constructor
= tail
= gfc_get_constructor ();
3363 tail
->next
= gfc_get_constructor ();
3368 tail
->expr
= gfc_copy_expr (c
->initializer
);
3370 if (c
->attr
.allocatable
)
3372 tail
->expr
= gfc_get_expr ();
3373 tail
->expr
->expr_type
= EXPR_NULL
;
3374 tail
->expr
->ts
= c
->ts
;
3381 /* Given a symbol, create an expression node with that symbol as a
3382 variable. If the symbol is array valued, setup a reference of the
3386 gfc_get_variable_expr (gfc_symtree
*var
)
3390 e
= gfc_get_expr ();
3391 e
->expr_type
= EXPR_VARIABLE
;
3393 e
->ts
= var
->n
.sym
->ts
;
3395 if (var
->n
.sym
->as
!= NULL
)
3397 e
->rank
= var
->n
.sym
->as
->rank
;
3398 e
->ref
= gfc_get_ref ();
3399 e
->ref
->type
= REF_ARRAY
;
3400 e
->ref
->u
.ar
.type
= AR_FULL
;
3407 /* General expression traversal function. */
3410 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3411 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3416 gfc_actual_arglist
*args
;
3423 if ((*func
) (expr
, sym
, &f
))
3426 if (expr
->ts
.type
== BT_CHARACTER
3428 && expr
->ts
.cl
->length
3429 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3430 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3433 switch (expr
->expr_type
)
3436 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3438 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3446 case EXPR_SUBSTRING
:
3449 case EXPR_STRUCTURE
:
3451 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3453 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3457 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3459 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3461 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3463 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3470 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3472 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3488 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3490 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3492 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3494 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3500 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3502 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3507 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3508 && ref
->u
.c
.component
->ts
.cl
3509 && ref
->u
.c
.component
->ts
.cl
->length
3510 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3512 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3516 if (ref
->u
.c
.component
->as
)
3517 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3519 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3522 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3536 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3539 expr_set_symbols_referenced (gfc_expr
*expr
,
3540 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3541 int *f ATTRIBUTE_UNUSED
)
3543 if (expr
->expr_type
!= EXPR_VARIABLE
)
3545 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3550 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3552 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
3556 /* Determine if an expression is a procedure pointer component. If yes, the
3557 argument 'comp' will point to the component (provided that 'comp' was
3561 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
3566 if (!expr
|| !expr
->ref
)
3573 if (ref
->type
== REF_COMPONENT
)
3575 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
3577 *comp
= ref
->u
.c
.component
;
3584 /* Walk an expression tree and check each variable encountered for being typed.
3585 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3586 mode as is a basic arithmetic expression using those; this is for things in
3589 INTEGER :: arr(n), n
3590 INTEGER :: arr(n + 1), n
3592 The namespace is needed for IMPLICIT typing. */
3594 static gfc_namespace
* check_typed_ns
;
3597 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3598 int* f ATTRIBUTE_UNUSED
)
3602 if (e
->expr_type
!= EXPR_VARIABLE
)
3605 gcc_assert (e
->symtree
);
3606 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
3609 return (t
== FAILURE
);
3613 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
3617 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3621 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
3622 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
3624 if (e
->expr_type
== EXPR_OP
)
3626 gfc_try t
= SUCCESS
;
3628 gcc_assert (e
->value
.op
.op1
);
3629 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
3631 if (t
== SUCCESS
&& e
->value
.op
.op2
)
3632 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
3638 /* Otherwise, walk the expression and do it strictly. */
3639 check_typed_ns
= ns
;
3640 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
3642 return error_found
? FAILURE
: SUCCESS
;
3645 /* Walk an expression tree and replace all symbols with a corresponding symbol
3646 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3647 statements. The boolean return value is required by gfc_traverse_expr. */
3650 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3652 if ((expr
->expr_type
== EXPR_VARIABLE
3653 || (expr
->expr_type
== EXPR_FUNCTION
3654 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
3655 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
3658 gfc_namespace
*ns
= sym
->formal_ns
;
3659 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3660 the symtree rather than create a new one (and probably fail later). */
3661 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
3662 expr
->symtree
->n
.sym
->name
);
3664 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
3665 expr
->symtree
= stree
;
3671 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
3673 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
3676 /* The following is analogous to 'replace_symbol', and needed for copying
3677 interfaces for procedure pointer components. The argument 'sym' must formally
3678 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3679 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3680 component in whose formal_ns the arguments have to be). */
3683 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3685 gfc_component
*comp
;
3686 comp
= (gfc_component
*)sym
;
3687 if ((expr
->expr_type
== EXPR_VARIABLE
3688 || (expr
->expr_type
== EXPR_FUNCTION
3689 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
3690 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
3693 gfc_namespace
*ns
= comp
->formal_ns
;
3694 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3695 the symtree rather than create a new one (and probably fail later). */
3696 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
3697 expr
->symtree
->n
.sym
->name
);
3699 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
3700 expr
->symtree
= stree
;
3706 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
3708 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);