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 /* Detect whether an expression has any vector index array
318 gfc_has_vector_index (gfc_expr
*e
)
322 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
323 if (ref
->type
== REF_ARRAY
)
324 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
325 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
331 /* Copy a shape array. */
334 gfc_copy_shape (mpz_t
* shape
, int rank
)
342 new_shape
= gfc_get_shape (rank
);
344 for (n
= 0; n
< rank
; n
++)
345 mpz_init_set (new_shape
[n
], shape
[n
]);
351 /* Copy a shape array excluding dimension N, where N is an integer
352 constant expression. Dimensions are numbered in fortran style --
355 So, if the original shape array contains R elements
356 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
357 the result contains R-1 elements:
358 { s1 ... sN-1 sN+1 ... sR-1}
360 If anything goes wrong -- N is not a constant, its value is out
361 of range -- or anything else, just returns NULL.
365 gfc_copy_shape_excluding (mpz_t
* shape
, int rank
, gfc_expr
* dim
)
367 mpz_t
*new_shape
, *s
;
373 || dim
->expr_type
!= EXPR_CONSTANT
374 || dim
->ts
.type
!= BT_INTEGER
)
377 n
= mpz_get_si (dim
->value
.integer
);
378 n
--; /* Convert to zero based index */
379 if (n
< 0 || n
>= rank
)
382 s
= new_shape
= gfc_get_shape (rank
-1);
384 for (i
= 0; i
< rank
; i
++)
388 mpz_init_set (*s
, shape
[i
]);
395 /* Given an expression pointer, return a copy of the expression. This
396 subroutine is recursive. */
399 gfc_copy_expr (gfc_expr
* p
)
410 switch (q
->expr_type
)
413 s
= gfc_getmem (p
->value
.character
.length
+ 1);
414 q
->value
.character
.string
= s
;
416 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
422 s
= gfc_getmem (p
->value
.character
.length
+ 1);
423 q
->value
.character
.string
= s
;
425 memcpy (s
, p
->value
.character
.string
,
426 p
->value
.character
.length
+ 1);
432 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
436 gfc_set_model_kind (q
->ts
.kind
);
437 mpfr_init (q
->value
.real
);
438 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
442 gfc_set_model_kind (q
->ts
.kind
);
443 mpfr_init (q
->value
.complex.r
);
444 mpfr_init (q
->value
.complex.i
);
445 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
446 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
451 s
= gfc_getmem (p
->value
.character
.length
+ 1);
452 q
->value
.character
.string
= s
;
454 memcpy (s
, p
->value
.character
.string
,
455 p
->value
.character
.length
+ 1);
460 break; /* Already done */
464 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
471 switch (q
->value
.op
.operator)
474 case INTRINSIC_UPLUS
:
475 case INTRINSIC_UMINUS
:
476 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
479 default: /* Binary operators */
480 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
481 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
488 q
->value
.function
.actual
=
489 gfc_copy_actual_arglist (p
->value
.function
.actual
);
494 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
502 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
504 q
->ref
= copy_ref (p
->ref
);
510 /* Return the maximum kind of two expressions. In general, higher
511 kind numbers mean more precision for numeric types. */
514 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
517 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
521 /* Returns nonzero if the type is numeric, zero otherwise. */
524 numeric_type (bt type
)
527 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
531 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
534 gfc_numeric_ts (gfc_typespec
* ts
)
537 return numeric_type (ts
->type
);
541 /* Returns an expression node that is an integer constant. */
550 p
->expr_type
= EXPR_CONSTANT
;
551 p
->ts
.type
= BT_INTEGER
;
552 p
->ts
.kind
= gfc_default_integer_kind
;
554 p
->where
= gfc_current_locus
;
555 mpz_init_set_si (p
->value
.integer
, i
);
561 /* Returns an expression node that is a logical constant. */
564 gfc_logical_expr (int i
, locus
* where
)
570 p
->expr_type
= EXPR_CONSTANT
;
571 p
->ts
.type
= BT_LOGICAL
;
572 p
->ts
.kind
= gfc_default_logical_kind
;
575 where
= &gfc_current_locus
;
577 p
->value
.logical
= i
;
583 /* Return an expression node with an optional argument list attached.
584 A variable number of gfc_expr pointers are strung together in an
585 argument list with a NULL pointer terminating the list. */
588 gfc_build_conversion (gfc_expr
* e
)
593 p
->expr_type
= EXPR_FUNCTION
;
595 p
->value
.function
.actual
= NULL
;
597 p
->value
.function
.actual
= gfc_get_actual_arglist ();
598 p
->value
.function
.actual
->expr
= e
;
604 /* Given an expression node with some sort of numeric binary
605 expression, insert type conversions required to make the operands
608 The exception is that the operands of an exponential don't have to
609 have the same type. If possible, the base is promoted to the type
610 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
611 1.0**2 stays as it is. */
614 gfc_type_convert_binary (gfc_expr
* e
)
618 op1
= e
->value
.op
.op1
;
619 op2
= e
->value
.op
.op2
;
621 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
623 gfc_clear_ts (&e
->ts
);
627 /* Kind conversions of same type. */
628 if (op1
->ts
.type
== op2
->ts
.type
)
631 if (op1
->ts
.kind
== op2
->ts
.kind
)
633 /* No type conversions. */
638 if (op1
->ts
.kind
> op2
->ts
.kind
)
639 gfc_convert_type (op2
, &op1
->ts
, 2);
641 gfc_convert_type (op1
, &op2
->ts
, 2);
647 /* Integer combined with real or complex. */
648 if (op2
->ts
.type
== BT_INTEGER
)
652 /* Special case for ** operator. */
653 if (e
->value
.op
.operator == INTRINSIC_POWER
)
656 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
660 if (op1
->ts
.type
== BT_INTEGER
)
663 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
667 /* Real combined with complex. */
668 e
->ts
.type
= BT_COMPLEX
;
669 if (op1
->ts
.kind
> op2
->ts
.kind
)
670 e
->ts
.kind
= op1
->ts
.kind
;
672 e
->ts
.kind
= op2
->ts
.kind
;
673 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
674 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
675 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
676 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
683 /* Function to determine if an expression is constant or not. This
684 function expects that the expression has already been simplified. */
687 gfc_is_constant_expr (gfc_expr
* e
)
690 gfc_actual_arglist
*arg
;
696 switch (e
->expr_type
)
699 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
700 && (e
->value
.op
.op2
== NULL
701 || gfc_is_constant_expr (e
->value
.op
.op2
)));
710 /* Call to intrinsic with at least one argument. */
712 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
714 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
716 if (!gfc_is_constant_expr (arg
->expr
))
730 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
731 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
736 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
737 if (!gfc_is_constant_expr (c
->expr
))
745 rv
= gfc_constant_ac (e
);
749 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
756 /* Try to collapse intrinsic expressions. */
759 simplify_intrinsic_op (gfc_expr
* p
, int type
)
761 gfc_expr
*op1
, *op2
, *result
;
763 if (p
->value
.op
.operator == INTRINSIC_USER
)
766 op1
= p
->value
.op
.op1
;
767 op2
= p
->value
.op
.op2
;
769 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
771 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
774 if (!gfc_is_constant_expr (op1
)
775 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
779 p
->value
.op
.op1
= NULL
;
780 p
->value
.op
.op2
= NULL
;
782 switch (p
->value
.op
.operator)
784 case INTRINSIC_UPLUS
:
785 result
= gfc_uplus (op1
);
788 case INTRINSIC_UMINUS
:
789 result
= gfc_uminus (op1
);
793 result
= gfc_add (op1
, op2
);
796 case INTRINSIC_MINUS
:
797 result
= gfc_subtract (op1
, op2
);
800 case INTRINSIC_TIMES
:
801 result
= gfc_multiply (op1
, op2
);
804 case INTRINSIC_DIVIDE
:
805 result
= gfc_divide (op1
, op2
);
808 case INTRINSIC_POWER
:
809 result
= gfc_power (op1
, op2
);
812 case INTRINSIC_CONCAT
:
813 result
= gfc_concat (op1
, op2
);
817 result
= gfc_eq (op1
, op2
);
821 result
= gfc_ne (op1
, op2
);
825 result
= gfc_gt (op1
, op2
);
829 result
= gfc_ge (op1
, op2
);
833 result
= gfc_lt (op1
, op2
);
837 result
= gfc_le (op1
, op2
);
841 result
= gfc_not (op1
);
845 result
= gfc_and (op1
, op2
);
849 result
= gfc_or (op1
, op2
);
853 result
= gfc_eqv (op1
, op2
);
857 result
= gfc_neqv (op1
, op2
);
861 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
871 gfc_replace_expr (p
, result
);
877 /* Subroutine to simplify constructor expressions. Mutually recursive
878 with gfc_simplify_expr(). */
881 simplify_constructor (gfc_constructor
* c
, int type
)
884 for (; c
; c
= c
->next
)
887 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
888 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
889 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
892 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
900 /* Pull a single array element out of an array constructor. */
902 static gfc_constructor
*
903 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
)
905 unsigned long nelemen
;
910 mpz_init_set_ui (offset
, 0);
912 for (i
= 0; i
< ar
->dimen
; i
++)
914 if (ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
)
919 mpz_sub (delta
, ar
->start
[i
]->value
.integer
,
920 ar
->as
->lower
[i
]->value
.integer
);
921 mpz_add (offset
, offset
, delta
);
926 if (mpz_fits_ulong_p (offset
))
928 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
949 /* Find a component of a structure constructor. */
951 static gfc_constructor
*
952 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
957 comp
= ref
->u
.c
.sym
->components
;
958 pick
= ref
->u
.c
.component
;
969 /* Replace an expression with the contents of a constructor, removing
970 the subobject reference in the process. */
973 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
979 e
->ref
= p
->ref
->next
;
981 gfc_replace_expr (p
, e
);
985 /* Simplify a subobject reference of a constructor. This occurs when
986 parameter variable values are substituted. */
989 simplify_const_ref (gfc_expr
* p
)
991 gfc_constructor
*cons
;
995 switch (p
->ref
->type
)
998 switch (p
->ref
->u
.ar
.type
)
1001 cons
= find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
);
1004 remove_subobject_ref (p
, cons
);
1008 if (p
->ref
->next
!= NULL
)
1010 /* TODO: Simplify array subobject references. */
1013 gfc_free_ref_list (p
->ref
);
1018 /* TODO: Simplify array subsections. */
1025 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1026 remove_subobject_ref (p
, cons
);
1030 /* TODO: Constant substrings. */
1039 /* Simplify a chain of references. */
1042 simplify_ref_chain (gfc_ref
* ref
, int type
)
1046 for (; ref
; ref
= ref
->next
)
1051 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1053 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1056 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1059 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1066 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1068 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1080 /* Try to substitute the value of a parameter variable. */
1082 simplify_parameter_variable (gfc_expr
* p
, int type
)
1087 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1088 /* Do not copy subobject refs for constant. */
1089 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1090 e
->ref
= copy_ref (p
->ref
);
1091 t
= gfc_simplify_expr (e
, type
);
1093 /* Only use the simplification if it eliminated all subobject
1095 if (t
== SUCCESS
&& ! e
->ref
)
1096 gfc_replace_expr (p
, e
);
1103 /* Given an expression, simplify it by collapsing constant
1104 expressions. Most simplification takes place when the expression
1105 tree is being constructed. If an intrinsic function is simplified
1106 at some point, we get called again to collapse the result against
1109 We work by recursively simplifying expression nodes, simplifying
1110 intrinsic functions where possible, which can lead to further
1111 constant collapsing. If an operator has constant operand(s), we
1112 rip the expression apart, and rebuild it, hoping that it becomes
1115 The expression type is defined for:
1116 0 Basic expression parsing
1117 1 Simplifying array constructors -- will substitute
1119 Returns FAILURE on error, SUCCESS otherwise.
1120 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1123 gfc_simplify_expr (gfc_expr
* p
, int type
)
1125 gfc_actual_arglist
*ap
;
1130 switch (p
->expr_type
)
1137 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1138 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1141 if (p
->value
.function
.isym
!= NULL
1142 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1147 case EXPR_SUBSTRING
:
1148 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1151 if (gfc_is_constant_expr (p
))
1156 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1157 start
--; /* Convert from one-based to zero-based. */
1158 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1159 s
= gfc_getmem (end
- start
+ 1);
1160 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1161 s
[end
] = '\0'; /* TODO: C-style string for debugging. */
1162 gfc_free (p
->value
.character
.string
);
1163 p
->value
.character
.string
= s
;
1164 p
->value
.character
.length
= end
- start
;
1165 p
->ts
.cl
= gfc_get_charlen ();
1166 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1167 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1168 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1169 gfc_free_ref_list (p
->ref
);
1171 p
->expr_type
= EXPR_CONSTANT
;
1176 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1181 /* Only substitute array parameter variables if we are in an
1182 initialization expression, or we want a subsection. */
1183 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1184 && (gfc_init_expr
|| p
->ref
1185 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1187 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1194 gfc_simplify_iterator_var (p
);
1197 /* Simplify subcomponent references. */
1198 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1203 case EXPR_STRUCTURE
:
1205 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1208 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1211 if (p
->expr_type
== EXPR_ARRAY
)
1212 gfc_expand_constructor (p
);
1214 if (simplify_const_ref (p
) == FAILURE
)
1224 /* Returns the type of an expression with the exception that iterator
1225 variables are automatically integers no matter what else they may
1232 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1239 /* Check an intrinsic arithmetic operation to see if it is consistent
1240 with some type of expression. */
1242 static try check_init_expr (gfc_expr
*);
1245 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1247 gfc_expr
*op1
= e
->value
.op
.op1
;
1248 gfc_expr
*op2
= e
->value
.op
.op2
;
1250 if ((*check_function
) (op1
) == FAILURE
)
1253 switch (e
->value
.op
.operator)
1255 case INTRINSIC_UPLUS
:
1256 case INTRINSIC_UMINUS
:
1257 if (!numeric_type (et0 (op1
)))
1267 if ((*check_function
) (op2
) == FAILURE
)
1270 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1271 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1273 gfc_error ("Numeric or CHARACTER operands are required in "
1274 "expression at %L", &e
->where
);
1279 case INTRINSIC_PLUS
:
1280 case INTRINSIC_MINUS
:
1281 case INTRINSIC_TIMES
:
1282 case INTRINSIC_DIVIDE
:
1283 case INTRINSIC_POWER
:
1284 if ((*check_function
) (op2
) == FAILURE
)
1287 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1290 if (e
->value
.op
.operator == INTRINSIC_POWER
1291 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1293 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1294 "expression", &op2
->where
);
1300 case INTRINSIC_CONCAT
:
1301 if ((*check_function
) (op2
) == FAILURE
)
1304 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1306 gfc_error ("Concatenation operator in expression at %L "
1307 "must have two CHARACTER operands", &op1
->where
);
1311 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1313 gfc_error ("Concat operator at %L must concatenate strings of the "
1314 "same kind", &e
->where
);
1321 if (et0 (op1
) != BT_LOGICAL
)
1323 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1324 "operand", &op1
->where
);
1333 case INTRINSIC_NEQV
:
1334 if ((*check_function
) (op2
) == FAILURE
)
1337 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1339 gfc_error ("LOGICAL operands are required in expression at %L",
1347 gfc_error ("Only intrinsic operators can be used in expression at %L",
1355 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1362 /* Certain inquiry functions are specifically allowed to have variable
1363 arguments, which is an exception to the normal requirement that an
1364 initialization function have initialization arguments. We head off
1365 this problem here. */
1368 check_inquiry (gfc_expr
* e
)
1372 /* FIXME: This should be moved into the intrinsic definitions,
1373 to eliminate this ugly hack. */
1374 static const char * const inquiry_function
[] = {
1375 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1376 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1377 "lbound", "ubound", NULL
1382 name
= e
->symtree
->n
.sym
->name
;
1384 for (i
= 0; inquiry_function
[i
]; i
++)
1385 if (strcmp (inquiry_function
[i
], name
) == 0)
1388 if (inquiry_function
[i
] == NULL
)
1391 e
= e
->value
.function
.actual
->expr
;
1393 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1396 /* At this point we have an inquiry function with a variable argument. The
1397 type of the variable might be undefined, but we need it now, because the
1398 arguments of these functions are allowed to be undefined. */
1400 if (e
->ts
.type
== BT_UNKNOWN
)
1402 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1403 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1407 e
->ts
= e
->symtree
->n
.sym
->ts
;
1414 /* Verify that an expression is an initialization expression. A side
1415 effect is that the expression tree is reduced to a single constant
1416 node if all goes well. This would normally happen when the
1417 expression is constructed but function references are assumed to be
1418 intrinsics in the context of initialization expressions. If
1419 FAILURE is returned an error message has been generated. */
1422 check_init_expr (gfc_expr
* e
)
1424 gfc_actual_arglist
*ap
;
1431 switch (e
->expr_type
)
1434 t
= check_intrinsic_op (e
, check_init_expr
);
1436 t
= gfc_simplify_expr (e
, 0);
1443 if (check_inquiry (e
) != SUCCESS
)
1446 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1447 if (check_init_expr (ap
->expr
) == FAILURE
)
1456 m
= gfc_intrinsic_func_interface (e
, 0);
1459 gfc_error ("Function '%s' in initialization expression at %L "
1460 "must be an intrinsic function",
1461 e
->symtree
->n
.sym
->name
, &e
->where
);
1472 if (gfc_check_iter_variable (e
) == SUCCESS
)
1475 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1477 t
= simplify_parameter_variable (e
, 0);
1481 gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1482 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1491 case EXPR_SUBSTRING
:
1492 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1496 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1498 t
= gfc_simplify_expr (e
, 0);
1502 case EXPR_STRUCTURE
:
1503 t
= gfc_check_constructor (e
, check_init_expr
);
1507 t
= gfc_check_constructor (e
, check_init_expr
);
1511 t
= gfc_expand_constructor (e
);
1515 t
= gfc_check_constructor_type (e
);
1519 gfc_internal_error ("check_init_expr(): Unknown expression type");
1526 /* Match an initialization expression. We work by first matching an
1527 expression, then reducing it to a constant. */
1530 gfc_match_init_expr (gfc_expr
** result
)
1536 m
= gfc_match_expr (&expr
);
1541 t
= gfc_resolve_expr (expr
);
1543 t
= check_init_expr (expr
);
1548 gfc_free_expr (expr
);
1552 if (expr
->expr_type
== EXPR_ARRAY
1553 && (gfc_check_constructor_type (expr
) == FAILURE
1554 || gfc_expand_constructor (expr
) == FAILURE
))
1556 gfc_free_expr (expr
);
1560 if (!gfc_is_constant_expr (expr
))
1561 gfc_internal_error ("Initialization expression didn't reduce %C");
1570 static try check_restricted (gfc_expr
*);
1572 /* Given an actual argument list, test to see that each argument is a
1573 restricted expression and optionally if the expression type is
1574 integer or character. */
1577 restricted_args (gfc_actual_arglist
* a
)
1579 for (; a
; a
= a
->next
)
1581 if (check_restricted (a
->expr
) == FAILURE
)
1589 /************* Restricted/specification expressions *************/
1592 /* Make sure a non-intrinsic function is a specification function. */
1595 external_spec_function (gfc_expr
* e
)
1599 f
= e
->value
.function
.esym
;
1601 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1603 gfc_error ("Specification function '%s' at %L cannot be a statement "
1604 "function", f
->name
, &e
->where
);
1608 if (f
->attr
.proc
== PROC_INTERNAL
)
1610 gfc_error ("Specification function '%s' at %L cannot be an internal "
1611 "function", f
->name
, &e
->where
);
1617 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1622 if (f
->attr
.recursive
)
1624 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1625 f
->name
, &e
->where
);
1629 return restricted_args (e
->value
.function
.actual
);
1633 /* Check to see that a function reference to an intrinsic is a
1634 restricted expression. */
1637 restricted_intrinsic (gfc_expr
* e
)
1639 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1640 if (check_inquiry (e
) == SUCCESS
)
1643 return restricted_args (e
->value
.function
.actual
);
1647 /* Verify that an expression is a restricted expression. Like its
1648 cousin check_init_expr(), an error message is generated if we
1652 check_restricted (gfc_expr
* e
)
1660 switch (e
->expr_type
)
1663 t
= check_intrinsic_op (e
, check_restricted
);
1665 t
= gfc_simplify_expr (e
, 0);
1670 t
= e
->value
.function
.esym
?
1671 external_spec_function (e
) : restricted_intrinsic (e
);
1676 sym
= e
->symtree
->n
.sym
;
1679 if (sym
->attr
.optional
)
1681 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1682 sym
->name
, &e
->where
);
1686 if (sym
->attr
.intent
== INTENT_OUT
)
1688 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1689 sym
->name
, &e
->where
);
1693 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1694 in resolve.c(resolve_formal_arglist). This is done so that host associated
1695 dummy array indices are accepted (PR23446). */
1696 if (sym
->attr
.in_common
1697 || sym
->attr
.use_assoc
1699 || sym
->ns
!= gfc_current_ns
1700 || (sym
->ns
->proc_name
!= NULL
1701 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
1702 || gfc_is_formal_arg ())
1708 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1709 sym
->name
, &e
->where
);
1718 case EXPR_SUBSTRING
:
1719 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
1723 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
1725 t
= gfc_simplify_expr (e
, 0);
1729 case EXPR_STRUCTURE
:
1730 t
= gfc_check_constructor (e
, check_restricted
);
1734 t
= gfc_check_constructor (e
, check_restricted
);
1738 gfc_internal_error ("check_restricted(): Unknown expression type");
1745 /* Check to see that an expression is a specification expression. If
1746 we return FAILURE, an error has been generated. */
1749 gfc_specification_expr (gfc_expr
* e
)
1752 if (e
->ts
.type
!= BT_INTEGER
)
1754 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
1760 gfc_error ("Expression at %L must be scalar", &e
->where
);
1764 if (gfc_simplify_expr (e
, 0) == FAILURE
)
1767 return check_restricted (e
);
1771 /************** Expression conformance checks. *************/
1773 /* Given two expressions, make sure that the arrays are conformable. */
1776 gfc_check_conformance (const char *optype_msgid
,
1777 gfc_expr
* op1
, gfc_expr
* op2
)
1779 int op1_flag
, op2_flag
, d
;
1780 mpz_t op1_size
, op2_size
;
1783 if (op1
->rank
== 0 || op2
->rank
== 0)
1786 if (op1
->rank
!= op2
->rank
)
1788 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
1795 for (d
= 0; d
< op1
->rank
; d
++)
1797 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
1798 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
1800 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
1802 gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1803 _(optype_msgid
), &op1
->where
, d
+ 1,
1804 (int) mpz_get_si (op1_size
),
1805 (int) mpz_get_si (op2_size
));
1811 mpz_clear (op1_size
);
1813 mpz_clear (op2_size
);
1823 /* Given an assignable expression and an arbitrary expression, make
1824 sure that the assignment can take place. */
1827 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
1831 sym
= lvalue
->symtree
->n
.sym
;
1833 if (sym
->attr
.intent
== INTENT_IN
)
1835 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1836 sym
->name
, &lvalue
->where
);
1840 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
1842 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1843 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
1847 if (lvalue
->ts
.type
== BT_UNKNOWN
)
1849 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1854 if (rvalue
->expr_type
== EXPR_NULL
)
1856 gfc_error ("NULL appears on right-hand side in assignment at %L",
1861 if (sym
->attr
.cray_pointee
1862 && lvalue
->ref
!= NULL
1863 && lvalue
->ref
->u
.ar
.type
!= AR_ELEMENT
1864 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
1866 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
1867 " is illegal.", &lvalue
->where
);
1871 /* This is possibly a typo: x = f() instead of x => f() */
1872 if (gfc_option
.warn_surprising
1873 && rvalue
->expr_type
== EXPR_FUNCTION
1874 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
1875 gfc_warning ("POINTER valued function appears on right-hand side of "
1876 "assignment at %L", &rvalue
->where
);
1878 /* Check size of array assignments. */
1879 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
1880 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
1883 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1888 /* Numeric can be converted to any other numeric. And Hollerith can be
1889 converted to any other type. */
1890 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
1891 || rvalue
->ts
.type
== BT_HOLLERITH
)
1894 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
1897 gfc_error ("Incompatible types in assignment at %L, %s to %s",
1898 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
1899 gfc_typename (&lvalue
->ts
));
1904 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
1908 /* Check that a pointer assignment is OK. We first check lvalue, and
1909 we only check rvalue if it's not an assignment to NULL() or a
1910 NULLIFY statement. */
1913 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
1915 symbol_attribute attr
;
1918 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
1920 gfc_error ("Pointer assignment target is not a POINTER at %L",
1925 attr
= gfc_variable_attr (lvalue
, NULL
);
1928 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
1932 is_pure
= gfc_pure (NULL
);
1934 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
1936 gfc_error ("Bad pointer object in PURE procedure at %L",
1941 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1942 kind, etc for lvalue and rvalue must match, and rvalue must be a
1943 pure variable if we're in a pure function. */
1944 if (rvalue
->expr_type
== EXPR_NULL
)
1947 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1949 gfc_error ("Different types in pointer assignment at %L",
1954 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
1956 gfc_error ("Different kind type parameters in pointer "
1957 "assignment at %L", &lvalue
->where
);
1961 attr
= gfc_expr_attr (rvalue
);
1962 if (!attr
.target
&& !attr
.pointer
)
1964 gfc_error ("Pointer assignment target is neither TARGET "
1965 "nor POINTER at %L", &rvalue
->where
);
1969 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
1971 gfc_error ("Bad target in pointer assignment in PURE "
1972 "procedure at %L", &rvalue
->where
);
1975 if (lvalue
->rank
!= rvalue
->rank
)
1977 gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
1978 lvalue
->rank
, rvalue
->rank
, &rvalue
->where
);
1982 if (gfc_has_vector_index (rvalue
))
1984 gfc_error ("Pointer assignment with vector subscript "
1985 "on rhs at %L", &rvalue
->where
);
1993 /* Relative of gfc_check_assign() except that the lvalue is a single
1994 symbol. Used for initialization assignments. */
1997 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
2002 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2004 lvalue
.expr_type
= EXPR_VARIABLE
;
2005 lvalue
.ts
= sym
->ts
;
2007 lvalue
.rank
= sym
->as
->rank
;
2008 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
2009 lvalue
.symtree
->n
.sym
= sym
;
2010 lvalue
.where
= sym
->declared_at
;
2012 if (sym
->attr
.pointer
)
2013 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2015 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2017 gfc_free (lvalue
.symtree
);
2023 /* Get an expression for a default initializer. */
2026 gfc_default_initializer (gfc_typespec
*ts
)
2028 gfc_constructor
*tail
;
2034 /* See if we have a default initializer. */
2035 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2037 if (c
->initializer
&& init
== NULL
)
2038 init
= gfc_get_expr ();
2044 /* Build the constructor. */
2045 init
->expr_type
= EXPR_STRUCTURE
;
2047 init
->where
= ts
->derived
->declared_at
;
2049 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2052 init
->value
.constructor
= tail
= gfc_get_constructor ();
2055 tail
->next
= gfc_get_constructor ();
2060 tail
->expr
= gfc_copy_expr (c
->initializer
);
2066 /* Given a symbol, create an expression node with that symbol as a
2067 variable. If the symbol is array valued, setup a reference of the
2071 gfc_get_variable_expr (gfc_symtree
* var
)
2075 e
= gfc_get_expr ();
2076 e
->expr_type
= EXPR_VARIABLE
;
2078 e
->ts
= var
->n
.sym
->ts
;
2080 if (var
->n
.sym
->as
!= NULL
)
2082 e
->rank
= var
->n
.sym
->as
->rank
;
2083 e
->ref
= gfc_get_ref ();
2084 e
->ref
->type
= REF_ARRAY
;
2085 e
->ref
->u
.ar
.type
= AR_FULL
;