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
);
159 mpc_clear (e
->value
.complex);
166 /* Free the representation. */
167 if (e
->representation
.string
)
168 gfc_free (e
->representation
.string
);
173 if (e
->value
.op
.op1
!= NULL
)
174 gfc_free_expr (e
->value
.op
.op1
);
175 if (e
->value
.op
.op2
!= NULL
)
176 gfc_free_expr (e
->value
.op
.op2
);
180 gfc_free_actual_arglist (e
->value
.function
.actual
);
185 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
193 gfc_free_constructor (e
->value
.constructor
);
197 gfc_free (e
->value
.character
.string
);
204 gfc_internal_error ("free_expr0(): Bad expr type");
207 /* Free a shape array. */
208 if (e
->shape
!= NULL
)
210 for (n
= 0; n
< e
->rank
; n
++)
211 mpz_clear (e
->shape
[n
]);
216 gfc_free_ref_list (e
->ref
);
218 memset (e
, '\0', sizeof (gfc_expr
));
222 /* Free an expression node and everything beneath it. */
225 gfc_free_expr (gfc_expr
*e
)
229 if (e
->con_by_offset
)
230 splay_tree_delete (e
->con_by_offset
);
236 /* Graft the *src expression onto the *dest subexpression. */
239 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
247 /* Try to extract an integer constant from the passed expression node.
248 Returns an error message or NULL if the result is set. It is
249 tempting to generate an error and return SUCCESS or FAILURE, but
250 failure is OK for some callers. */
253 gfc_extract_int (gfc_expr
*expr
, int *result
)
255 if (expr
->expr_type
!= EXPR_CONSTANT
)
256 return _("Constant expression required at %C");
258 if (expr
->ts
.type
!= BT_INTEGER
)
259 return _("Integer expression required at %C");
261 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
262 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
264 return _("Integer value too large in expression at %C");
267 *result
= (int) mpz_get_si (expr
->value
.integer
);
273 /* Recursively copy a list of reference structures. */
276 gfc_copy_ref (gfc_ref
*src
)
284 dest
= gfc_get_ref ();
285 dest
->type
= src
->type
;
290 ar
= gfc_copy_array_ref (&src
->u
.ar
);
296 dest
->u
.c
= src
->u
.c
;
300 dest
->u
.ss
= src
->u
.ss
;
301 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
302 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
306 dest
->next
= gfc_copy_ref (src
->next
);
312 /* Detect whether an expression has any vector index array references. */
315 gfc_has_vector_index (gfc_expr
*e
)
319 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
320 if (ref
->type
== REF_ARRAY
)
321 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
322 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
328 /* Insert a reference to the component of the given name.
329 Only to be used with CLASS containers. */
332 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
334 gfc_ref
**tail
= &(e
->ref
);
335 gfc_ref
*next
= NULL
;
336 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
337 while (*tail
!= NULL
)
339 if ((*tail
)->type
== REF_COMPONENT
)
340 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
341 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
343 tail
= &((*tail
)->next
);
345 if (*tail
!= NULL
&& strcmp (name
, "$data") == 0)
347 (*tail
) = gfc_get_ref();
348 (*tail
)->next
= next
;
349 (*tail
)->type
= REF_COMPONENT
;
350 (*tail
)->u
.c
.sym
= derived
;
351 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
352 gcc_assert((*tail
)->u
.c
.component
);
354 e
->ts
= (*tail
)->u
.c
.component
->ts
;
358 /* Copy a shape array. */
361 gfc_copy_shape (mpz_t
*shape
, int rank
)
369 new_shape
= gfc_get_shape (rank
);
371 for (n
= 0; n
< rank
; n
++)
372 mpz_init_set (new_shape
[n
], shape
[n
]);
378 /* Copy a shape array excluding dimension N, where N is an integer
379 constant expression. Dimensions are numbered in fortran style --
382 So, if the original shape array contains R elements
383 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
384 the result contains R-1 elements:
385 { s1 ... sN-1 sN+1 ... sR-1}
387 If anything goes wrong -- N is not a constant, its value is out
388 of range -- or anything else, just returns NULL. */
391 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
393 mpz_t
*new_shape
, *s
;
399 || dim
->expr_type
!= EXPR_CONSTANT
400 || dim
->ts
.type
!= BT_INTEGER
)
403 n
= mpz_get_si (dim
->value
.integer
);
404 n
--; /* Convert to zero based index. */
405 if (n
< 0 || n
>= rank
)
408 s
= new_shape
= gfc_get_shape (rank
- 1);
410 for (i
= 0; i
< rank
; i
++)
414 mpz_init_set (*s
, shape
[i
]);
422 /* Given an expression pointer, return a copy of the expression. This
423 subroutine is recursive. */
426 gfc_copy_expr (gfc_expr
*p
)
438 switch (q
->expr_type
)
441 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
442 q
->value
.character
.string
= s
;
443 memcpy (s
, p
->value
.character
.string
,
444 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
448 /* Copy target representation, if it exists. */
449 if (p
->representation
.string
)
451 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
452 q
->representation
.string
= c
;
453 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
456 /* Copy the values of any pointer components of p->value. */
460 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
464 gfc_set_model_kind (q
->ts
.kind
);
465 mpfr_init (q
->value
.real
);
466 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
470 gfc_set_model_kind (q
->ts
.kind
);
471 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
472 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
476 if (p
->representation
.string
)
477 q
->value
.character
.string
478 = gfc_char_to_widechar (q
->representation
.string
);
481 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
482 q
->value
.character
.string
= s
;
484 /* This is the case for the C_NULL_CHAR named constant. */
485 if (p
->value
.character
.length
== 0
486 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
489 /* Need to set the length to 1 to make sure the NUL
490 terminator is copied. */
491 q
->value
.character
.length
= 1;
494 memcpy (s
, p
->value
.character
.string
,
495 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
503 break; /* Already done. */
507 /* Should never be reached. */
509 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
516 switch (q
->value
.op
.op
)
519 case INTRINSIC_PARENTHESES
:
520 case INTRINSIC_UPLUS
:
521 case INTRINSIC_UMINUS
:
522 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
525 default: /* Binary operators. */
526 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
527 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
534 q
->value
.function
.actual
=
535 gfc_copy_actual_arglist (p
->value
.function
.actual
);
540 q
->value
.compcall
.actual
=
541 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
542 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
547 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
555 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
557 q
->ref
= gfc_copy_ref (p
->ref
);
563 /* Return the maximum kind of two expressions. In general, higher
564 kind numbers mean more precision for numeric types. */
567 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
569 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
573 /* Returns nonzero if the type is numeric, zero otherwise. */
576 numeric_type (bt type
)
578 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
582 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
585 gfc_numeric_ts (gfc_typespec
*ts
)
587 return numeric_type (ts
->type
);
591 /* Returns an expression node that is an integer constant. */
600 p
->expr_type
= EXPR_CONSTANT
;
601 p
->ts
.type
= BT_INTEGER
;
602 p
->ts
.kind
= gfc_default_integer_kind
;
604 p
->where
= gfc_current_locus
;
605 mpz_init_set_si (p
->value
.integer
, i
);
611 /* Returns an expression node that is a logical constant. */
614 gfc_logical_expr (int i
, locus
*where
)
620 p
->expr_type
= EXPR_CONSTANT
;
621 p
->ts
.type
= BT_LOGICAL
;
622 p
->ts
.kind
= gfc_default_logical_kind
;
625 where
= &gfc_current_locus
;
627 p
->value
.logical
= i
;
633 /* Return an expression node with an optional argument list attached.
634 A variable number of gfc_expr pointers are strung together in an
635 argument list with a NULL pointer terminating the list. */
638 gfc_build_conversion (gfc_expr
*e
)
643 p
->expr_type
= EXPR_FUNCTION
;
645 p
->value
.function
.actual
= NULL
;
647 p
->value
.function
.actual
= gfc_get_actual_arglist ();
648 p
->value
.function
.actual
->expr
= e
;
654 /* Given an expression node with some sort of numeric binary
655 expression, insert type conversions required to make the operands
658 The exception is that the operands of an exponential don't have to
659 have the same type. If possible, the base is promoted to the type
660 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
661 1.0**2 stays as it is. */
664 gfc_type_convert_binary (gfc_expr
*e
)
668 op1
= e
->value
.op
.op1
;
669 op2
= e
->value
.op
.op2
;
671 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
673 gfc_clear_ts (&e
->ts
);
677 /* Kind conversions of same type. */
678 if (op1
->ts
.type
== op2
->ts
.type
)
680 if (op1
->ts
.kind
== op2
->ts
.kind
)
682 /* No type conversions. */
687 if (op1
->ts
.kind
> op2
->ts
.kind
)
688 gfc_convert_type (op2
, &op1
->ts
, 2);
690 gfc_convert_type (op1
, &op2
->ts
, 2);
696 /* Integer combined with real or complex. */
697 if (op2
->ts
.type
== BT_INTEGER
)
701 /* Special case for ** operator. */
702 if (e
->value
.op
.op
== INTRINSIC_POWER
)
705 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
709 if (op1
->ts
.type
== BT_INTEGER
)
712 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
716 /* Real combined with complex. */
717 e
->ts
.type
= BT_COMPLEX
;
718 if (op1
->ts
.kind
> op2
->ts
.kind
)
719 e
->ts
.kind
= op1
->ts
.kind
;
721 e
->ts
.kind
= op2
->ts
.kind
;
722 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
723 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
724 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
725 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
733 check_specification_function (gfc_expr
*e
)
740 sym
= e
->symtree
->n
.sym
;
742 /* F95, 7.1.6.2; F2003, 7.1.7 */
744 && sym
->attr
.function
746 && !sym
->attr
.intrinsic
747 && !sym
->attr
.recursive
748 && sym
->attr
.proc
!= PROC_INTERNAL
749 && sym
->attr
.proc
!= PROC_ST_FUNCTION
750 && sym
->attr
.proc
!= PROC_UNKNOWN
751 && sym
->formal
== NULL
)
757 /* Function to determine if an expression is constant or not. This
758 function expects that the expression has already been simplified. */
761 gfc_is_constant_expr (gfc_expr
*e
)
764 gfc_actual_arglist
*arg
;
770 switch (e
->expr_type
)
773 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
774 && (e
->value
.op
.op2
== NULL
775 || gfc_is_constant_expr (e
->value
.op
.op2
)));
783 /* Specification functions are constant. */
784 if (check_specification_function (e
) == MATCH_YES
)
790 /* Call to intrinsic with at least one argument. */
792 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
794 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
796 if (!gfc_is_constant_expr (arg
->expr
))
810 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
811 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
816 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
817 if (!gfc_is_constant_expr (c
->expr
))
825 rv
= gfc_constant_ac (e
);
829 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
836 /* Is true if an array reference is followed by a component or substring
839 is_subref_array (gfc_expr
* e
)
844 if (e
->expr_type
!= EXPR_VARIABLE
)
847 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
851 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
853 if (ref
->type
== REF_ARRAY
854 && ref
->u
.ar
.type
!= AR_ELEMENT
)
858 && ref
->type
!= REF_ARRAY
)
865 /* Try to collapse intrinsic expressions. */
868 simplify_intrinsic_op (gfc_expr
*p
, int type
)
871 gfc_expr
*op1
, *op2
, *result
;
873 if (p
->value
.op
.op
== INTRINSIC_USER
)
876 op1
= p
->value
.op
.op1
;
877 op2
= p
->value
.op
.op2
;
880 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
882 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
885 if (!gfc_is_constant_expr (op1
)
886 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
890 p
->value
.op
.op1
= NULL
;
891 p
->value
.op
.op2
= NULL
;
895 case INTRINSIC_PARENTHESES
:
896 result
= gfc_parentheses (op1
);
899 case INTRINSIC_UPLUS
:
900 result
= gfc_uplus (op1
);
903 case INTRINSIC_UMINUS
:
904 result
= gfc_uminus (op1
);
908 result
= gfc_add (op1
, op2
);
911 case INTRINSIC_MINUS
:
912 result
= gfc_subtract (op1
, op2
);
915 case INTRINSIC_TIMES
:
916 result
= gfc_multiply (op1
, op2
);
919 case INTRINSIC_DIVIDE
:
920 result
= gfc_divide (op1
, op2
);
923 case INTRINSIC_POWER
:
924 result
= gfc_power (op1
, op2
);
927 case INTRINSIC_CONCAT
:
928 result
= gfc_concat (op1
, op2
);
932 case INTRINSIC_EQ_OS
:
933 result
= gfc_eq (op1
, op2
, op
);
937 case INTRINSIC_NE_OS
:
938 result
= gfc_ne (op1
, op2
, op
);
942 case INTRINSIC_GT_OS
:
943 result
= gfc_gt (op1
, op2
, op
);
947 case INTRINSIC_GE_OS
:
948 result
= gfc_ge (op1
, op2
, op
);
952 case INTRINSIC_LT_OS
:
953 result
= gfc_lt (op1
, op2
, op
);
957 case INTRINSIC_LE_OS
:
958 result
= gfc_le (op1
, op2
, op
);
962 result
= gfc_not (op1
);
966 result
= gfc_and (op1
, op2
);
970 result
= gfc_or (op1
, op2
);
974 result
= gfc_eqv (op1
, op2
);
978 result
= gfc_neqv (op1
, op2
);
982 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
992 result
->rank
= p
->rank
;
993 result
->where
= p
->where
;
994 gfc_replace_expr (p
, result
);
1000 /* Subroutine to simplify constructor expressions. Mutually recursive
1001 with gfc_simplify_expr(). */
1004 simplify_constructor (gfc_constructor
*c
, int type
)
1008 for (; c
; c
= c
->next
)
1011 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
1012 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
1013 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
1018 /* Try and simplify a copy. Replace the original if successful
1019 but keep going through the constructor at all costs. Not
1020 doing so can make a dog's dinner of complicated things. */
1021 p
= gfc_copy_expr (c
->expr
);
1023 if (gfc_simplify_expr (p
, type
) == FAILURE
)
1029 gfc_replace_expr (c
->expr
, p
);
1037 /* Pull a single array element out of an array constructor. */
1040 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
1041 gfc_constructor
**rval
)
1043 unsigned long nelemen
;
1055 mpz_init_set_ui (offset
, 0);
1058 mpz_init_set_ui (span
, 1);
1059 for (i
= 0; i
< ar
->dimen
; i
++)
1061 if (gfc_reduce_init_expr (ar
->as
->lower
[i
]) == FAILURE
1062 || gfc_reduce_init_expr (ar
->as
->upper
[i
]) == FAILURE
)
1069 e
= gfc_copy_expr (ar
->start
[i
]);
1070 if (e
->expr_type
!= EXPR_CONSTANT
)
1076 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1077 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1079 /* Check the bounds. */
1080 if ((ar
->as
->upper
[i
]
1081 && mpz_cmp (e
->value
.integer
,
1082 ar
->as
->upper
[i
]->value
.integer
) > 0)
1083 || (mpz_cmp (e
->value
.integer
,
1084 ar
->as
->lower
[i
]->value
.integer
) < 0))
1086 gfc_error ("Index in dimension %d is out of bounds "
1087 "at %L", i
+ 1, &ar
->c_where
[i
]);
1093 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1094 mpz_mul (delta
, delta
, span
);
1095 mpz_add (offset
, offset
, delta
);
1097 mpz_set_ui (tmp
, 1);
1098 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1099 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1100 mpz_mul (span
, span
, tmp
);
1103 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1128 /* Find a component of a structure constructor. */
1130 static gfc_constructor
*
1131 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1133 gfc_component
*comp
;
1134 gfc_component
*pick
;
1136 comp
= ref
->u
.c
.sym
->components
;
1137 pick
= ref
->u
.c
.component
;
1138 while (comp
!= pick
)
1148 /* Replace an expression with the contents of a constructor, removing
1149 the subobject reference in the process. */
1152 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1158 e
->ref
= p
->ref
->next
;
1159 p
->ref
->next
= NULL
;
1160 gfc_replace_expr (p
, e
);
1164 /* Pull an array section out of an array constructor. */
1167 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1173 long unsigned one
= 1;
1175 mpz_t start
[GFC_MAX_DIMENSIONS
];
1176 mpz_t end
[GFC_MAX_DIMENSIONS
];
1177 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1178 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1179 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1185 gfc_constructor
*cons
;
1186 gfc_constructor
*base
;
1192 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1197 base
= expr
->value
.constructor
;
1198 expr
->value
.constructor
= NULL
;
1200 rank
= ref
->u
.ar
.as
->rank
;
1202 if (expr
->shape
== NULL
)
1203 expr
->shape
= gfc_get_shape (rank
);
1205 mpz_init_set_ui (delta_mpz
, one
);
1206 mpz_init_set_ui (nelts
, one
);
1209 /* Do the initialization now, so that we can cleanup without
1210 keeping track of where we were. */
1211 for (d
= 0; d
< rank
; d
++)
1213 mpz_init (delta
[d
]);
1214 mpz_init (start
[d
]);
1217 mpz_init (stride
[d
]);
1221 /* Build the counters to clock through the array reference. */
1223 for (d
= 0; d
< rank
; d
++)
1225 /* Make this stretch of code easier on the eye! */
1226 begin
= ref
->u
.ar
.start
[d
];
1227 finish
= ref
->u
.ar
.end
[d
];
1228 step
= ref
->u
.ar
.stride
[d
];
1229 lower
= ref
->u
.ar
.as
->lower
[d
];
1230 upper
= ref
->u
.ar
.as
->upper
[d
];
1232 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1236 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1242 gcc_assert (begin
->rank
== 1);
1243 /* Zero-sized arrays have no shape and no elements, stop early. */
1246 mpz_init_set_ui (nelts
, 0);
1250 vecsub
[d
] = begin
->value
.constructor
;
1251 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1252 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1253 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1256 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1258 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1259 || mpz_cmp (c
->expr
->value
.integer
,
1260 lower
->value
.integer
) < 0)
1262 gfc_error ("index in dimension %d is out of bounds "
1263 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1271 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1272 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1273 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1279 /* Obtain the stride. */
1281 mpz_set (stride
[d
], step
->value
.integer
);
1283 mpz_set_ui (stride
[d
], one
);
1285 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1286 mpz_set_ui (stride
[d
], one
);
1288 /* Obtain the start value for the index. */
1290 mpz_set (start
[d
], begin
->value
.integer
);
1292 mpz_set (start
[d
], lower
->value
.integer
);
1294 mpz_set (ctr
[d
], start
[d
]);
1296 /* Obtain the end value for the index. */
1298 mpz_set (end
[d
], finish
->value
.integer
);
1300 mpz_set (end
[d
], upper
->value
.integer
);
1302 /* Separate 'if' because elements sometimes arrive with
1304 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1305 mpz_set (end
[d
], begin
->value
.integer
);
1307 /* Check the bounds. */
1308 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1309 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1310 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1311 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1313 gfc_error ("index in dimension %d is out of bounds "
1314 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1319 /* Calculate the number of elements and the shape. */
1320 mpz_set (tmp_mpz
, stride
[d
]);
1321 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1322 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1323 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1324 mpz_mul (nelts
, nelts
, tmp_mpz
);
1326 /* An element reference reduces the rank of the expression; don't
1327 add anything to the shape array. */
1328 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1329 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1332 /* Calculate the 'stride' (=delta) for conversion of the
1333 counter values into the index along the constructor. */
1334 mpz_set (delta
[d
], delta_mpz
);
1335 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1336 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1337 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1344 /* Now clock through the array reference, calculating the index in
1345 the source constructor and transferring the elements to the new
1347 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1349 if (ref
->u
.ar
.offset
)
1350 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1352 mpz_init_set_ui (ptr
, 0);
1355 for (d
= 0; d
< rank
; d
++)
1357 mpz_set (tmp_mpz
, ctr
[d
]);
1358 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1359 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1360 mpz_add (ptr
, ptr
, tmp_mpz
);
1362 if (!incr_ctr
) continue;
1364 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1366 gcc_assert(vecsub
[d
]);
1368 if (!vecsub
[d
]->next
)
1369 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1372 vecsub
[d
] = vecsub
[d
]->next
;
1375 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1379 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1381 if (mpz_cmp_ui (stride
[d
], 0) > 0
1382 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1383 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1384 mpz_set (ctr
[d
], start
[d
]);
1390 /* There must be a better way of dealing with negative strides
1391 than resetting the index and the constructor pointer! */
1392 if (mpz_cmp (ptr
, index
) < 0)
1394 mpz_set_ui (index
, 0);
1398 while (cons
&& cons
->next
&& mpz_cmp (ptr
, index
) > 0)
1400 mpz_add_ui (index
, index
, one
);
1404 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1412 mpz_clear (delta_mpz
);
1413 mpz_clear (tmp_mpz
);
1415 for (d
= 0; d
< rank
; d
++)
1417 mpz_clear (delta
[d
]);
1418 mpz_clear (start
[d
]);
1421 mpz_clear (stride
[d
]);
1423 gfc_free_constructor (base
);
1427 /* Pull a substring out of an expression. */
1430 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1437 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1438 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1441 *newp
= gfc_copy_expr (p
);
1442 gfc_free ((*newp
)->value
.character
.string
);
1444 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1445 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1446 length
= end
- start
+ 1;
1448 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1449 (*newp
)->value
.character
.length
= length
;
1450 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1451 length
* sizeof (gfc_char_t
));
1458 /* Simplify a subobject reference of a constructor. This occurs when
1459 parameter variable values are substituted. */
1462 simplify_const_ref (gfc_expr
*p
)
1464 gfc_constructor
*cons
;
1469 switch (p
->ref
->type
)
1472 switch (p
->ref
->u
.ar
.type
)
1475 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1482 remove_subobject_ref (p
, cons
);
1486 if (find_array_section (p
, p
->ref
) == FAILURE
)
1488 p
->ref
->u
.ar
.type
= AR_FULL
;
1493 if (p
->ref
->next
!= NULL
1494 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1496 cons
= p
->value
.constructor
;
1497 for (; cons
; cons
= cons
->next
)
1499 cons
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1500 if (simplify_const_ref (cons
->expr
) == FAILURE
)
1504 /* If this is a CHARACTER array and we possibly took a
1505 substring out of it, update the type-spec's character
1506 length according to the first element (as all should have
1507 the same length). */
1508 if (p
->ts
.type
== BT_CHARACTER
)
1512 gcc_assert (p
->ref
->next
);
1513 gcc_assert (!p
->ref
->next
->next
);
1514 gcc_assert (p
->ref
->next
->type
== REF_SUBSTRING
);
1516 if (p
->value
.constructor
)
1518 const gfc_expr
* first
= p
->value
.constructor
->expr
;
1519 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1520 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1521 string_len
= first
->value
.character
.length
;
1527 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1530 gfc_free_expr (p
->ts
.u
.cl
->length
);
1532 p
->ts
.u
.cl
->length
= gfc_int_expr (string_len
);
1535 gfc_free_ref_list (p
->ref
);
1546 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1547 remove_subobject_ref (p
, cons
);
1551 if (find_substring_ref (p
, &newp
) == FAILURE
)
1554 gfc_replace_expr (p
, newp
);
1555 gfc_free_ref_list (p
->ref
);
1565 /* Simplify a chain of references. */
1568 simplify_ref_chain (gfc_ref
*ref
, int type
)
1572 for (; ref
; ref
= ref
->next
)
1577 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1579 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1581 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1583 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1589 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1591 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1603 /* Try to substitute the value of a parameter variable. */
1606 simplify_parameter_variable (gfc_expr
*p
, int type
)
1611 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1617 /* Do not copy subobject refs for constant. */
1618 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1619 e
->ref
= gfc_copy_ref (p
->ref
);
1620 t
= gfc_simplify_expr (e
, type
);
1622 /* Only use the simplification if it eliminated all subobject references. */
1623 if (t
== SUCCESS
&& !e
->ref
)
1624 gfc_replace_expr (p
, e
);
1631 /* Given an expression, simplify it by collapsing constant
1632 expressions. Most simplification takes place when the expression
1633 tree is being constructed. If an intrinsic function is simplified
1634 at some point, we get called again to collapse the result against
1637 We work by recursively simplifying expression nodes, simplifying
1638 intrinsic functions where possible, which can lead to further
1639 constant collapsing. If an operator has constant operand(s), we
1640 rip the expression apart, and rebuild it, hoping that it becomes
1643 The expression type is defined for:
1644 0 Basic expression parsing
1645 1 Simplifying array constructors -- will substitute
1647 Returns FAILURE on error, SUCCESS otherwise.
1648 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1651 gfc_simplify_expr (gfc_expr
*p
, int type
)
1653 gfc_actual_arglist
*ap
;
1658 switch (p
->expr_type
)
1665 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1666 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1669 if (p
->value
.function
.isym
!= NULL
1670 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1675 case EXPR_SUBSTRING
:
1676 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1679 if (gfc_is_constant_expr (p
))
1685 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1687 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1688 start
--; /* Convert from one-based to zero-based. */
1691 end
= p
->value
.character
.length
;
1692 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1693 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1695 s
= gfc_get_wide_string (end
- start
+ 2);
1696 memcpy (s
, p
->value
.character
.string
+ start
,
1697 (end
- start
) * sizeof (gfc_char_t
));
1698 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1699 gfc_free (p
->value
.character
.string
);
1700 p
->value
.character
.string
= s
;
1701 p
->value
.character
.length
= end
- start
;
1702 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1703 p
->ts
.u
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1704 gfc_free_ref_list (p
->ref
);
1706 p
->expr_type
= EXPR_CONSTANT
;
1711 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1716 /* Only substitute array parameter variables if we are in an
1717 initialization expression, or we want a subsection. */
1718 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1719 && (gfc_init_expr
|| p
->ref
1720 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1722 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1729 gfc_simplify_iterator_var (p
);
1732 /* Simplify subcomponent references. */
1733 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1738 case EXPR_STRUCTURE
:
1740 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1743 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1746 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1747 && p
->ref
->u
.ar
.type
== AR_FULL
)
1748 gfc_expand_constructor (p
);
1750 if (simplify_const_ref (p
) == FAILURE
)
1765 /* Returns the type of an expression with the exception that iterator
1766 variables are automatically integers no matter what else they may
1772 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1779 /* Check an intrinsic arithmetic operation to see if it is consistent
1780 with some type of expression. */
1782 static gfc_try
check_init_expr (gfc_expr
*);
1785 /* Scalarize an expression for an elemental intrinsic call. */
1788 scalarize_intrinsic_call (gfc_expr
*e
)
1790 gfc_actual_arglist
*a
, *b
;
1791 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1792 gfc_expr
*expr
, *old
;
1793 int n
, i
, rank
[5], array_arg
;
1795 /* Find which, if any, arguments are arrays. Assume that the old
1796 expression carries the type information and that the first arg
1797 that is an array expression carries all the shape information.*/
1799 a
= e
->value
.function
.actual
;
1800 for (; a
; a
= a
->next
)
1803 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1806 expr
= gfc_copy_expr (a
->expr
);
1813 old
= gfc_copy_expr (e
);
1815 gfc_free_constructor (expr
->value
.constructor
);
1816 expr
->value
.constructor
= NULL
;
1819 expr
->where
= old
->where
;
1820 expr
->expr_type
= EXPR_ARRAY
;
1822 /* Copy the array argument constructors into an array, with nulls
1825 a
= old
->value
.function
.actual
;
1826 for (; a
; a
= a
->next
)
1828 /* Check that this is OK for an initialization expression. */
1829 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1833 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1835 rank
[n
] = a
->expr
->rank
;
1836 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1837 args
[n
] = gfc_copy_constructor (ctor
);
1839 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1842 rank
[n
] = a
->expr
->rank
;
1845 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1853 /* Using the array argument as the master, step through the array
1854 calling the function for each element and advancing the array
1855 constructors together. */
1856 ctor
= args
[array_arg
- 1];
1858 for (; ctor
; ctor
= ctor
->next
)
1860 if (expr
->value
.constructor
== NULL
)
1861 expr
->value
.constructor
1862 = new_ctor
= gfc_get_constructor ();
1865 new_ctor
->next
= gfc_get_constructor ();
1866 new_ctor
= new_ctor
->next
;
1868 new_ctor
->expr
= gfc_copy_expr (old
);
1869 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1871 b
= old
->value
.function
.actual
;
1872 for (i
= 0; i
< n
; i
++)
1875 new_ctor
->expr
->value
.function
.actual
1876 = a
= gfc_get_actual_arglist ();
1879 a
->next
= gfc_get_actual_arglist ();
1883 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1885 a
->expr
= gfc_copy_expr (b
->expr
);
1890 /* Simplify the function calls. If the simplification fails, the
1891 error will be flagged up down-stream or the library will deal
1893 gfc_simplify_expr (new_ctor
->expr
, 0);
1895 for (i
= 0; i
< n
; i
++)
1897 args
[i
] = args
[i
]->next
;
1899 for (i
= 1; i
< n
; i
++)
1900 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
1901 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
1907 gfc_free_expr (old
);
1911 gfc_error_now ("elemental function arguments at %C are not compliant");
1914 gfc_free_expr (expr
);
1915 gfc_free_expr (old
);
1921 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
1923 gfc_expr
*op1
= e
->value
.op
.op1
;
1924 gfc_expr
*op2
= e
->value
.op
.op2
;
1926 if ((*check_function
) (op1
) == FAILURE
)
1929 switch (e
->value
.op
.op
)
1931 case INTRINSIC_UPLUS
:
1932 case INTRINSIC_UMINUS
:
1933 if (!numeric_type (et0 (op1
)))
1938 case INTRINSIC_EQ_OS
:
1940 case INTRINSIC_NE_OS
:
1942 case INTRINSIC_GT_OS
:
1944 case INTRINSIC_GE_OS
:
1946 case INTRINSIC_LT_OS
:
1948 case INTRINSIC_LE_OS
:
1949 if ((*check_function
) (op2
) == FAILURE
)
1952 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1953 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1955 gfc_error ("Numeric or CHARACTER operands are required in "
1956 "expression at %L", &e
->where
);
1961 case INTRINSIC_PLUS
:
1962 case INTRINSIC_MINUS
:
1963 case INTRINSIC_TIMES
:
1964 case INTRINSIC_DIVIDE
:
1965 case INTRINSIC_POWER
:
1966 if ((*check_function
) (op2
) == FAILURE
)
1969 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1974 case INTRINSIC_CONCAT
:
1975 if ((*check_function
) (op2
) == FAILURE
)
1978 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1980 gfc_error ("Concatenation operator in expression at %L "
1981 "must have two CHARACTER operands", &op1
->where
);
1985 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1987 gfc_error ("Concat operator at %L must concatenate strings of the "
1988 "same kind", &e
->where
);
1995 if (et0 (op1
) != BT_LOGICAL
)
1997 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1998 "operand", &op1
->where
);
2007 case INTRINSIC_NEQV
:
2008 if ((*check_function
) (op2
) == FAILURE
)
2011 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2013 gfc_error ("LOGICAL operands are required in expression at %L",
2020 case INTRINSIC_PARENTHESES
:
2024 gfc_error ("Only intrinsic operators can be used in expression at %L",
2032 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2037 /* F2003, 7.1.7 (3): In init expression, allocatable components
2038 must not be data-initialized. */
2040 check_alloc_comp_init (gfc_expr
*e
)
2043 gfc_constructor
*ctor
;
2045 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2046 gcc_assert (e
->ts
.type
== BT_DERIVED
);
2048 for (c
= e
->ts
.u
.derived
->components
, ctor
= e
->value
.constructor
;
2049 c
; c
= c
->next
, ctor
= ctor
->next
)
2051 if (c
->attr
.allocatable
2052 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2054 gfc_error("Invalid initialization expression for ALLOCATABLE "
2055 "component '%s' in structure constructor at %L",
2056 c
->name
, &ctor
->expr
->where
);
2065 check_init_expr_arguments (gfc_expr
*e
)
2067 gfc_actual_arglist
*ap
;
2069 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2070 if (check_init_expr (ap
->expr
) == FAILURE
)
2076 static gfc_try
check_restricted (gfc_expr
*);
2078 /* F95, 7.1.6.1, Initialization expressions, (7)
2079 F2003, 7.1.7 Initialization expression, (8) */
2082 check_inquiry (gfc_expr
*e
, int not_restricted
)
2085 const char *const *functions
;
2087 static const char *const inquiry_func_f95
[] = {
2088 "lbound", "shape", "size", "ubound",
2089 "bit_size", "len", "kind",
2090 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2091 "precision", "radix", "range", "tiny",
2095 static const char *const inquiry_func_f2003
[] = {
2096 "lbound", "shape", "size", "ubound",
2097 "bit_size", "len", "kind",
2098 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2099 "precision", "radix", "range", "tiny",
2104 gfc_actual_arglist
*ap
;
2106 if (!e
->value
.function
.isym
2107 || !e
->value
.function
.isym
->inquiry
)
2110 /* An undeclared parameter will get us here (PR25018). */
2111 if (e
->symtree
== NULL
)
2114 name
= e
->symtree
->n
.sym
->name
;
2116 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2117 ? inquiry_func_f2003
: inquiry_func_f95
;
2119 for (i
= 0; functions
[i
]; i
++)
2120 if (strcmp (functions
[i
], name
) == 0)
2123 if (functions
[i
] == NULL
)
2126 /* At this point we have an inquiry function with a variable argument. The
2127 type of the variable might be undefined, but we need it now, because the
2128 arguments of these functions are not allowed to be undefined. */
2130 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2135 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2137 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2138 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2142 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2145 /* Assumed character length will not reduce to a constant expression
2146 with LEN, as required by the standard. */
2147 if (i
== 5 && not_restricted
2148 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2149 && ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
)
2151 gfc_error ("Assumed character length variable '%s' in constant "
2152 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2155 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2158 if (not_restricted
== 0
2159 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2160 && check_restricted (ap
->expr
) == FAILURE
)
2168 /* F95, 7.1.6.1, Initialization expressions, (5)
2169 F2003, 7.1.7 Initialization expression, (5) */
2172 check_transformational (gfc_expr
*e
)
2174 static const char * const trans_func_f95
[] = {
2175 "repeat", "reshape", "selected_int_kind",
2176 "selected_real_kind", "transfer", "trim", NULL
2179 static const char * const trans_func_f2003
[] = {
2180 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2181 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2182 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2183 "trim", "unpack", NULL
2188 const char *const *functions
;
2190 if (!e
->value
.function
.isym
2191 || !e
->value
.function
.isym
->transformational
)
2194 name
= e
->symtree
->n
.sym
->name
;
2196 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2197 ? trans_func_f2003
: trans_func_f95
;
2199 /* NULL() is dealt with below. */
2200 if (strcmp ("null", name
) == 0)
2203 for (i
= 0; functions
[i
]; i
++)
2204 if (strcmp (functions
[i
], name
) == 0)
2207 if (functions
[i
] == NULL
)
2209 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2210 "in an initialization expression", name
, &e
->where
);
2214 return check_init_expr_arguments (e
);
2218 /* F95, 7.1.6.1, Initialization expressions, (6)
2219 F2003, 7.1.7 Initialization expression, (6) */
2222 check_null (gfc_expr
*e
)
2224 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2227 return check_init_expr_arguments (e
);
2232 check_elemental (gfc_expr
*e
)
2234 if (!e
->value
.function
.isym
2235 || !e
->value
.function
.isym
->elemental
)
2238 if (e
->ts
.type
!= BT_INTEGER
2239 && e
->ts
.type
!= BT_CHARACTER
2240 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2241 "nonstandard initialization expression at %L",
2242 &e
->where
) == FAILURE
)
2245 return check_init_expr_arguments (e
);
2250 check_conversion (gfc_expr
*e
)
2252 if (!e
->value
.function
.isym
2253 || !e
->value
.function
.isym
->conversion
)
2256 return check_init_expr_arguments (e
);
2260 /* Verify that an expression is an initialization expression. A side
2261 effect is that the expression tree is reduced to a single constant
2262 node if all goes well. This would normally happen when the
2263 expression is constructed but function references are assumed to be
2264 intrinsics in the context of initialization expressions. If
2265 FAILURE is returned an error message has been generated. */
2268 check_init_expr (gfc_expr
*e
)
2276 switch (e
->expr_type
)
2279 t
= check_intrinsic_op (e
, check_init_expr
);
2281 t
= gfc_simplify_expr (e
, 0);
2288 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2290 gfc_intrinsic_sym
* isym
;
2293 sym
= e
->symtree
->n
.sym
;
2294 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2295 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2297 gfc_error ("Function '%s' in initialization expression at %L "
2298 "must be an intrinsic or a specification function",
2299 e
->symtree
->n
.sym
->name
, &e
->where
);
2303 if ((m
= check_conversion (e
)) == MATCH_NO
2304 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2305 && (m
= check_null (e
)) == MATCH_NO
2306 && (m
= check_transformational (e
)) == MATCH_NO
2307 && (m
= check_elemental (e
)) == MATCH_NO
)
2309 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2310 "in an initialization expression",
2311 e
->symtree
->n
.sym
->name
, &e
->where
);
2315 /* Try to scalarize an elemental intrinsic function that has an
2317 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2318 if (isym
&& isym
->elemental
2319 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2324 t
= gfc_simplify_expr (e
, 0);
2331 if (gfc_check_iter_variable (e
) == SUCCESS
)
2334 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2336 /* A PARAMETER shall not be used to define itself, i.e.
2337 REAL, PARAMETER :: x = transfer(0, x)
2339 if (!e
->symtree
->n
.sym
->value
)
2341 gfc_error("PARAMETER '%s' is used at %L before its definition "
2342 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2346 t
= simplify_parameter_variable (e
, 0);
2351 if (gfc_in_match_data ())
2356 if (e
->symtree
->n
.sym
->as
)
2358 switch (e
->symtree
->n
.sym
->as
->type
)
2360 case AS_ASSUMED_SIZE
:
2361 gfc_error ("Assumed size array '%s' at %L is not permitted "
2362 "in an initialization expression",
2363 e
->symtree
->n
.sym
->name
, &e
->where
);
2366 case AS_ASSUMED_SHAPE
:
2367 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2368 "in an initialization expression",
2369 e
->symtree
->n
.sym
->name
, &e
->where
);
2373 gfc_error ("Deferred array '%s' at %L is not permitted "
2374 "in an initialization expression",
2375 e
->symtree
->n
.sym
->name
, &e
->where
);
2379 gfc_error ("Array '%s' at %L is a variable, which does "
2380 "not reduce to a constant expression",
2381 e
->symtree
->n
.sym
->name
, &e
->where
);
2389 gfc_error ("Parameter '%s' at %L has not been declared or is "
2390 "a variable, which does not reduce to a constant "
2391 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2400 case EXPR_SUBSTRING
:
2401 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2405 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2407 t
= gfc_simplify_expr (e
, 0);
2411 case EXPR_STRUCTURE
:
2412 t
= e
->ts
.is_iso_c
? SUCCESS
: FAILURE
;
2416 t
= check_alloc_comp_init (e
);
2420 t
= gfc_check_constructor (e
, check_init_expr
);
2427 t
= gfc_check_constructor (e
, check_init_expr
);
2431 t
= gfc_expand_constructor (e
);
2435 t
= gfc_check_constructor_type (e
);
2439 gfc_internal_error ("check_init_expr(): Unknown expression type");
2445 /* Reduces a general expression to an initialization expression (a constant).
2446 This used to be part of gfc_match_init_expr.
2447 Note that this function doesn't free the given expression on FAILURE. */
2450 gfc_reduce_init_expr (gfc_expr
*expr
)
2455 t
= gfc_resolve_expr (expr
);
2457 t
= check_init_expr (expr
);
2463 if (expr
->expr_type
== EXPR_ARRAY
2464 && (gfc_check_constructor_type (expr
) == FAILURE
2465 || gfc_expand_constructor (expr
) == FAILURE
))
2468 /* Not all inquiry functions are simplified to constant expressions
2469 so it is necessary to call check_inquiry again. */
2470 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2471 && !gfc_in_match_data ())
2473 gfc_error ("Initialization expression didn't reduce %C");
2481 /* Match an initialization expression. We work by first matching an
2482 expression, then reducing it to a constant. The reducing it to
2483 constant part requires a global variable to flag the prohibition
2484 of a non-integer exponent in -std=f95 mode. */
2486 bool init_flag
= false;
2489 gfc_match_init_expr (gfc_expr
**result
)
2499 m
= gfc_match_expr (&expr
);
2506 t
= gfc_reduce_init_expr (expr
);
2509 gfc_free_expr (expr
);
2521 /* Given an actual argument list, test to see that each argument is a
2522 restricted expression and optionally if the expression type is
2523 integer or character. */
2526 restricted_args (gfc_actual_arglist
*a
)
2528 for (; a
; a
= a
->next
)
2530 if (check_restricted (a
->expr
) == FAILURE
)
2538 /************* Restricted/specification expressions *************/
2541 /* Make sure a non-intrinsic function is a specification function. */
2544 external_spec_function (gfc_expr
*e
)
2548 f
= e
->value
.function
.esym
;
2550 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2552 gfc_error ("Specification function '%s' at %L cannot be a statement "
2553 "function", f
->name
, &e
->where
);
2557 if (f
->attr
.proc
== PROC_INTERNAL
)
2559 gfc_error ("Specification function '%s' at %L cannot be an internal "
2560 "function", f
->name
, &e
->where
);
2564 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2566 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2571 if (f
->attr
.recursive
)
2573 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2574 f
->name
, &e
->where
);
2578 return restricted_args (e
->value
.function
.actual
);
2582 /* Check to see that a function reference to an intrinsic is a
2583 restricted expression. */
2586 restricted_intrinsic (gfc_expr
*e
)
2588 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2589 if (check_inquiry (e
, 0) == MATCH_YES
)
2592 return restricted_args (e
->value
.function
.actual
);
2596 /* Check the expressions of an actual arglist. Used by check_restricted. */
2599 check_arglist (gfc_actual_arglist
* arg
, gfc_try (*checker
) (gfc_expr
*))
2601 for (; arg
; arg
= arg
->next
)
2602 if (checker (arg
->expr
) == FAILURE
)
2609 /* Check the subscription expressions of a reference chain with a checking
2610 function; used by check_restricted. */
2613 check_references (gfc_ref
* ref
, gfc_try (*checker
) (gfc_expr
*))
2623 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2625 if (checker (ref
->u
.ar
.start
[dim
]) == FAILURE
)
2627 if (checker (ref
->u
.ar
.end
[dim
]) == FAILURE
)
2629 if (checker (ref
->u
.ar
.stride
[dim
]) == FAILURE
)
2635 /* Nothing needed, just proceed to next reference. */
2639 if (checker (ref
->u
.ss
.start
) == FAILURE
)
2641 if (checker (ref
->u
.ss
.end
) == FAILURE
)
2650 return check_references (ref
->next
, checker
);
2654 /* Verify that an expression is a restricted expression. Like its
2655 cousin check_init_expr(), an error message is generated if we
2659 check_restricted (gfc_expr
*e
)
2667 switch (e
->expr_type
)
2670 t
= check_intrinsic_op (e
, check_restricted
);
2672 t
= gfc_simplify_expr (e
, 0);
2677 if (e
->value
.function
.esym
)
2679 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2681 t
= external_spec_function (e
);
2685 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
2688 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
2691 t
= restricted_intrinsic (e
);
2696 sym
= e
->symtree
->n
.sym
;
2699 /* If a dummy argument appears in a context that is valid for a
2700 restricted expression in an elemental procedure, it will have
2701 already been simplified away once we get here. Therefore we
2702 don't need to jump through hoops to distinguish valid from
2704 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2705 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2707 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2708 sym
->name
, &e
->where
);
2712 if (sym
->attr
.optional
)
2714 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2715 sym
->name
, &e
->where
);
2719 if (sym
->attr
.intent
== INTENT_OUT
)
2721 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2722 sym
->name
, &e
->where
);
2726 /* Check reference chain if any. */
2727 if (check_references (e
->ref
, &check_restricted
) == FAILURE
)
2730 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2731 processed in resolve.c(resolve_formal_arglist). This is done so
2732 that host associated dummy array indices are accepted (PR23446).
2733 This mechanism also does the same for the specification expressions
2734 of array-valued functions. */
2736 || sym
->attr
.in_common
2737 || sym
->attr
.use_assoc
2739 || sym
->attr
.implied_index
2740 || sym
->attr
.flavor
== FL_PARAMETER
2741 || (sym
->ns
&& sym
->ns
== gfc_current_ns
->parent
)
2742 || (sym
->ns
&& gfc_current_ns
->parent
2743 && sym
->ns
== gfc_current_ns
->parent
->parent
)
2744 || (sym
->ns
->proc_name
!= NULL
2745 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2746 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2752 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2753 sym
->name
, &e
->where
);
2754 /* Prevent a repetition of the error. */
2763 case EXPR_SUBSTRING
:
2764 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2768 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2770 t
= gfc_simplify_expr (e
, 0);
2774 case EXPR_STRUCTURE
:
2775 t
= gfc_check_constructor (e
, check_restricted
);
2779 t
= gfc_check_constructor (e
, check_restricted
);
2783 gfc_internal_error ("check_restricted(): Unknown expression type");
2790 /* Check to see that an expression is a specification expression. If
2791 we return FAILURE, an error has been generated. */
2794 gfc_specification_expr (gfc_expr
*e
)
2800 if (e
->ts
.type
!= BT_INTEGER
)
2802 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2803 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2807 if (e
->expr_type
== EXPR_FUNCTION
2808 && !e
->value
.function
.isym
2809 && !e
->value
.function
.esym
2810 && !gfc_pure (e
->symtree
->n
.sym
))
2812 gfc_error ("Function '%s' at %L must be PURE",
2813 e
->symtree
->n
.sym
->name
, &e
->where
);
2814 /* Prevent repeat error messages. */
2815 e
->symtree
->n
.sym
->attr
.pure
= 1;
2821 gfc_error ("Expression at %L must be scalar", &e
->where
);
2825 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2828 return check_restricted (e
);
2832 /************** Expression conformance checks. *************/
2834 /* Given two expressions, make sure that the arrays are conformable. */
2837 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
2839 int op1_flag
, op2_flag
, d
;
2840 mpz_t op1_size
, op2_size
;
2846 if (op1
->rank
== 0 || op2
->rank
== 0)
2849 va_start (argp
, optype_msgid
);
2850 vsnprintf (buffer
, 240, optype_msgid
, argp
);
2853 if (op1
->rank
!= op2
->rank
)
2855 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
2856 op1
->rank
, op2
->rank
, &op1
->where
);
2862 for (d
= 0; d
< op1
->rank
; d
++)
2864 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2865 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2867 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2869 gfc_error ("Different shape for %s at %L on dimension %d "
2870 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
2871 (int) mpz_get_si (op1_size
),
2872 (int) mpz_get_si (op2_size
));
2878 mpz_clear (op1_size
);
2880 mpz_clear (op2_size
);
2890 /* Given an assignable expression and an arbitrary expression, make
2891 sure that the assignment can take place. */
2894 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2900 sym
= lvalue
->symtree
->n
.sym
;
2902 /* Check INTENT(IN), unless the object itself is the component or
2903 sub-component of a pointer. */
2904 has_pointer
= sym
->attr
.pointer
;
2906 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2907 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
2913 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2915 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2916 sym
->name
, &lvalue
->where
);
2920 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2921 variable local to a function subprogram. Its existence begins when
2922 execution of the function is initiated and ends when execution of the
2923 function is terminated...
2924 Therefore, the left hand side is no longer a variable, when it is: */
2925 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2926 && !sym
->attr
.external
)
2931 /* (i) Use associated; */
2932 if (sym
->attr
.use_assoc
)
2935 /* (ii) The assignment is in the main program; or */
2936 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2939 /* (iii) A module or internal procedure... */
2940 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2941 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2942 && gfc_current_ns
->parent
2943 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2944 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2945 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2947 /* ... that is not a function... */
2948 if (!gfc_current_ns
->proc_name
->attr
.function
)
2951 /* ... or is not an entry and has a different name. */
2952 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2956 /* (iv) Host associated and not the function symbol or the
2957 parent result. This picks up sibling references, which
2958 cannot be entries. */
2959 if (!sym
->attr
.entry
2960 && sym
->ns
== gfc_current_ns
->parent
2961 && sym
!= gfc_current_ns
->proc_name
2962 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
2967 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2972 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2974 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2975 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2979 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2981 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2986 if (rvalue
->expr_type
== EXPR_NULL
)
2988 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
2989 && lvalue
->symtree
->n
.sym
->attr
.data
)
2993 gfc_error ("NULL appears on right-hand side in assignment at %L",
2999 if (sym
->attr
.cray_pointee
3000 && lvalue
->ref
!= NULL
3001 && lvalue
->ref
->u
.ar
.type
== AR_FULL
3002 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
3004 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
3005 "is illegal", &lvalue
->where
);
3009 /* This is possibly a typo: x = f() instead of x => f(). */
3010 if (gfc_option
.warn_surprising
3011 && rvalue
->expr_type
== EXPR_FUNCTION
3012 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
3013 gfc_warning ("POINTER valued function appears on right-hand side of "
3014 "assignment at %L", &rvalue
->where
);
3016 /* Check size of array assignments. */
3017 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3018 && gfc_check_conformance (lvalue
, rvalue
, "array assignment") != SUCCESS
)
3021 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3022 && lvalue
->symtree
->n
.sym
->attr
.data
3023 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
3024 "initialize non-integer variable '%s'",
3025 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
3028 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3029 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
3030 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3031 &rvalue
->where
) == FAILURE
)
3034 /* Handle the case of a BOZ literal on the RHS. */
3035 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3038 if (gfc_option
.warn_surprising
)
3039 gfc_warning ("BOZ literal at %L is bitwise transferred "
3040 "non-integer symbol '%s'", &rvalue
->where
,
3041 lvalue
->symtree
->n
.sym
->name
);
3042 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3044 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3046 if (rc
== ARITH_UNDERFLOW
)
3047 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3048 ". This check can be disabled with the option "
3049 "-fno-range-check", &rvalue
->where
);
3050 else if (rc
== ARITH_OVERFLOW
)
3051 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3052 ". This check can be disabled with the option "
3053 "-fno-range-check", &rvalue
->where
);
3054 else if (rc
== ARITH_NAN
)
3055 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3056 ". This check can be disabled with the option "
3057 "-fno-range-check", &rvalue
->where
);
3062 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3065 /* Only DATA Statements come here. */
3068 /* Numeric can be converted to any other numeric. And Hollerith can be
3069 converted to any other type. */
3070 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3071 || rvalue
->ts
.type
== BT_HOLLERITH
)
3074 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3077 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3078 "conversion of %s to %s", &lvalue
->where
,
3079 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3084 /* Assignment is the only case where character variables of different
3085 kind values can be converted into one another. */
3086 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3088 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3089 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3094 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3098 /* Check that a pointer assignment is OK. We first check lvalue, and
3099 we only check rvalue if it's not an assignment to NULL() or a
3100 NULLIFY statement. */
3103 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3105 symbol_attribute attr
;
3108 int pointer
, check_intent_in
, proc_pointer
;
3110 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
3111 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3113 gfc_error ("Pointer assignment target is not a POINTER at %L",
3118 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
3119 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
3120 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3122 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3123 "l-value since it is a procedure",
3124 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3129 /* Check INTENT(IN), unless the object itself is the component or
3130 sub-component of a pointer. */
3131 check_intent_in
= 1;
3132 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
3133 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3135 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3138 check_intent_in
= 0;
3140 if (ref
->type
== REF_COMPONENT
)
3142 pointer
= ref
->u
.c
.component
->attr
.pointer
;
3143 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3146 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3148 if (ref
->u
.ar
.type
== AR_FULL
)
3151 if (ref
->u
.ar
.type
!= AR_SECTION
)
3153 gfc_error ("Expected bounds specification for '%s' at %L",
3154 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3158 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
3159 "specification for '%s' in pointer assignment "
3160 "at %L", lvalue
->symtree
->n
.sym
->name
,
3161 &lvalue
->where
) == FAILURE
)
3164 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3165 "in gfortran", &lvalue
->where
);
3166 /* TODO: See PR 29785. Add checks that all lbounds are specified and
3167 either never or always the upper-bound; strides shall not be
3173 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
3175 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3176 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3180 if (!pointer
&& !proc_pointer
3181 && !(lvalue
->ts
.type
== BT_CLASS
3182 && lvalue
->ts
.u
.derived
->components
->attr
.pointer
))
3184 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
3188 is_pure
= gfc_pure (NULL
);
3190 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
3191 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
3193 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
3197 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3198 kind, etc for lvalue and rvalue must match, and rvalue must be a
3199 pure variable if we're in a pure function. */
3200 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3203 /* Checks on rvalue for procedure pointer assignments. */
3208 gfc_component
*comp
;
3211 attr
= gfc_expr_attr (rvalue
);
3212 if (!((rvalue
->expr_type
== EXPR_NULL
)
3213 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3214 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3215 || (rvalue
->expr_type
== EXPR_VARIABLE
3216 && attr
.flavor
== FL_PROCEDURE
)))
3218 gfc_error ("Invalid procedure pointer assignment at %L",
3224 gfc_error ("Abstract interface '%s' is invalid "
3225 "in procedure pointer assignment at %L",
3226 rvalue
->symtree
->name
, &rvalue
->where
);
3229 /* Check for C727. */
3230 if (attr
.flavor
== FL_PROCEDURE
)
3232 if (attr
.proc
== PROC_ST_FUNCTION
)
3234 gfc_error ("Statement function '%s' is invalid "
3235 "in procedure pointer assignment at %L",
3236 rvalue
->symtree
->name
, &rvalue
->where
);
3239 if (attr
.proc
== PROC_INTERNAL
&&
3240 gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is "
3241 "invalid in procedure pointer assignment at %L",
3242 rvalue
->symtree
->name
, &rvalue
->where
) == FAILURE
)
3246 /* Ensure that the calling convention is the same. As other attributes
3247 such as DLLEXPORT may differ, one explicitly only tests for the
3248 calling conventions. */
3249 if (rvalue
->expr_type
== EXPR_VARIABLE
3250 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3251 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3253 symbol_attribute calls
;
3256 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3257 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3258 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3260 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3261 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3263 gfc_error ("Mismatch in the procedure pointer assignment "
3264 "at %L: mismatch in the calling convention",
3270 if (gfc_is_proc_ptr_comp (lvalue
, &comp
))
3271 s1
= comp
->ts
.interface
;
3273 s1
= lvalue
->symtree
->n
.sym
;
3275 if (gfc_is_proc_ptr_comp (rvalue
, &comp
))
3277 s2
= comp
->ts
.interface
;
3280 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3282 s2
= rvalue
->symtree
->n
.sym
->result
;
3283 name
= rvalue
->symtree
->n
.sym
->result
->name
;
3287 s2
= rvalue
->symtree
->n
.sym
;
3288 name
= rvalue
->symtree
->n
.sym
->name
;
3291 if (s1
&& s2
&& !gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3294 gfc_error ("Interface mismatch in procedure pointer assignment "
3295 "at %L: %s", &rvalue
->where
, err
);
3302 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3304 gfc_error ("Different types in pointer assignment at %L; attempted "
3305 "assignment of %s to %s", &lvalue
->where
,
3306 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3310 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3312 gfc_error ("Different kind type parameters in pointer "
3313 "assignment at %L", &lvalue
->where
);
3317 if (lvalue
->rank
!= rvalue
->rank
)
3319 gfc_error ("Different ranks in pointer assignment at %L",
3324 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3325 if (rvalue
->expr_type
== EXPR_NULL
)
3328 if (lvalue
->ts
.type
== BT_CHARACTER
)
3330 gfc_try t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3335 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3336 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3338 attr
= gfc_expr_attr (rvalue
);
3339 if (!attr
.target
&& !attr
.pointer
)
3341 gfc_error ("Pointer assignment target is neither TARGET "
3342 "nor POINTER at %L", &rvalue
->where
);
3346 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3348 gfc_error ("Bad target in pointer assignment in PURE "
3349 "procedure at %L", &rvalue
->where
);
3352 if (gfc_has_vector_index (rvalue
))
3354 gfc_error ("Pointer assignment with vector subscript "
3355 "on rhs at %L", &rvalue
->where
);
3359 if (attr
.is_protected
&& attr
.use_assoc
3360 && !(attr
.pointer
|| attr
.proc_pointer
))
3362 gfc_error ("Pointer assignment target has PROTECTED "
3363 "attribute at %L", &rvalue
->where
);
3371 /* Relative of gfc_check_assign() except that the lvalue is a single
3372 symbol. Used for initialization assignments. */
3375 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3380 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3382 lvalue
.expr_type
= EXPR_VARIABLE
;
3383 lvalue
.ts
= sym
->ts
;
3385 lvalue
.rank
= sym
->as
->rank
;
3386 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
3387 lvalue
.symtree
->n
.sym
= sym
;
3388 lvalue
.where
= sym
->declared_at
;
3390 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
3391 || (sym
->ts
.type
== BT_CLASS
3392 && sym
->ts
.u
.derived
->components
->attr
.pointer
3393 && rvalue
->expr_type
== EXPR_NULL
))
3394 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3396 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3398 gfc_free (lvalue
.symtree
);
3404 /* Get an expression for a default initializer. */
3407 gfc_default_initializer (gfc_typespec
*ts
)
3409 gfc_constructor
*tail
;
3413 /* See if we have a default initializer. */
3414 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
3415 if (c
->initializer
|| c
->attr
.allocatable
)
3421 /* Build the constructor. */
3422 init
= gfc_get_expr ();
3423 init
->expr_type
= EXPR_STRUCTURE
;
3425 init
->where
= ts
->u
.derived
->declared_at
;
3428 for (c
= ts
->u
.derived
->components
; c
; c
= c
->next
)
3431 init
->value
.constructor
= tail
= gfc_get_constructor ();
3434 tail
->next
= gfc_get_constructor ();
3439 tail
->expr
= gfc_copy_expr (c
->initializer
);
3441 if (c
->attr
.allocatable
)
3443 tail
->expr
= gfc_get_expr ();
3444 tail
->expr
->expr_type
= EXPR_NULL
;
3445 tail
->expr
->ts
= c
->ts
;
3452 /* Given a symbol, create an expression node with that symbol as a
3453 variable. If the symbol is array valued, setup a reference of the
3457 gfc_get_variable_expr (gfc_symtree
*var
)
3461 e
= gfc_get_expr ();
3462 e
->expr_type
= EXPR_VARIABLE
;
3464 e
->ts
= var
->n
.sym
->ts
;
3466 if (var
->n
.sym
->as
!= NULL
)
3468 e
->rank
= var
->n
.sym
->as
->rank
;
3469 e
->ref
= gfc_get_ref ();
3470 e
->ref
->type
= REF_ARRAY
;
3471 e
->ref
->u
.ar
.type
= AR_FULL
;
3478 /* General expression traversal function. */
3481 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3482 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3487 gfc_actual_arglist
*args
;
3494 if ((*func
) (expr
, sym
, &f
))
3497 if (expr
->ts
.type
== BT_CHARACTER
3499 && expr
->ts
.u
.cl
->length
3500 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
3501 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
3504 switch (expr
->expr_type
)
3507 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3509 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3517 case EXPR_SUBSTRING
:
3520 case EXPR_STRUCTURE
:
3522 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3524 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3528 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3530 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3532 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3534 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3541 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3543 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3559 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3561 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3563 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3565 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3571 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3573 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3578 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3579 && ref
->u
.c
.component
->ts
.u
.cl
3580 && ref
->u
.c
.component
->ts
.u
.cl
->length
3581 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
3583 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
3587 if (ref
->u
.c
.component
->as
)
3588 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3590 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3593 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3607 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3610 expr_set_symbols_referenced (gfc_expr
*expr
,
3611 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3612 int *f ATTRIBUTE_UNUSED
)
3614 if (expr
->expr_type
!= EXPR_VARIABLE
)
3616 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3621 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3623 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
3627 /* Determine if an expression is a procedure pointer component. If yes, the
3628 argument 'comp' will point to the component (provided that 'comp' was
3632 gfc_is_proc_ptr_comp (gfc_expr
*expr
, gfc_component
**comp
)
3637 if (!expr
|| !expr
->ref
)
3644 if (ref
->type
== REF_COMPONENT
)
3646 ppc
= ref
->u
.c
.component
->attr
.proc_pointer
;
3648 *comp
= ref
->u
.c
.component
;
3655 /* Walk an expression tree and check each variable encountered for being typed.
3656 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3657 mode as is a basic arithmetic expression using those; this is for things in
3660 INTEGER :: arr(n), n
3661 INTEGER :: arr(n + 1), n
3663 The namespace is needed for IMPLICIT typing. */
3665 static gfc_namespace
* check_typed_ns
;
3668 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3669 int* f ATTRIBUTE_UNUSED
)
3673 if (e
->expr_type
!= EXPR_VARIABLE
)
3676 gcc_assert (e
->symtree
);
3677 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
3680 return (t
== FAILURE
);
3684 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
3688 /* If this is a top-level variable or EXPR_OP, do the check with strict given
3692 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
3693 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
3695 if (e
->expr_type
== EXPR_OP
)
3697 gfc_try t
= SUCCESS
;
3699 gcc_assert (e
->value
.op
.op1
);
3700 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
3702 if (t
== SUCCESS
&& e
->value
.op
.op2
)
3703 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
3709 /* Otherwise, walk the expression and do it strictly. */
3710 check_typed_ns
= ns
;
3711 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
3713 return error_found
? FAILURE
: SUCCESS
;
3716 /* Walk an expression tree and replace all symbols with a corresponding symbol
3717 in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3718 statements. The boolean return value is required by gfc_traverse_expr. */
3721 replace_symbol (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3723 if ((expr
->expr_type
== EXPR_VARIABLE
3724 || (expr
->expr_type
== EXPR_FUNCTION
3725 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
3726 && expr
->symtree
->n
.sym
->ns
== sym
->ts
.interface
->formal_ns
)
3729 gfc_namespace
*ns
= sym
->formal_ns
;
3730 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3731 the symtree rather than create a new one (and probably fail later). */
3732 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
3733 expr
->symtree
->n
.sym
->name
);
3735 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
3736 expr
->symtree
= stree
;
3742 gfc_expr_replace_symbols (gfc_expr
*expr
, gfc_symbol
*dest
)
3744 gfc_traverse_expr (expr
, dest
, &replace_symbol
, 0);
3747 /* The following is analogous to 'replace_symbol', and needed for copying
3748 interfaces for procedure pointer components. The argument 'sym' must formally
3749 be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3750 However, it gets actually passed a gfc_component (i.e. the procedure pointer
3751 component in whose formal_ns the arguments have to be). */
3754 replace_comp (gfc_expr
*expr
, gfc_symbol
*sym
, int *i ATTRIBUTE_UNUSED
)
3756 gfc_component
*comp
;
3757 comp
= (gfc_component
*)sym
;
3758 if ((expr
->expr_type
== EXPR_VARIABLE
3759 || (expr
->expr_type
== EXPR_FUNCTION
3760 && !gfc_is_intrinsic (expr
->symtree
->n
.sym
, 0, expr
->where
)))
3761 && expr
->symtree
->n
.sym
->ns
== comp
->ts
.interface
->formal_ns
)
3764 gfc_namespace
*ns
= comp
->formal_ns
;
3765 /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3766 the symtree rather than create a new one (and probably fail later). */
3767 stree
= gfc_find_symtree (ns
? ns
->sym_root
: gfc_current_ns
->sym_root
,
3768 expr
->symtree
->n
.sym
->name
);
3770 stree
->n
.sym
->attr
= expr
->symtree
->n
.sym
->attr
;
3771 expr
->symtree
= stree
;
3777 gfc_expr_replace_comp (gfc_expr
*expr
, gfc_component
*dest
)
3779 gfc_traverse_expr (expr
, (gfc_symbol
*)dest
, &replace_comp
, 0);