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, 59 Temple Place - Suite 330, 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
)
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
159 mpfr_clear (e
->value
.complex.r
);
160 mpfr_clear (e
->value
.complex.i
);
170 if (e
->value
.op
.op1
!= NULL
)
171 gfc_free_expr (e
->value
.op
.op1
);
172 if (e
->value
.op
.op2
!= NULL
)
173 gfc_free_expr (e
->value
.op
.op2
);
177 gfc_free_actual_arglist (e
->value
.function
.actual
);
185 gfc_free_constructor (e
->value
.constructor
);
189 gfc_free (e
->value
.character
.string
);
196 gfc_internal_error ("free_expr0(): Bad expr type");
199 /* Free a shape array. */
200 if (e
->shape
!= NULL
)
202 for (n
= 0; n
< e
->rank
; n
++)
203 mpz_clear (e
->shape
[n
]);
208 gfc_free_ref_list (e
->ref
);
210 memset (e
, '\0', sizeof (gfc_expr
));
214 /* Free an expression node and everything beneath it. */
217 gfc_free_expr (gfc_expr
* e
)
228 /* Graft the *src expression onto the *dest subexpression. */
231 gfc_replace_expr (gfc_expr
* dest
, gfc_expr
* src
)
241 /* Try to extract an integer constant from the passed expression node.
242 Returns an error message or NULL if the result is set. It is
243 tempting to generate an error and return SUCCESS or FAILURE, but
244 failure is OK for some callers. */
247 gfc_extract_int (gfc_expr
* expr
, int *result
)
250 if (expr
->expr_type
!= EXPR_CONSTANT
)
251 return "Constant expression required at %C";
253 if (expr
->ts
.type
!= BT_INTEGER
)
254 return "Integer expression required at %C";
256 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
257 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
259 return "Integer value too large in expression at %C";
262 *result
= (int) mpz_get_si (expr
->value
.integer
);
268 /* Recursively copy a list of reference structures. */
271 copy_ref (gfc_ref
* src
)
279 dest
= gfc_get_ref ();
280 dest
->type
= src
->type
;
285 ar
= gfc_copy_array_ref (&src
->u
.ar
);
291 dest
->u
.c
= src
->u
.c
;
295 dest
->u
.ss
= src
->u
.ss
;
296 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
297 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
301 dest
->next
= copy_ref (src
->next
);
307 /* Copy a shape array. */
310 gfc_copy_shape (mpz_t
* shape
, int rank
)
318 new_shape
= gfc_get_shape (rank
);
320 for (n
= 0; n
< rank
; n
++)
321 mpz_init_set (new_shape
[n
], shape
[n
]);
327 /* Copy a shape array excluding dimension N, where N is an integer
328 constant expression. Dimensions are numbered in fortran style --
331 So, if the original shape array contains R elements
332 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
333 the result contains R-1 elements:
334 { s1 ... sN-1 sN+1 ... sR-1}
336 If anything goes wrong -- N is not a constant, its value is out
337 of range -- or anything else, just returns NULL.
341 gfc_copy_shape_excluding (mpz_t
* shape
, int rank
, gfc_expr
* dim
)
343 mpz_t
*new_shape
, *s
;
349 || dim
->expr_type
!= EXPR_CONSTANT
350 || dim
->ts
.type
!= BT_INTEGER
)
353 n
= mpz_get_si (dim
->value
.integer
);
354 n
--; /* Convert to zero based index */
355 if (n
< 0 || n
>= rank
)
358 s
= new_shape
= gfc_get_shape (rank
-1);
360 for (i
= 0; i
< rank
; i
++)
364 mpz_init_set (*s
, shape
[i
]);
371 /* Given an expression pointer, return a copy of the expression. This
372 subroutine is recursive. */
375 gfc_copy_expr (gfc_expr
* p
)
386 switch (q
->expr_type
)
389 s
= gfc_getmem (p
->value
.character
.length
+ 1);
390 q
->value
.character
.string
= s
;
392 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
399 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
403 gfc_set_model_kind (q
->ts
.kind
);
404 mpfr_init (q
->value
.real
);
405 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
409 gfc_set_model_kind (q
->ts
.kind
);
410 mpfr_init (q
->value
.complex.r
);
411 mpfr_init (q
->value
.complex.i
);
412 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
413 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
417 s
= gfc_getmem (p
->value
.character
.length
+ 1);
418 q
->value
.character
.string
= s
;
420 memcpy (s
, p
->value
.character
.string
,
421 p
->value
.character
.length
+ 1);
426 break; /* Already done */
430 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
437 switch (q
->value
.op
.operator)
440 case INTRINSIC_UPLUS
:
441 case INTRINSIC_UMINUS
:
442 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
445 default: /* Binary operators */
446 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
447 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
454 q
->value
.function
.actual
=
455 gfc_copy_actual_arglist (p
->value
.function
.actual
);
460 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
468 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
470 q
->ref
= copy_ref (p
->ref
);
476 /* Return the maximum kind of two expressions. In general, higher
477 kind numbers mean more precision for numeric types. */
480 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
483 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
487 /* Returns nonzero if the type is numeric, zero otherwise. */
490 numeric_type (bt type
)
493 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
497 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
500 gfc_numeric_ts (gfc_typespec
* ts
)
503 return numeric_type (ts
->type
);
507 /* Returns an expression node that is an integer constant. */
516 p
->expr_type
= EXPR_CONSTANT
;
517 p
->ts
.type
= BT_INTEGER
;
518 p
->ts
.kind
= gfc_default_integer_kind
;
520 p
->where
= gfc_current_locus
;
521 mpz_init_set_si (p
->value
.integer
, i
);
527 /* Returns an expression node that is a logical constant. */
530 gfc_logical_expr (int i
, locus
* where
)
536 p
->expr_type
= EXPR_CONSTANT
;
537 p
->ts
.type
= BT_LOGICAL
;
538 p
->ts
.kind
= gfc_default_logical_kind
;
541 where
= &gfc_current_locus
;
543 p
->value
.logical
= i
;
549 /* Return an expression node with an optional argument list attached.
550 A variable number of gfc_expr pointers are strung together in an
551 argument list with a NULL pointer terminating the list. */
554 gfc_build_conversion (gfc_expr
* e
)
559 p
->expr_type
= EXPR_FUNCTION
;
561 p
->value
.function
.actual
= NULL
;
563 p
->value
.function
.actual
= gfc_get_actual_arglist ();
564 p
->value
.function
.actual
->expr
= e
;
570 /* Given an expression node with some sort of numeric binary
571 expression, insert type conversions required to make the operands
574 The exception is that the operands of an exponential don't have to
575 have the same type. If possible, the base is promoted to the type
576 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
577 1.0**2 stays as it is. */
580 gfc_type_convert_binary (gfc_expr
* e
)
584 op1
= e
->value
.op
.op1
;
585 op2
= e
->value
.op
.op2
;
587 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
589 gfc_clear_ts (&e
->ts
);
593 /* Kind conversions of same type. */
594 if (op1
->ts
.type
== op2
->ts
.type
)
597 if (op1
->ts
.kind
== op2
->ts
.kind
)
599 /* No type conversions. */
604 if (op1
->ts
.kind
> op2
->ts
.kind
)
605 gfc_convert_type (op2
, &op1
->ts
, 2);
607 gfc_convert_type (op1
, &op2
->ts
, 2);
613 /* Integer combined with real or complex. */
614 if (op2
->ts
.type
== BT_INTEGER
)
618 /* Special case for ** operator. */
619 if (e
->value
.op
.operator == INTRINSIC_POWER
)
622 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
626 if (op1
->ts
.type
== BT_INTEGER
)
629 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
633 /* Real combined with complex. */
634 e
->ts
.type
= BT_COMPLEX
;
635 if (op1
->ts
.kind
> op2
->ts
.kind
)
636 e
->ts
.kind
= op1
->ts
.kind
;
638 e
->ts
.kind
= op2
->ts
.kind
;
639 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
640 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
641 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
642 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
649 /* Function to determine if an expression is constant or not. This
650 function expects that the expression has already been simplified. */
653 gfc_is_constant_expr (gfc_expr
* e
)
656 gfc_actual_arglist
*arg
;
662 switch (e
->expr_type
)
665 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
666 && (e
->value
.op
.op2
== NULL
667 || gfc_is_constant_expr (e
->value
.op
.op2
)));
676 /* Call to intrinsic with at least one argument. */
678 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
680 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
682 if (!gfc_is_constant_expr (arg
->expr
))
696 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
697 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
702 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
703 if (!gfc_is_constant_expr (c
->expr
))
711 rv
= gfc_constant_ac (e
);
715 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
722 /* Try to collapse intrinsic expressions. */
725 simplify_intrinsic_op (gfc_expr
* p
, int type
)
727 gfc_expr
*op1
, *op2
, *result
;
729 if (p
->value
.op
.operator == INTRINSIC_USER
)
732 op1
= p
->value
.op
.op1
;
733 op2
= p
->value
.op
.op2
;
735 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
737 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
740 if (!gfc_is_constant_expr (op1
)
741 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
745 p
->value
.op
.op1
= NULL
;
746 p
->value
.op
.op2
= NULL
;
748 switch (p
->value
.op
.operator)
750 case INTRINSIC_UPLUS
:
751 result
= gfc_uplus (op1
);
754 case INTRINSIC_UMINUS
:
755 result
= gfc_uminus (op1
);
759 result
= gfc_add (op1
, op2
);
762 case INTRINSIC_MINUS
:
763 result
= gfc_subtract (op1
, op2
);
766 case INTRINSIC_TIMES
:
767 result
= gfc_multiply (op1
, op2
);
770 case INTRINSIC_DIVIDE
:
771 result
= gfc_divide (op1
, op2
);
774 case INTRINSIC_POWER
:
775 result
= gfc_power (op1
, op2
);
778 case INTRINSIC_CONCAT
:
779 result
= gfc_concat (op1
, op2
);
783 result
= gfc_eq (op1
, op2
);
787 result
= gfc_ne (op1
, op2
);
791 result
= gfc_gt (op1
, op2
);
795 result
= gfc_ge (op1
, op2
);
799 result
= gfc_lt (op1
, op2
);
803 result
= gfc_le (op1
, op2
);
807 result
= gfc_not (op1
);
811 result
= gfc_and (op1
, op2
);
815 result
= gfc_or (op1
, op2
);
819 result
= gfc_eqv (op1
, op2
);
823 result
= gfc_neqv (op1
, op2
);
827 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
837 gfc_replace_expr (p
, result
);
843 /* Subroutine to simplify constructor expressions. Mutually recursive
844 with gfc_simplify_expr(). */
847 simplify_constructor (gfc_constructor
* c
, int type
)
850 for (; c
; c
= c
->next
)
853 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
854 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
855 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
858 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
866 /* Pull a single array element out of an array constructor. */
868 static gfc_constructor
*
869 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
)
871 unsigned long nelemen
;
876 mpz_init_set_ui (offset
, 0);
878 for (i
= 0; i
< ar
->dimen
; i
++)
880 if (ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
)
885 mpz_sub (delta
, ar
->start
[i
]->value
.integer
,
886 ar
->as
->lower
[i
]->value
.integer
);
887 mpz_add (offset
, offset
, delta
);
892 if (mpz_fits_ulong_p (offset
))
894 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
915 /* Find a component of a structure constructor. */
917 static gfc_constructor
*
918 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
923 comp
= ref
->u
.c
.sym
->components
;
924 pick
= ref
->u
.c
.component
;
935 /* Replace an expression with the contents of a constructor, removing
936 the subobject reference in the process. */
939 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
945 e
->ref
= p
->ref
->next
;
947 gfc_replace_expr (p
, e
);
951 /* Simplify a subobject reference of a constructor. This occurs when
952 parameter variable values are substituted. */
955 simplify_const_ref (gfc_expr
* p
)
957 gfc_constructor
*cons
;
961 switch (p
->ref
->type
)
964 switch (p
->ref
->u
.ar
.type
)
967 cons
= find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
);
970 remove_subobject_ref (p
, cons
);
974 if (p
->ref
->next
!= NULL
)
976 /* TODO: Simplify array subobject references. */
979 gfc_free_ref_list (p
->ref
);
984 /* TODO: Simplify array subsections. */
991 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
992 remove_subobject_ref (p
, cons
);
996 /* TODO: Constant substrings. */
1005 /* Simplify a chain of references. */
1008 simplify_ref_chain (gfc_ref
* ref
, int type
)
1012 for (; ref
; ref
= ref
->next
)
1017 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1019 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1022 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1025 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1032 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1034 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1046 /* Try to substitute the value of a parameter variable. */
1048 simplify_parameter_variable (gfc_expr
* p
, int type
)
1053 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1055 e
->ref
= copy_ref (p
->ref
);
1056 t
= gfc_simplify_expr (e
, type
);
1058 /* Only use the simplification if it eliminated all subobject
1060 if (t
== SUCCESS
&& ! e
->ref
)
1061 gfc_replace_expr (p
, e
);
1068 /* Given an expression, simplify it by collapsing constant
1069 expressions. Most simplification takes place when the expression
1070 tree is being constructed. If an intrinsic function is simplified
1071 at some point, we get called again to collapse the result against
1074 We work by recursively simplifying expression nodes, simplifying
1075 intrinsic functions where possible, which can lead to further
1076 constant collapsing. If an operator has constant operand(s), we
1077 rip the expression apart, and rebuild it, hoping that it becomes
1080 The expression type is defined for:
1081 0 Basic expression parsing
1082 1 Simplifying array constructors -- will substitute
1084 Returns FAILURE on error, SUCCESS otherwise.
1085 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1088 gfc_simplify_expr (gfc_expr
* p
, int type
)
1090 gfc_actual_arglist
*ap
;
1095 switch (p
->expr_type
)
1102 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1103 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1106 if (p
->value
.function
.isym
!= NULL
1107 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1112 case EXPR_SUBSTRING
:
1113 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1116 /* TODO: evaluate constant substrings. */
1120 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1125 /* Only substitute array parameter variables if we are in an
1126 initialization expression, or we want a subsection. */
1127 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1128 && (gfc_init_expr
|| p
->ref
1129 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1131 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1138 gfc_simplify_iterator_var (p
);
1141 /* Simplify subcomponent references. */
1142 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1147 case EXPR_STRUCTURE
:
1149 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1152 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1155 if (p
->expr_type
== EXPR_ARRAY
)
1156 gfc_expand_constructor (p
);
1158 if (simplify_const_ref (p
) == FAILURE
)
1168 /* Returns the type of an expression with the exception that iterator
1169 variables are automatically integers no matter what else they may
1176 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1183 /* Check an intrinsic arithmetic operation to see if it is consistent
1184 with some type of expression. */
1186 static try check_init_expr (gfc_expr
*);
1189 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1191 gfc_expr
*op1
= e
->value
.op
.op1
;
1192 gfc_expr
*op2
= e
->value
.op
.op2
;
1194 if ((*check_function
) (op1
) == FAILURE
)
1197 switch (e
->value
.op
.operator)
1199 case INTRINSIC_UPLUS
:
1200 case INTRINSIC_UMINUS
:
1201 if (!numeric_type (et0 (op1
)))
1211 if ((*check_function
) (op2
) == FAILURE
)
1214 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1215 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1217 gfc_error ("Numeric or CHARACTER operands are required in "
1218 "expression at %L", &e
->where
);
1223 case INTRINSIC_PLUS
:
1224 case INTRINSIC_MINUS
:
1225 case INTRINSIC_TIMES
:
1226 case INTRINSIC_DIVIDE
:
1227 case INTRINSIC_POWER
:
1228 if ((*check_function
) (op2
) == FAILURE
)
1231 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1234 if (e
->value
.op
.operator == INTRINSIC_POWER
1235 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1237 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1238 "expression", &op2
->where
);
1244 case INTRINSIC_CONCAT
:
1245 if ((*check_function
) (op2
) == FAILURE
)
1248 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1250 gfc_error ("Concatenation operator in expression at %L "
1251 "must have two CHARACTER operands", &op1
->where
);
1255 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1257 gfc_error ("Concat operator at %L must concatenate strings of the "
1258 "same kind", &e
->where
);
1265 if (et0 (op1
) != BT_LOGICAL
)
1267 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1268 "operand", &op1
->where
);
1277 case INTRINSIC_NEQV
:
1278 if ((*check_function
) (op2
) == FAILURE
)
1281 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1283 gfc_error ("LOGICAL operands are required in expression at %L",
1291 gfc_error ("Only intrinsic operators can be used in expression at %L",
1299 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1306 /* Certain inquiry functions are specifically allowed to have variable
1307 arguments, which is an exception to the normal requirement that an
1308 initialization function have initialization arguments. We head off
1309 this problem here. */
1312 check_inquiry (gfc_expr
* e
)
1316 /* FIXME: This should be moved into the intrinsic definitions,
1317 to eliminate this ugly hack. */
1318 static const char * const inquiry_function
[] = {
1319 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
1320 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1321 "lbound", "ubound", NULL
1326 name
= e
->symtree
->n
.sym
->name
;
1328 for (i
= 0; inquiry_function
[i
]; i
++)
1329 if (strcmp (inquiry_function
[i
], name
) == 0)
1332 if (inquiry_function
[i
] == NULL
)
1335 e
= e
->value
.function
.actual
->expr
;
1337 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1340 /* At this point we have a numeric inquiry function with a variable
1341 argument. The type of the variable might be undefined, but we
1342 need it now, because the arguments of these functions are allowed
1345 if (e
->ts
.type
== BT_UNKNOWN
)
1347 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1348 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1352 e
->ts
= e
->symtree
->n
.sym
->ts
;
1359 /* Verify that an expression is an initialization expression. A side
1360 effect is that the expression tree is reduced to a single constant
1361 node if all goes well. This would normally happen when the
1362 expression is constructed but function references are assumed to be
1363 intrinsics in the context of initialization expressions. If
1364 FAILURE is returned an error message has been generated. */
1367 check_init_expr (gfc_expr
* e
)
1369 gfc_actual_arglist
*ap
;
1376 switch (e
->expr_type
)
1379 t
= check_intrinsic_op (e
, check_init_expr
);
1381 t
= gfc_simplify_expr (e
, 0);
1388 if (check_inquiry (e
) != SUCCESS
)
1391 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1392 if (check_init_expr (ap
->expr
) == FAILURE
)
1401 m
= gfc_intrinsic_func_interface (e
, 0);
1404 gfc_error ("Function '%s' in initialization expression at %L "
1405 "must be an intrinsic function",
1406 e
->symtree
->n
.sym
->name
, &e
->where
);
1417 if (gfc_check_iter_variable (e
) == SUCCESS
)
1420 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1422 t
= simplify_parameter_variable (e
, 0);
1426 gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1427 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1436 case EXPR_SUBSTRING
:
1437 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1441 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1443 t
= gfc_simplify_expr (e
, 0);
1447 case EXPR_STRUCTURE
:
1448 t
= gfc_check_constructor (e
, check_init_expr
);
1452 t
= gfc_check_constructor (e
, check_init_expr
);
1456 t
= gfc_expand_constructor (e
);
1460 t
= gfc_check_constructor_type (e
);
1464 gfc_internal_error ("check_init_expr(): Unknown expression type");
1471 /* Match an initialization expression. We work by first matching an
1472 expression, then reducing it to a constant. */
1475 gfc_match_init_expr (gfc_expr
** result
)
1481 m
= gfc_match_expr (&expr
);
1486 t
= gfc_resolve_expr (expr
);
1488 t
= check_init_expr (expr
);
1493 gfc_free_expr (expr
);
1497 if (expr
->expr_type
== EXPR_ARRAY
1498 && (gfc_check_constructor_type (expr
) == FAILURE
1499 || gfc_expand_constructor (expr
) == FAILURE
))
1501 gfc_free_expr (expr
);
1505 if (!gfc_is_constant_expr (expr
))
1506 gfc_internal_error ("Initialization expression didn't reduce %C");
1515 static try check_restricted (gfc_expr
*);
1517 /* Given an actual argument list, test to see that each argument is a
1518 restricted expression and optionally if the expression type is
1519 integer or character. */
1522 restricted_args (gfc_actual_arglist
* a
)
1524 for (; a
; a
= a
->next
)
1526 if (check_restricted (a
->expr
) == FAILURE
)
1534 /************* Restricted/specification expressions *************/
1537 /* Make sure a non-intrinsic function is a specification function. */
1540 external_spec_function (gfc_expr
* e
)
1544 f
= e
->value
.function
.esym
;
1546 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1548 gfc_error ("Specification function '%s' at %L cannot be a statement "
1549 "function", f
->name
, &e
->where
);
1553 if (f
->attr
.proc
== PROC_INTERNAL
)
1555 gfc_error ("Specification function '%s' at %L cannot be an internal "
1556 "function", f
->name
, &e
->where
);
1562 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1567 if (f
->attr
.recursive
)
1569 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1570 f
->name
, &e
->where
);
1574 return restricted_args (e
->value
.function
.actual
);
1578 /* Check to see that a function reference to an intrinsic is a
1579 restricted expression. */
1582 restricted_intrinsic (gfc_expr
* e
)
1584 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1585 if (check_inquiry (e
) == SUCCESS
)
1588 return restricted_args (e
->value
.function
.actual
);
1592 /* Verify that an expression is a restricted expression. Like its
1593 cousin check_init_expr(), an error message is generated if we
1597 check_restricted (gfc_expr
* e
)
1605 switch (e
->expr_type
)
1608 t
= check_intrinsic_op (e
, check_restricted
);
1610 t
= gfc_simplify_expr (e
, 0);
1615 t
= e
->value
.function
.esym
?
1616 external_spec_function (e
) : restricted_intrinsic (e
);
1621 sym
= e
->symtree
->n
.sym
;
1624 if (sym
->attr
.optional
)
1626 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1627 sym
->name
, &e
->where
);
1631 if (sym
->attr
.intent
== INTENT_OUT
)
1633 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1634 sym
->name
, &e
->where
);
1638 if (sym
->attr
.in_common
1639 || sym
->attr
.use_assoc
1641 || sym
->ns
!= gfc_current_ns
1642 || (sym
->ns
->proc_name
!= NULL
1643 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
1649 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1650 sym
->name
, &e
->where
);
1659 case EXPR_SUBSTRING
:
1660 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
1664 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
1666 t
= gfc_simplify_expr (e
, 0);
1670 case EXPR_STRUCTURE
:
1671 t
= gfc_check_constructor (e
, check_restricted
);
1675 t
= gfc_check_constructor (e
, check_restricted
);
1679 gfc_internal_error ("check_restricted(): Unknown expression type");
1686 /* Check to see that an expression is a specification expression. If
1687 we return FAILURE, an error has been generated. */
1690 gfc_specification_expr (gfc_expr
* e
)
1693 if (e
->ts
.type
!= BT_INTEGER
)
1695 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
1701 gfc_error ("Expression at %L must be scalar", &e
->where
);
1705 if (gfc_simplify_expr (e
, 0) == FAILURE
)
1708 return check_restricted (e
);
1712 /************** Expression conformance checks. *************/
1714 /* Given two expressions, make sure that the arrays are conformable. */
1717 gfc_check_conformance (const char *optype
, gfc_expr
* op1
, gfc_expr
* op2
)
1719 int op1_flag
, op2_flag
, d
;
1720 mpz_t op1_size
, op2_size
;
1723 if (op1
->rank
== 0 || op2
->rank
== 0)
1726 if (op1
->rank
!= op2
->rank
)
1728 gfc_error ("Incompatible ranks in %s at %L", optype
, &op1
->where
);
1734 for (d
= 0; d
< op1
->rank
; d
++)
1736 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
1737 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
1739 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
1741 gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1742 optype
, &op1
->where
, d
+ 1, (int) mpz_get_si (op1_size
),
1743 (int) mpz_get_si (op2_size
));
1749 mpz_clear (op1_size
);
1751 mpz_clear (op2_size
);
1761 /* Given an assignable expression and an arbitrary expression, make
1762 sure that the assignment can take place. */
1765 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
1769 sym
= lvalue
->symtree
->n
.sym
;
1771 if (sym
->attr
.intent
== INTENT_IN
)
1773 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1774 sym
->name
, &lvalue
->where
);
1778 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
1780 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1781 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
1785 if (lvalue
->ts
.type
== BT_UNKNOWN
)
1787 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1792 if (rvalue
->expr_type
== EXPR_NULL
)
1794 gfc_error ("NULL appears on right-hand side in assignment at %L",
1799 /* This is possibly a typo: x = f() instead of x => f() */
1800 if (gfc_option
.warn_surprising
1801 && rvalue
->expr_type
== EXPR_FUNCTION
1802 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
1803 gfc_warning ("POINTER valued function appears on right-hand side of "
1804 "assignment at %L", &rvalue
->where
);
1806 /* Check size of array assignments. */
1807 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
1808 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
1811 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1816 if (gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
1819 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
1822 gfc_error ("Incompatible types in assignment at %L, %s to %s",
1823 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
1824 gfc_typename (&lvalue
->ts
));
1829 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
1833 /* Check that a pointer assignment is OK. We first check lvalue, and
1834 we only check rvalue if it's not an assignment to NULL() or a
1835 NULLIFY statement. */
1838 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
1840 symbol_attribute attr
;
1843 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
1845 gfc_error ("Pointer assignment target is not a POINTER at %L",
1850 attr
= gfc_variable_attr (lvalue
, NULL
);
1853 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
1857 is_pure
= gfc_pure (NULL
);
1859 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
1861 gfc_error ("Bad pointer object in PURE procedure at %L",
1866 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1867 kind, etc for lvalue and rvalue must match, and rvalue must be a
1868 pure variable if we're in a pure function. */
1869 if (rvalue
->expr_type
== EXPR_NULL
)
1872 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1874 gfc_error ("Different types in pointer assignment at %L",
1879 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
1881 gfc_error ("Different kind type parameters in pointer "
1882 "assignment at %L", &lvalue
->where
);
1886 attr
= gfc_expr_attr (rvalue
);
1887 if (!attr
.target
&& !attr
.pointer
)
1889 gfc_error ("Pointer assignment target is neither TARGET "
1890 "nor POINTER at %L", &rvalue
->where
);
1894 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
1896 gfc_error ("Bad target in pointer assignment in PURE "
1897 "procedure at %L", &rvalue
->where
);
1900 if (lvalue
->rank
!= rvalue
->rank
)
1902 gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
1903 lvalue
->rank
, rvalue
->rank
, &rvalue
->where
);
1911 /* Relative of gfc_check_assign() except that the lvalue is a single
1912 symbol. Used for initialization assignments. */
1915 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
1920 memset (&lvalue
, '\0', sizeof (gfc_expr
));
1922 lvalue
.expr_type
= EXPR_VARIABLE
;
1923 lvalue
.ts
= sym
->ts
;
1925 lvalue
.rank
= sym
->as
->rank
;
1926 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
1927 lvalue
.symtree
->n
.sym
= sym
;
1928 lvalue
.where
= sym
->declared_at
;
1930 if (sym
->attr
.pointer
)
1931 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
1933 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
1935 gfc_free (lvalue
.symtree
);
1941 /* Get an expression for a default initializer. */
1944 gfc_default_initializer (gfc_typespec
*ts
)
1946 gfc_constructor
*tail
;
1952 /* See if we have a default initializer. */
1953 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1955 if (c
->initializer
&& init
== NULL
)
1956 init
= gfc_get_expr ();
1962 /* Build the constructor. */
1963 init
->expr_type
= EXPR_STRUCTURE
;
1965 init
->where
= ts
->derived
->declared_at
;
1967 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1970 init
->value
.constructor
= tail
= gfc_get_constructor ();
1973 tail
->next
= gfc_get_constructor ();
1978 tail
->expr
= gfc_copy_expr (c
->initializer
);
1984 /* Given a symbol, create an expression node with that symbol as a
1985 variable. If the symbol is array valued, setup a reference of the
1989 gfc_get_variable_expr (gfc_symtree
* var
)
1993 e
= gfc_get_expr ();
1994 e
->expr_type
= EXPR_VARIABLE
;
1996 e
->ts
= var
->n
.sym
->ts
;
1998 if (var
->n
.sym
->as
!= NULL
)
2000 e
->rank
= var
->n
.sym
->as
->rank
;
2001 e
->ref
= gfc_get_ref ();
2002 e
->ref
->type
= REF_ARRAY
;
2003 e
->ref
->u
.ar
.type
= AR_FULL
;