1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
38 gfc_clear_ts (&e
->ts
);
47 /* Free an argument list and everything below it. */
50 gfc_free_actual_arglist (gfc_actual_arglist
* a1
)
52 gfc_actual_arglist
*a2
;
57 gfc_free_expr (a1
->expr
);
64 /* Copy an arglist structure and all of the arguments. */
67 gfc_copy_actual_arglist (gfc_actual_arglist
* p
)
69 gfc_actual_arglist
*head
, *tail
, *new;
73 for (; p
; p
= p
->next
)
75 new = gfc_get_actual_arglist ();
78 new->expr
= gfc_copy_expr (p
->expr
);
93 /* Free a list of reference structures. */
96 gfc_free_ref_list (gfc_ref
* p
)
108 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
110 gfc_free_expr (p
->u
.ar
.start
[i
]);
111 gfc_free_expr (p
->u
.ar
.end
[i
]);
112 gfc_free_expr (p
->u
.ar
.stride
[i
]);
118 gfc_free_expr (p
->u
.ss
.start
);
119 gfc_free_expr (p
->u
.ss
.end
);
131 /* Workhorse function for gfc_free_expr() that frees everything
132 beneath an expression node, but not the node itself. This is
133 useful when we want to simplify a node and replace it with
134 something else or the expression node belongs to another structure. */
137 free_expr0 (gfc_expr
* e
)
141 switch (e
->expr_type
)
146 gfc_free (e
->value
.character
.string
);
153 mpz_clear (e
->value
.integer
);
157 mpfr_clear (e
->value
.real
);
162 gfc_free (e
->value
.character
.string
);
166 mpfr_clear (e
->value
.complex.r
);
167 mpfr_clear (e
->value
.complex.i
);
177 if (e
->value
.op
.op1
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op1
);
179 if (e
->value
.op
.op2
!= NULL
)
180 gfc_free_expr (e
->value
.op
.op2
);
184 gfc_free_actual_arglist (e
->value
.function
.actual
);
192 gfc_free_constructor (e
->value
.constructor
);
196 gfc_free (e
->value
.character
.string
);
203 gfc_internal_error ("free_expr0(): Bad expr type");
206 /* Free a shape array. */
207 if (e
->shape
!= NULL
)
209 for (n
= 0; n
< e
->rank
; n
++)
210 mpz_clear (e
->shape
[n
]);
215 gfc_free_ref_list (e
->ref
);
217 memset (e
, '\0', sizeof (gfc_expr
));
221 /* Free an expression node and everything beneath it. */
224 gfc_free_expr (gfc_expr
* e
)
235 /* Graft the *src expression onto the *dest subexpression. */
238 gfc_replace_expr (gfc_expr
* dest
, gfc_expr
* src
)
248 /* Try to extract an integer constant from the passed expression node.
249 Returns an error message or NULL if the result is set. It is
250 tempting to generate an error and return SUCCESS or FAILURE, but
251 failure is OK for some callers. */
254 gfc_extract_int (gfc_expr
* expr
, int *result
)
257 if (expr
->expr_type
!= EXPR_CONSTANT
)
258 return _("Constant expression required at %C");
260 if (expr
->ts
.type
!= BT_INTEGER
)
261 return _("Integer expression required at %C");
263 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
264 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
266 return _("Integer value too large in expression at %C");
269 *result
= (int) mpz_get_si (expr
->value
.integer
);
275 /* Recursively copy a list of reference structures. */
278 copy_ref (gfc_ref
* src
)
286 dest
= gfc_get_ref ();
287 dest
->type
= src
->type
;
292 ar
= gfc_copy_array_ref (&src
->u
.ar
);
298 dest
->u
.c
= src
->u
.c
;
302 dest
->u
.ss
= src
->u
.ss
;
303 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
304 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
308 dest
->next
= copy_ref (src
->next
);
314 /* Copy a shape array. */
317 gfc_copy_shape (mpz_t
* shape
, int rank
)
325 new_shape
= gfc_get_shape (rank
);
327 for (n
= 0; n
< rank
; n
++)
328 mpz_init_set (new_shape
[n
], shape
[n
]);
334 /* Copy a shape array excluding dimension N, where N is an integer
335 constant expression. Dimensions are numbered in fortran style --
338 So, if the original shape array contains R elements
339 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
340 the result contains R-1 elements:
341 { s1 ... sN-1 sN+1 ... sR-1}
343 If anything goes wrong -- N is not a constant, its value is out
344 of range -- or anything else, just returns NULL.
348 gfc_copy_shape_excluding (mpz_t
* shape
, int rank
, gfc_expr
* dim
)
350 mpz_t
*new_shape
, *s
;
356 || dim
->expr_type
!= EXPR_CONSTANT
357 || dim
->ts
.type
!= BT_INTEGER
)
360 n
= mpz_get_si (dim
->value
.integer
);
361 n
--; /* Convert to zero based index */
362 if (n
< 0 || n
>= rank
)
365 s
= new_shape
= gfc_get_shape (rank
-1);
367 for (i
= 0; i
< rank
; i
++)
371 mpz_init_set (*s
, shape
[i
]);
378 /* Given an expression pointer, return a copy of the expression. This
379 subroutine is recursive. */
382 gfc_copy_expr (gfc_expr
* p
)
393 switch (q
->expr_type
)
396 s
= gfc_getmem (p
->value
.character
.length
+ 1);
397 q
->value
.character
.string
= s
;
399 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
405 s
= gfc_getmem (p
->value
.character
.length
+ 1);
406 q
->value
.character
.string
= s
;
408 memcpy (s
, p
->value
.character
.string
,
409 p
->value
.character
.length
+ 1);
415 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
419 gfc_set_model_kind (q
->ts
.kind
);
420 mpfr_init (q
->value
.real
);
421 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
425 gfc_set_model_kind (q
->ts
.kind
);
426 mpfr_init (q
->value
.complex.r
);
427 mpfr_init (q
->value
.complex.i
);
428 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
429 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
434 s
= gfc_getmem (p
->value
.character
.length
+ 1);
435 q
->value
.character
.string
= s
;
437 memcpy (s
, p
->value
.character
.string
,
438 p
->value
.character
.length
+ 1);
443 break; /* Already done */
447 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
454 switch (q
->value
.op
.operator)
457 case INTRINSIC_UPLUS
:
458 case INTRINSIC_UMINUS
:
459 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
462 default: /* Binary operators */
463 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
464 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
471 q
->value
.function
.actual
=
472 gfc_copy_actual_arglist (p
->value
.function
.actual
);
477 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
485 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
487 q
->ref
= copy_ref (p
->ref
);
493 /* Return the maximum kind of two expressions. In general, higher
494 kind numbers mean more precision for numeric types. */
497 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
500 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
504 /* Returns nonzero if the type is numeric, zero otherwise. */
507 numeric_type (bt type
)
510 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
514 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
517 gfc_numeric_ts (gfc_typespec
* ts
)
520 return numeric_type (ts
->type
);
524 /* Returns an expression node that is an integer constant. */
533 p
->expr_type
= EXPR_CONSTANT
;
534 p
->ts
.type
= BT_INTEGER
;
535 p
->ts
.kind
= gfc_default_integer_kind
;
537 p
->where
= gfc_current_locus
;
538 mpz_init_set_si (p
->value
.integer
, i
);
544 /* Returns an expression node that is a logical constant. */
547 gfc_logical_expr (int i
, locus
* where
)
553 p
->expr_type
= EXPR_CONSTANT
;
554 p
->ts
.type
= BT_LOGICAL
;
555 p
->ts
.kind
= gfc_default_logical_kind
;
558 where
= &gfc_current_locus
;
560 p
->value
.logical
= i
;
566 /* Return an expression node with an optional argument list attached.
567 A variable number of gfc_expr pointers are strung together in an
568 argument list with a NULL pointer terminating the list. */
571 gfc_build_conversion (gfc_expr
* e
)
576 p
->expr_type
= EXPR_FUNCTION
;
578 p
->value
.function
.actual
= NULL
;
580 p
->value
.function
.actual
= gfc_get_actual_arglist ();
581 p
->value
.function
.actual
->expr
= e
;
587 /* Given an expression node with some sort of numeric binary
588 expression, insert type conversions required to make the operands
591 The exception is that the operands of an exponential don't have to
592 have the same type. If possible, the base is promoted to the type
593 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
594 1.0**2 stays as it is. */
597 gfc_type_convert_binary (gfc_expr
* e
)
601 op1
= e
->value
.op
.op1
;
602 op2
= e
->value
.op
.op2
;
604 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
606 gfc_clear_ts (&e
->ts
);
610 /* Kind conversions of same type. */
611 if (op1
->ts
.type
== op2
->ts
.type
)
614 if (op1
->ts
.kind
== op2
->ts
.kind
)
616 /* No type conversions. */
621 if (op1
->ts
.kind
> op2
->ts
.kind
)
622 gfc_convert_type (op2
, &op1
->ts
, 2);
624 gfc_convert_type (op1
, &op2
->ts
, 2);
630 /* Integer combined with real or complex. */
631 if (op2
->ts
.type
== BT_INTEGER
)
635 /* Special case for ** operator. */
636 if (e
->value
.op
.operator == INTRINSIC_POWER
)
639 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
643 if (op1
->ts
.type
== BT_INTEGER
)
646 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
650 /* Real combined with complex. */
651 e
->ts
.type
= BT_COMPLEX
;
652 if (op1
->ts
.kind
> op2
->ts
.kind
)
653 e
->ts
.kind
= op1
->ts
.kind
;
655 e
->ts
.kind
= op2
->ts
.kind
;
656 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
657 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
658 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
659 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
666 /* Function to determine if an expression is constant or not. This
667 function expects that the expression has already been simplified. */
670 gfc_is_constant_expr (gfc_expr
* e
)
673 gfc_actual_arglist
*arg
;
679 switch (e
->expr_type
)
682 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
683 && (e
->value
.op
.op2
== NULL
684 || gfc_is_constant_expr (e
->value
.op
.op2
)));
693 /* Call to intrinsic with at least one argument. */
695 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
697 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
699 if (!gfc_is_constant_expr (arg
->expr
))
713 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
714 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
719 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
720 if (!gfc_is_constant_expr (c
->expr
))
728 rv
= gfc_constant_ac (e
);
732 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
739 /* Try to collapse intrinsic expressions. */
742 simplify_intrinsic_op (gfc_expr
* p
, int type
)
744 gfc_expr
*op1
, *op2
, *result
;
746 if (p
->value
.op
.operator == INTRINSIC_USER
)
749 op1
= p
->value
.op
.op1
;
750 op2
= p
->value
.op
.op2
;
752 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
754 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
757 if (!gfc_is_constant_expr (op1
)
758 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
762 p
->value
.op
.op1
= NULL
;
763 p
->value
.op
.op2
= NULL
;
765 switch (p
->value
.op
.operator)
767 case INTRINSIC_UPLUS
:
768 result
= gfc_uplus (op1
);
771 case INTRINSIC_UMINUS
:
772 result
= gfc_uminus (op1
);
776 result
= gfc_add (op1
, op2
);
779 case INTRINSIC_MINUS
:
780 result
= gfc_subtract (op1
, op2
);
783 case INTRINSIC_TIMES
:
784 result
= gfc_multiply (op1
, op2
);
787 case INTRINSIC_DIVIDE
:
788 result
= gfc_divide (op1
, op2
);
791 case INTRINSIC_POWER
:
792 result
= gfc_power (op1
, op2
);
795 case INTRINSIC_CONCAT
:
796 result
= gfc_concat (op1
, op2
);
800 result
= gfc_eq (op1
, op2
);
804 result
= gfc_ne (op1
, op2
);
808 result
= gfc_gt (op1
, op2
);
812 result
= gfc_ge (op1
, op2
);
816 result
= gfc_lt (op1
, op2
);
820 result
= gfc_le (op1
, op2
);
824 result
= gfc_not (op1
);
828 result
= gfc_and (op1
, op2
);
832 result
= gfc_or (op1
, op2
);
836 result
= gfc_eqv (op1
, op2
);
840 result
= gfc_neqv (op1
, op2
);
844 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
854 gfc_replace_expr (p
, result
);
860 /* Subroutine to simplify constructor expressions. Mutually recursive
861 with gfc_simplify_expr(). */
864 simplify_constructor (gfc_constructor
* c
, int type
)
867 for (; c
; c
= c
->next
)
870 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
871 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
872 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
875 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
883 /* Pull a single array element out of an array constructor. */
885 static gfc_constructor
*
886 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
)
888 unsigned long nelemen
;
893 mpz_init_set_ui (offset
, 0);
895 for (i
= 0; i
< ar
->dimen
; i
++)
897 if (ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
)
902 mpz_sub (delta
, ar
->start
[i
]->value
.integer
,
903 ar
->as
->lower
[i
]->value
.integer
);
904 mpz_add (offset
, offset
, delta
);
909 if (mpz_fits_ulong_p (offset
))
911 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
932 /* Find a component of a structure constructor. */
934 static gfc_constructor
*
935 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
940 comp
= ref
->u
.c
.sym
->components
;
941 pick
= ref
->u
.c
.component
;
952 /* Replace an expression with the contents of a constructor, removing
953 the subobject reference in the process. */
956 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
962 e
->ref
= p
->ref
->next
;
964 gfc_replace_expr (p
, e
);
968 /* Simplify a subobject reference of a constructor. This occurs when
969 parameter variable values are substituted. */
972 simplify_const_ref (gfc_expr
* p
)
974 gfc_constructor
*cons
;
978 switch (p
->ref
->type
)
981 switch (p
->ref
->u
.ar
.type
)
984 cons
= find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
);
987 remove_subobject_ref (p
, cons
);
991 if (p
->ref
->next
!= NULL
)
993 /* TODO: Simplify array subobject references. */
996 gfc_free_ref_list (p
->ref
);
1001 /* TODO: Simplify array subsections. */
1008 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1009 remove_subobject_ref (p
, cons
);
1013 /* TODO: Constant substrings. */
1022 /* Simplify a chain of references. */
1025 simplify_ref_chain (gfc_ref
* ref
, int type
)
1029 for (; ref
; ref
= ref
->next
)
1034 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1036 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1039 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1042 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1049 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1051 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1063 /* Try to substitute the value of a parameter variable. */
1065 simplify_parameter_variable (gfc_expr
* p
, int type
)
1070 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1071 /* Do not copy subobject refs for constant. */
1072 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1073 e
->ref
= copy_ref (p
->ref
);
1074 t
= gfc_simplify_expr (e
, type
);
1076 /* Only use the simplification if it eliminated all subobject
1078 if (t
== SUCCESS
&& ! e
->ref
)
1079 gfc_replace_expr (p
, e
);
1086 /* Given an expression, simplify it by collapsing constant
1087 expressions. Most simplification takes place when the expression
1088 tree is being constructed. If an intrinsic function is simplified
1089 at some point, we get called again to collapse the result against
1092 We work by recursively simplifying expression nodes, simplifying
1093 intrinsic functions where possible, which can lead to further
1094 constant collapsing. If an operator has constant operand(s), we
1095 rip the expression apart, and rebuild it, hoping that it becomes
1098 The expression type is defined for:
1099 0 Basic expression parsing
1100 1 Simplifying array constructors -- will substitute
1102 Returns FAILURE on error, SUCCESS otherwise.
1103 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1106 gfc_simplify_expr (gfc_expr
* p
, int type
)
1108 gfc_actual_arglist
*ap
;
1113 switch (p
->expr_type
)
1120 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1121 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1124 if (p
->value
.function
.isym
!= NULL
1125 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1130 case EXPR_SUBSTRING
:
1131 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1134 if (gfc_is_constant_expr (p
))
1139 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1140 start
--; /* Convert from one-based to zero-based. */
1141 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1142 s
= gfc_getmem (end
- start
+ 1);
1143 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1144 s
[end
] = '\0'; /* TODO: C-style string for debugging. */
1145 gfc_free (p
->value
.character
.string
);
1146 p
->value
.character
.string
= s
;
1147 p
->value
.character
.length
= end
- start
;
1148 p
->ts
.cl
= gfc_get_charlen ();
1149 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1150 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1151 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1152 gfc_free_ref_list (p
->ref
);
1154 p
->expr_type
= EXPR_CONSTANT
;
1159 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1164 /* Only substitute array parameter variables if we are in an
1165 initialization expression, or we want a subsection. */
1166 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1167 && (gfc_init_expr
|| p
->ref
1168 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1170 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1177 gfc_simplify_iterator_var (p
);
1180 /* Simplify subcomponent references. */
1181 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1186 case EXPR_STRUCTURE
:
1188 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1191 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1194 if (p
->expr_type
== EXPR_ARRAY
)
1195 gfc_expand_constructor (p
);
1197 if (simplify_const_ref (p
) == FAILURE
)
1207 /* Returns the type of an expression with the exception that iterator
1208 variables are automatically integers no matter what else they may
1215 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1222 /* Check an intrinsic arithmetic operation to see if it is consistent
1223 with some type of expression. */
1225 static try check_init_expr (gfc_expr
*);
1228 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1230 gfc_expr
*op1
= e
->value
.op
.op1
;
1231 gfc_expr
*op2
= e
->value
.op
.op2
;
1233 if ((*check_function
) (op1
) == FAILURE
)
1236 switch (e
->value
.op
.operator)
1238 case INTRINSIC_UPLUS
:
1239 case INTRINSIC_UMINUS
:
1240 if (!numeric_type (et0 (op1
)))
1250 if ((*check_function
) (op2
) == FAILURE
)
1253 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1254 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1256 gfc_error ("Numeric or CHARACTER operands are required in "
1257 "expression at %L", &e
->where
);
1262 case INTRINSIC_PLUS
:
1263 case INTRINSIC_MINUS
:
1264 case INTRINSIC_TIMES
:
1265 case INTRINSIC_DIVIDE
:
1266 case INTRINSIC_POWER
:
1267 if ((*check_function
) (op2
) == FAILURE
)
1270 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1273 if (e
->value
.op
.operator == INTRINSIC_POWER
1274 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1276 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1277 "expression", &op2
->where
);
1283 case INTRINSIC_CONCAT
:
1284 if ((*check_function
) (op2
) == FAILURE
)
1287 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1289 gfc_error ("Concatenation operator in expression at %L "
1290 "must have two CHARACTER operands", &op1
->where
);
1294 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1296 gfc_error ("Concat operator at %L must concatenate strings of the "
1297 "same kind", &e
->where
);
1304 if (et0 (op1
) != BT_LOGICAL
)
1306 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1307 "operand", &op1
->where
);
1316 case INTRINSIC_NEQV
:
1317 if ((*check_function
) (op2
) == FAILURE
)
1320 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1322 gfc_error ("LOGICAL operands are required in expression at %L",
1330 gfc_error ("Only intrinsic operators can be used in expression at %L",
1338 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1345 /* Certain inquiry functions are specifically allowed to have variable
1346 arguments, which is an exception to the normal requirement that an
1347 initialization function have initialization arguments. We head off
1348 this problem here. */
1351 check_inquiry (gfc_expr
* e
)
1355 /* FIXME: This should be moved into the intrinsic definitions,
1356 to eliminate this ugly hack. */
1357 static const char * const inquiry_function
[] = {
1358 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1359 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1360 "lbound", "ubound", NULL
1365 name
= e
->symtree
->n
.sym
->name
;
1367 for (i
= 0; inquiry_function
[i
]; i
++)
1368 if (strcmp (inquiry_function
[i
], name
) == 0)
1371 if (inquiry_function
[i
] == NULL
)
1374 e
= e
->value
.function
.actual
->expr
;
1376 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1379 /* At this point we have an inquiry function with a variable argument. The
1380 type of the variable might be undefined, but we need it now, because the
1381 arguments of these functions are allowed to be undefined. */
1383 if (e
->ts
.type
== BT_UNKNOWN
)
1385 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1386 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1390 e
->ts
= e
->symtree
->n
.sym
->ts
;
1397 /* Verify that an expression is an initialization expression. A side
1398 effect is that the expression tree is reduced to a single constant
1399 node if all goes well. This would normally happen when the
1400 expression is constructed but function references are assumed to be
1401 intrinsics in the context of initialization expressions. If
1402 FAILURE is returned an error message has been generated. */
1405 check_init_expr (gfc_expr
* e
)
1407 gfc_actual_arglist
*ap
;
1414 switch (e
->expr_type
)
1417 t
= check_intrinsic_op (e
, check_init_expr
);
1419 t
= gfc_simplify_expr (e
, 0);
1426 if (check_inquiry (e
) != SUCCESS
)
1429 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1430 if (check_init_expr (ap
->expr
) == FAILURE
)
1439 m
= gfc_intrinsic_func_interface (e
, 0);
1442 gfc_error ("Function '%s' in initialization expression at %L "
1443 "must be an intrinsic function",
1444 e
->symtree
->n
.sym
->name
, &e
->where
);
1455 if (gfc_check_iter_variable (e
) == SUCCESS
)
1458 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1460 t
= simplify_parameter_variable (e
, 0);
1464 gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1465 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1474 case EXPR_SUBSTRING
:
1475 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1479 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1481 t
= gfc_simplify_expr (e
, 0);
1485 case EXPR_STRUCTURE
:
1486 t
= gfc_check_constructor (e
, check_init_expr
);
1490 t
= gfc_check_constructor (e
, check_init_expr
);
1494 t
= gfc_expand_constructor (e
);
1498 t
= gfc_check_constructor_type (e
);
1502 gfc_internal_error ("check_init_expr(): Unknown expression type");
1509 /* Match an initialization expression. We work by first matching an
1510 expression, then reducing it to a constant. */
1513 gfc_match_init_expr (gfc_expr
** result
)
1519 m
= gfc_match_expr (&expr
);
1524 t
= gfc_resolve_expr (expr
);
1526 t
= check_init_expr (expr
);
1531 gfc_free_expr (expr
);
1535 if (expr
->expr_type
== EXPR_ARRAY
1536 && (gfc_check_constructor_type (expr
) == FAILURE
1537 || gfc_expand_constructor (expr
) == FAILURE
))
1539 gfc_free_expr (expr
);
1543 if (!gfc_is_constant_expr (expr
))
1544 gfc_internal_error ("Initialization expression didn't reduce %C");
1553 static try check_restricted (gfc_expr
*);
1555 /* Given an actual argument list, test to see that each argument is a
1556 restricted expression and optionally if the expression type is
1557 integer or character. */
1560 restricted_args (gfc_actual_arglist
* a
)
1562 for (; a
; a
= a
->next
)
1564 if (check_restricted (a
->expr
) == FAILURE
)
1572 /************* Restricted/specification expressions *************/
1575 /* Make sure a non-intrinsic function is a specification function. */
1578 external_spec_function (gfc_expr
* e
)
1582 f
= e
->value
.function
.esym
;
1584 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1586 gfc_error ("Specification function '%s' at %L cannot be a statement "
1587 "function", f
->name
, &e
->where
);
1591 if (f
->attr
.proc
== PROC_INTERNAL
)
1593 gfc_error ("Specification function '%s' at %L cannot be an internal "
1594 "function", f
->name
, &e
->where
);
1600 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1605 if (f
->attr
.recursive
)
1607 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1608 f
->name
, &e
->where
);
1612 return restricted_args (e
->value
.function
.actual
);
1616 /* Check to see that a function reference to an intrinsic is a
1617 restricted expression. */
1620 restricted_intrinsic (gfc_expr
* e
)
1622 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1623 if (check_inquiry (e
) == SUCCESS
)
1626 return restricted_args (e
->value
.function
.actual
);
1630 /* Verify that an expression is a restricted expression. Like its
1631 cousin check_init_expr(), an error message is generated if we
1635 check_restricted (gfc_expr
* e
)
1643 switch (e
->expr_type
)
1646 t
= check_intrinsic_op (e
, check_restricted
);
1648 t
= gfc_simplify_expr (e
, 0);
1653 t
= e
->value
.function
.esym
?
1654 external_spec_function (e
) : restricted_intrinsic (e
);
1659 sym
= e
->symtree
->n
.sym
;
1662 if (sym
->attr
.optional
)
1664 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1665 sym
->name
, &e
->where
);
1669 if (sym
->attr
.intent
== INTENT_OUT
)
1671 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1672 sym
->name
, &e
->where
);
1676 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1677 in resolve.c(resolve_formal_arglist). This is done so that host associated
1678 dummy array indices are accepted (PR23446). */
1679 if (sym
->attr
.in_common
1680 || sym
->attr
.use_assoc
1682 || sym
->ns
!= gfc_current_ns
1683 || (sym
->ns
->proc_name
!= NULL
1684 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1685 || gfc_is_formal_arg ())
1691 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1692 sym
->name
, &e
->where
);
1701 case EXPR_SUBSTRING
:
1702 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
1706 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
1708 t
= gfc_simplify_expr (e
, 0);
1712 case EXPR_STRUCTURE
:
1713 t
= gfc_check_constructor (e
, check_restricted
);
1717 t
= gfc_check_constructor (e
, check_restricted
);
1721 gfc_internal_error ("check_restricted(): Unknown expression type");
1728 /* Check to see that an expression is a specification expression. If
1729 we return FAILURE, an error has been generated. */
1732 gfc_specification_expr (gfc_expr
* e
)
1735 if (e
->ts
.type
!= BT_INTEGER
)
1737 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
1743 gfc_error ("Expression at %L must be scalar", &e
->where
);
1747 if (gfc_simplify_expr (e
, 0) == FAILURE
)
1750 return check_restricted (e
);
1754 /************** Expression conformance checks. *************/
1756 /* Given two expressions, make sure that the arrays are conformable. */
1759 gfc_check_conformance (const char *optype_msgid
,
1760 gfc_expr
* op1
, gfc_expr
* op2
)
1762 int op1_flag
, op2_flag
, d
;
1763 mpz_t op1_size
, op2_size
;
1766 if (op1
->rank
== 0 || op2
->rank
== 0)
1769 if (op1
->rank
!= op2
->rank
)
1771 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
1778 for (d
= 0; d
< op1
->rank
; d
++)
1780 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
1781 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
1783 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
1785 gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1786 _(optype_msgid
), &op1
->where
, d
+ 1,
1787 (int) mpz_get_si (op1_size
),
1788 (int) mpz_get_si (op2_size
));
1794 mpz_clear (op1_size
);
1796 mpz_clear (op2_size
);
1806 /* Given an assignable expression and an arbitrary expression, make
1807 sure that the assignment can take place. */
1810 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
1814 sym
= lvalue
->symtree
->n
.sym
;
1816 if (sym
->attr
.intent
== INTENT_IN
)
1818 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1819 sym
->name
, &lvalue
->where
);
1823 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
1825 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1826 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
1830 if (lvalue
->ts
.type
== BT_UNKNOWN
)
1832 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1837 if (rvalue
->expr_type
== EXPR_NULL
)
1839 gfc_error ("NULL appears on right-hand side in assignment at %L",
1844 /* This is possibly a typo: x = f() instead of x => f() */
1845 if (gfc_option
.warn_surprising
1846 && rvalue
->expr_type
== EXPR_FUNCTION
1847 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
1848 gfc_warning ("POINTER valued function appears on right-hand side of "
1849 "assignment at %L", &rvalue
->where
);
1851 /* Check size of array assignments. */
1852 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
1853 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
1856 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1861 /* Numeric can be converted to any other numeric. And Hollerith can be
1862 converted to any other type. */
1863 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
1864 || rvalue
->ts
.type
== BT_HOLLERITH
)
1867 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
1870 gfc_error ("Incompatible types in assignment at %L, %s to %s",
1871 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
1872 gfc_typename (&lvalue
->ts
));
1877 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
1881 /* Check that a pointer assignment is OK. We first check lvalue, and
1882 we only check rvalue if it's not an assignment to NULL() or a
1883 NULLIFY statement. */
1886 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
1888 symbol_attribute attr
;
1891 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
1893 gfc_error ("Pointer assignment target is not a POINTER at %L",
1898 attr
= gfc_variable_attr (lvalue
, NULL
);
1901 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
1905 is_pure
= gfc_pure (NULL
);
1907 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
1909 gfc_error ("Bad pointer object in PURE procedure at %L",
1914 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1915 kind, etc for lvalue and rvalue must match, and rvalue must be a
1916 pure variable if we're in a pure function. */
1917 if (rvalue
->expr_type
== EXPR_NULL
)
1920 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1922 gfc_error ("Different types in pointer assignment at %L",
1927 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
1929 gfc_error ("Different kind type parameters in pointer "
1930 "assignment at %L", &lvalue
->where
);
1934 attr
= gfc_expr_attr (rvalue
);
1935 if (!attr
.target
&& !attr
.pointer
)
1937 gfc_error ("Pointer assignment target is neither TARGET "
1938 "nor POINTER at %L", &rvalue
->where
);
1942 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
1944 gfc_error ("Bad target in pointer assignment in PURE "
1945 "procedure at %L", &rvalue
->where
);
1948 if (lvalue
->rank
!= rvalue
->rank
)
1950 gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
1951 lvalue
->rank
, rvalue
->rank
, &rvalue
->where
);
1959 /* Relative of gfc_check_assign() except that the lvalue is a single
1960 symbol. Used for initialization assignments. */
1963 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
1968 memset (&lvalue
, '\0', sizeof (gfc_expr
));
1970 lvalue
.expr_type
= EXPR_VARIABLE
;
1971 lvalue
.ts
= sym
->ts
;
1973 lvalue
.rank
= sym
->as
->rank
;
1974 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
1975 lvalue
.symtree
->n
.sym
= sym
;
1976 lvalue
.where
= sym
->declared_at
;
1978 if (sym
->attr
.pointer
)
1979 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
1981 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
1983 gfc_free (lvalue
.symtree
);
1989 /* Get an expression for a default initializer. */
1992 gfc_default_initializer (gfc_typespec
*ts
)
1994 gfc_constructor
*tail
;
2000 /* See if we have a default initializer. */
2001 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2003 if (c
->initializer
&& init
== NULL
)
2004 init
= gfc_get_expr ();
2010 /* Build the constructor. */
2011 init
->expr_type
= EXPR_STRUCTURE
;
2013 init
->where
= ts
->derived
->declared_at
;
2015 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2018 init
->value
.constructor
= tail
= gfc_get_constructor ();
2021 tail
->next
= gfc_get_constructor ();
2026 tail
->expr
= gfc_copy_expr (c
->initializer
);
2032 /* Given a symbol, create an expression node with that symbol as a
2033 variable. If the symbol is array valued, setup a reference of the
2037 gfc_get_variable_expr (gfc_symtree
* var
)
2041 e
= gfc_get_expr ();
2042 e
->expr_type
= EXPR_VARIABLE
;
2044 e
->ts
= var
->n
.sym
->ts
;
2046 if (var
->n
.sym
->as
!= NULL
)
2048 e
->rank
= var
->n
.sym
->as
->rank
;
2049 e
->ref
= gfc_get_ref ();
2050 e
->ref
->type
= REF_ARRAY
;
2051 e
->ref
->u
.ar
.type
= AR_FULL
;