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
);
50 /* Free an argument list and everything below it. */
53 gfc_free_actual_arglist (gfc_actual_arglist
* a1
)
55 gfc_actual_arglist
*a2
;
60 gfc_free_expr (a1
->expr
);
67 /* Copy an arglist structure and all of the arguments. */
70 gfc_copy_actual_arglist (gfc_actual_arglist
* p
)
72 gfc_actual_arglist
*head
, *tail
, *new;
76 for (; p
; p
= p
->next
)
78 new = gfc_get_actual_arglist ();
81 new->expr
= gfc_copy_expr (p
->expr
);
96 /* Free a list of reference structures. */
99 gfc_free_ref_list (gfc_ref
* p
)
111 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
113 gfc_free_expr (p
->u
.ar
.start
[i
]);
114 gfc_free_expr (p
->u
.ar
.end
[i
]);
115 gfc_free_expr (p
->u
.ar
.stride
[i
]);
121 gfc_free_expr (p
->u
.ss
.start
);
122 gfc_free_expr (p
->u
.ss
.end
);
134 /* Workhorse function for gfc_free_expr() that frees everything
135 beneath an expression node, but not the node itself. This is
136 useful when we want to simplify a node and replace it with
137 something else or the expression node belongs to another structure. */
140 free_expr0 (gfc_expr
* e
)
144 switch (e
->expr_type
)
150 mpz_clear (e
->value
.integer
);
154 mpfr_clear (e
->value
.real
);
158 gfc_free (e
->value
.character
.string
);
162 mpfr_clear (e
->value
.complex.r
);
163 mpfr_clear (e
->value
.complex.i
);
174 gfc_free_expr (e
->op1
);
176 gfc_free_expr (e
->op2
);
180 gfc_free_actual_arglist (e
->value
.function
.actual
);
188 gfc_free_constructor (e
->value
.constructor
);
192 gfc_free (e
->value
.character
.string
);
199 gfc_internal_error ("free_expr0(): Bad expr type");
202 /* Free a shape array. */
203 if (e
->shape
!= NULL
)
205 for (n
= 0; n
< e
->rank
; n
++)
206 mpz_clear (e
->shape
[n
]);
211 gfc_free_ref_list (e
->ref
);
213 memset (e
, '\0', sizeof (gfc_expr
));
217 /* Free an expression node and everything beneath it. */
220 gfc_free_expr (gfc_expr
* e
)
231 /* Graft the *src expression onto the *dest subexpression. */
234 gfc_replace_expr (gfc_expr
* dest
, gfc_expr
* src
)
244 /* Try to extract an integer constant from the passed expression node.
245 Returns an error message or NULL if the result is set. It is
246 tempting to generate an error and return SUCCESS or FAILURE, but
247 failure is OK for some callers. */
250 gfc_extract_int (gfc_expr
* expr
, int *result
)
253 if (expr
->expr_type
!= EXPR_CONSTANT
)
254 return "Constant expression required at %C";
256 if (expr
->ts
.type
!= BT_INTEGER
)
257 return "Integer expression required at %C";
259 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
260 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
262 return "Integer value too large in expression at %C";
265 *result
= (int) mpz_get_si (expr
->value
.integer
);
271 /* Recursively copy a list of reference structures. */
274 copy_ref (gfc_ref
* src
)
282 dest
= gfc_get_ref ();
283 dest
->type
= src
->type
;
288 ar
= gfc_copy_array_ref (&src
->u
.ar
);
294 dest
->u
.c
= src
->u
.c
;
298 dest
->u
.ss
= src
->u
.ss
;
299 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
300 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
304 dest
->next
= copy_ref (src
->next
);
310 /* Copy a shape array. */
313 gfc_copy_shape (mpz_t
* shape
, int rank
)
321 new_shape
= gfc_get_shape (rank
);
323 for (n
= 0; n
< rank
; n
++)
324 mpz_init_set (new_shape
[n
], shape
[n
]);
330 /* Copy a shape array excluding dimension N, where N is an integer
331 constant expression. Dimensions are numbered in fortran style --
334 So, if the original shape array contains R elements
335 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
336 the result contains R-1 elements:
337 { s1 ... sN-1 sN+1 ... sR-1}
339 If anything goes wrong -- N is not a constant, its value is out
340 of range -- or anything else, just returns NULL.
344 gfc_copy_shape_excluding (mpz_t
* shape
, int rank
, gfc_expr
* dim
)
346 mpz_t
*new_shape
, *s
;
352 || dim
->expr_type
!= EXPR_CONSTANT
353 || dim
->ts
.type
!= BT_INTEGER
)
356 n
= mpz_get_si (dim
->value
.integer
);
357 n
--; /* Convert to zero based index */
358 if (n
< 0 && n
>= rank
)
361 s
= new_shape
= gfc_get_shape (rank
-1);
363 for (i
= 0; i
< rank
; i
++)
367 mpz_init_set (*s
, shape
[i
]);
374 /* Given an expression pointer, return a copy of the expression. This
375 subroutine is recursive. */
378 gfc_copy_expr (gfc_expr
* p
)
389 switch (q
->expr_type
)
392 s
= gfc_getmem (p
->value
.character
.length
+ 1);
393 q
->value
.character
.string
= s
;
395 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
402 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
406 gfc_set_model_kind (q
->ts
.kind
);
407 mpfr_init (q
->value
.real
);
408 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
412 gfc_set_model_kind (q
->ts
.kind
);
413 mpfr_init (q
->value
.complex.r
);
414 mpfr_init (q
->value
.complex.i
);
415 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
416 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
420 s
= gfc_getmem (p
->value
.character
.length
+ 1);
421 q
->value
.character
.string
= s
;
423 memcpy (s
, p
->value
.character
.string
,
424 p
->value
.character
.length
+ 1);
429 break; /* Already done */
433 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
443 case INTRINSIC_UPLUS
:
444 case INTRINSIC_UMINUS
:
445 q
->op1
= gfc_copy_expr (p
->op1
);
448 default: /* Binary operators */
449 q
->op1
= gfc_copy_expr (p
->op1
);
450 q
->op2
= gfc_copy_expr (p
->op2
);
457 q
->value
.function
.actual
=
458 gfc_copy_actual_arglist (p
->value
.function
.actual
);
463 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
471 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
473 q
->ref
= copy_ref (p
->ref
);
479 /* Return the maximum kind of two expressions. In general, higher
480 kind numbers mean more precision for numeric types. */
483 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
486 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
490 /* Returns nonzero if the type is numeric, zero otherwise. */
493 numeric_type (bt type
)
496 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
500 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
503 gfc_numeric_ts (gfc_typespec
* ts
)
506 return numeric_type (ts
->type
);
510 /* Returns an expression node that is an integer constant. */
519 p
->expr_type
= EXPR_CONSTANT
;
520 p
->ts
.type
= BT_INTEGER
;
521 p
->ts
.kind
= gfc_default_integer_kind
;
523 p
->where
= gfc_current_locus
;
524 mpz_init_set_si (p
->value
.integer
, i
);
530 /* Returns an expression node that is a logical constant. */
533 gfc_logical_expr (int i
, locus
* where
)
539 p
->expr_type
= EXPR_CONSTANT
;
540 p
->ts
.type
= BT_LOGICAL
;
541 p
->ts
.kind
= gfc_default_logical_kind
;
544 where
= &gfc_current_locus
;
546 p
->value
.logical
= i
;
552 /* Return an expression node with an optional argument list attached.
553 A variable number of gfc_expr pointers are strung together in an
554 argument list with a NULL pointer terminating the list. */
557 gfc_build_conversion (gfc_expr
* e
)
562 p
->expr_type
= EXPR_FUNCTION
;
564 p
->value
.function
.actual
= NULL
;
566 p
->value
.function
.actual
= gfc_get_actual_arglist ();
567 p
->value
.function
.actual
->expr
= e
;
573 /* Given an expression node with some sort of numeric binary
574 expression, insert type conversions required to make the operands
577 The exception is that the operands of an exponential don't have to
578 have the same type. If possible, the base is promoted to the type
579 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
580 1.0**2 stays as it is. */
583 gfc_type_convert_binary (gfc_expr
* e
)
590 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
592 gfc_clear_ts (&e
->ts
);
596 /* Kind conversions of same type. */
597 if (op1
->ts
.type
== op2
->ts
.type
)
600 if (op1
->ts
.kind
== op2
->ts
.kind
)
602 /* No type conversions. */
607 if (op1
->ts
.kind
> op2
->ts
.kind
)
608 gfc_convert_type (op2
, &op1
->ts
, 2);
610 gfc_convert_type (op1
, &op2
->ts
, 2);
616 /* Integer combined with real or complex. */
617 if (op2
->ts
.type
== BT_INTEGER
)
621 /* Special cose for ** operator. */
622 if (e
->operator == INTRINSIC_POWER
)
625 gfc_convert_type (e
->op2
, &e
->ts
, 2);
629 if (op1
->ts
.type
== BT_INTEGER
)
632 gfc_convert_type (e
->op1
, &e
->ts
, 2);
636 /* Real combined with complex. */
637 e
->ts
.type
= BT_COMPLEX
;
638 if (op1
->ts
.kind
> op2
->ts
.kind
)
639 e
->ts
.kind
= op1
->ts
.kind
;
641 e
->ts
.kind
= op2
->ts
.kind
;
642 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
643 gfc_convert_type (e
->op1
, &e
->ts
, 2);
644 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
645 gfc_convert_type (e
->op2
, &e
->ts
, 2);
652 /* Function to determine if an expression is constant or not. This
653 function expects that the expression has already been simplified. */
656 gfc_is_constant_expr (gfc_expr
* e
)
659 gfc_actual_arglist
*arg
;
665 switch (e
->expr_type
)
668 rv
= (gfc_is_constant_expr (e
->op1
)
670 || gfc_is_constant_expr (e
->op2
)));
679 /* Call to intrinsic with at least one argument. */
681 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
683 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
685 if (!gfc_is_constant_expr (arg
->expr
))
699 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
700 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
705 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
706 if (!gfc_is_constant_expr (c
->expr
))
714 rv
= gfc_constant_ac (e
);
718 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
725 /* Try to collapse intrinsic expressions. */
728 simplify_intrinsic_op (gfc_expr
* p
, int type
)
730 gfc_expr
*op1
, *op2
, *result
;
732 if (p
->operator == INTRINSIC_USER
)
738 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
740 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
743 if (!gfc_is_constant_expr (op1
)
744 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
753 case INTRINSIC_UPLUS
:
754 result
= gfc_uplus (op1
);
757 case INTRINSIC_UMINUS
:
758 result
= gfc_uminus (op1
);
762 result
= gfc_add (op1
, op2
);
765 case INTRINSIC_MINUS
:
766 result
= gfc_subtract (op1
, op2
);
769 case INTRINSIC_TIMES
:
770 result
= gfc_multiply (op1
, op2
);
773 case INTRINSIC_DIVIDE
:
774 result
= gfc_divide (op1
, op2
);
777 case INTRINSIC_POWER
:
778 result
= gfc_power (op1
, op2
);
781 case INTRINSIC_CONCAT
:
782 result
= gfc_concat (op1
, op2
);
786 result
= gfc_eq (op1
, op2
);
790 result
= gfc_ne (op1
, op2
);
794 result
= gfc_gt (op1
, op2
);
798 result
= gfc_ge (op1
, op2
);
802 result
= gfc_lt (op1
, op2
);
806 result
= gfc_le (op1
, op2
);
810 result
= gfc_not (op1
);
814 result
= gfc_and (op1
, op2
);
818 result
= gfc_or (op1
, op2
);
822 result
= gfc_eqv (op1
, op2
);
826 result
= gfc_neqv (op1
, op2
);
830 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
840 gfc_replace_expr (p
, result
);
846 /* Subroutine to simplify constructor expressions. Mutually recursive
847 with gfc_simplify_expr(). */
850 simplify_constructor (gfc_constructor
* c
, int type
)
853 for (; c
; c
= c
->next
)
856 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
857 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
858 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
861 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
869 /* Pull a single array element out of an array constructor. */
871 static gfc_constructor
*
872 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
)
874 unsigned long nelemen
;
879 mpz_init_set_ui (offset
, 0);
881 for (i
= 0; i
< ar
->dimen
; i
++)
883 if (ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
)
888 mpz_sub (delta
, ar
->start
[i
]->value
.integer
,
889 ar
->as
->lower
[i
]->value
.integer
);
890 mpz_add (offset
, offset
, delta
);
895 if (mpz_fits_ulong_p (offset
))
897 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
918 /* Find a component of a structure constructor. */
920 static gfc_constructor
*
921 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
926 comp
= ref
->u
.c
.sym
->components
;
927 pick
= ref
->u
.c
.component
;
938 /* Replace an expression with the contents of a constructor, removing
939 the subobject reference in the process. */
942 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
948 e
->ref
= p
->ref
->next
;
950 gfc_replace_expr (p
, e
);
954 /* Simplify a subobject reference of a constructor. This occurs when
955 parameter variable values are substituted. */
958 simplify_const_ref (gfc_expr
* p
)
960 gfc_constructor
*cons
;
964 switch (p
->ref
->type
)
967 switch (p
->ref
->u
.ar
.type
)
970 cons
= find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
);
973 remove_subobject_ref (p
, cons
);
977 if (p
->ref
->next
!= NULL
)
979 /* TODO: Simplify array subobject references. */
982 gfc_free_ref_list (p
->ref
);
987 /* TODO: Simplify array subsections. */
994 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
995 remove_subobject_ref (p
, cons
);
999 /* TODO: Constant substrings. */
1008 /* Simplify a chain of references. */
1011 simplify_ref_chain (gfc_ref
* ref
, int type
)
1015 for (; ref
; ref
= ref
->next
)
1020 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1022 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1025 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1028 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1035 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1037 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1049 /* Try to substitute the value of a parameter variable. */
1051 simplify_parameter_variable (gfc_expr
* p
, int type
)
1056 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1058 e
->ref
= copy_ref (p
->ref
);
1059 t
= gfc_simplify_expr (e
, type
);
1061 /* Only use the simplification if it eliminated all subobject
1063 if (t
== SUCCESS
&& ! e
->ref
)
1064 gfc_replace_expr (p
, e
);
1071 /* Given an expression, simplify it by collapsing constant
1072 expressions. Most simplification takes place when the expression
1073 tree is being constructed. If an intrinsic function is simplified
1074 at some point, we get called again to collapse the result against
1077 We work by recursively simplifying expression nodes, simplifying
1078 intrinsic functions where possible, which can lead to further
1079 constant collapsing. If an operator has constant operand(s), we
1080 rip the expression apart, and rebuild it, hoping that it becomes
1083 The expression type is defined for:
1084 0 Basic expression parsing
1085 1 Simplifying array constructors -- will substitute
1087 Returns FAILURE on error, SUCCESS otherwise.
1088 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1091 gfc_simplify_expr (gfc_expr
* p
, int type
)
1093 gfc_actual_arglist
*ap
;
1098 switch (p
->expr_type
)
1105 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1106 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1109 if (p
->value
.function
.isym
!= NULL
1110 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1115 case EXPR_SUBSTRING
:
1116 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1119 /* TODO: evaluate constant substrings. */
1123 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1128 /* Only substitute array parameter variables if we are in an
1129 initialization expression, or we want a subsection. */
1130 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1131 && (gfc_init_expr
|| p
->ref
1132 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1134 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1141 gfc_simplify_iterator_var (p
);
1144 /* Simplify subcomponent references. */
1145 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1150 case EXPR_STRUCTURE
:
1152 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1155 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1158 if (p
->expr_type
== EXPR_ARRAY
)
1159 gfc_expand_constructor (p
);
1161 if (simplify_const_ref (p
) == FAILURE
)
1171 /* Returns the type of an expression with the exception that iterator
1172 variables are automatically integers no matter what else they may
1179 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1186 /* Check an intrinsic arithmetic operation to see if it is consistent
1187 with some type of expression. */
1189 static try check_init_expr (gfc_expr
*);
1192 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1195 if ((*check_function
) (e
->op1
) == FAILURE
)
1198 switch (e
->operator)
1200 case INTRINSIC_UPLUS
:
1201 case INTRINSIC_UMINUS
:
1202 if (!numeric_type (et0 (e
->op1
)))
1212 if ((*check_function
) (e
->op2
) == FAILURE
)
1215 if (!(et0 (e
->op1
) == BT_CHARACTER
&& et0 (e
->op2
) == BT_CHARACTER
)
1216 && !(numeric_type (et0 (e
->op1
)) && numeric_type (et0 (e
->op2
))))
1218 gfc_error ("Numeric or CHARACTER operands are required in "
1219 "expression at %L", &e
->where
);
1224 case INTRINSIC_PLUS
:
1225 case INTRINSIC_MINUS
:
1226 case INTRINSIC_TIMES
:
1227 case INTRINSIC_DIVIDE
:
1228 case INTRINSIC_POWER
:
1229 if ((*check_function
) (e
->op2
) == FAILURE
)
1232 if (!numeric_type (et0 (e
->op1
)) || !numeric_type (et0 (e
->op2
)))
1235 if (e
->operator == INTRINSIC_POWER
1236 && check_function
== check_init_expr
&& et0 (e
->op2
) != BT_INTEGER
)
1238 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1239 "expression", &e
->op2
->where
);
1245 case INTRINSIC_CONCAT
:
1246 if ((*check_function
) (e
->op2
) == FAILURE
)
1249 if (et0 (e
->op1
) != BT_CHARACTER
|| et0 (e
->op2
) != BT_CHARACTER
)
1251 gfc_error ("Concatenation operator in expression at %L "
1252 "must have two CHARACTER operands", &e
->op1
->where
);
1256 if (e
->op1
->ts
.kind
!= e
->op2
->ts
.kind
)
1258 gfc_error ("Concat operator at %L must concatenate strings of the "
1259 "same kind", &e
->where
);
1266 if (et0 (e
->op1
) != BT_LOGICAL
)
1268 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1269 "operand", &e
->op1
->where
);
1278 case INTRINSIC_NEQV
:
1279 if ((*check_function
) (e
->op2
) == FAILURE
)
1282 if (et0 (e
->op1
) != BT_LOGICAL
|| et0 (e
->op2
) != BT_LOGICAL
)
1284 gfc_error ("LOGICAL operands are required in expression at %L",
1292 gfc_error ("Only intrinsic operators can be used in expression at %L",
1300 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1307 /* Certain inquiry functions are specifically allowed to have variable
1308 arguments, which is an exception to the normal requirement that an
1309 initialization function have initialization arguments. We head off
1310 this problem here. */
1313 check_inquiry (gfc_expr
* e
)
1317 /* FIXME: This should be moved into the intrinsic definitions,
1318 to eliminate this ugly hack. */
1319 static const char * const inquiry_function
[] = {
1320 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
1321 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1322 "lbound", "ubound", NULL
1327 name
= e
->symtree
->n
.sym
->name
;
1329 for (i
= 0; inquiry_function
[i
]; i
++)
1330 if (strcmp (inquiry_function
[i
], name
) == 0)
1333 if (inquiry_function
[i
] == NULL
)
1336 e
= e
->value
.function
.actual
->expr
;
1338 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1341 /* At this point we have a numeric inquiry function with a variable
1342 argument. The type of the variable might be undefined, but we
1343 need it now, because the arguments of these functions are allowed
1346 if (e
->ts
.type
== BT_UNKNOWN
)
1348 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1349 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1353 e
->ts
= e
->symtree
->n
.sym
->ts
;
1360 /* Verify that an expression is an initialization expression. A side
1361 effect is that the expression tree is reduced to a single constant
1362 node if all goes well. This would normally happen when the
1363 expression is constructed but function references are assumed to be
1364 intrinsics in the context of initialization expressions. If
1365 FAILURE is returned an error message has been generated. */
1368 check_init_expr (gfc_expr
* e
)
1370 gfc_actual_arglist
*ap
;
1377 switch (e
->expr_type
)
1380 t
= check_intrinsic_op (e
, check_init_expr
);
1382 t
= gfc_simplify_expr (e
, 0);
1389 if (check_inquiry (e
) != SUCCESS
)
1392 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1393 if (check_init_expr (ap
->expr
) == FAILURE
)
1402 m
= gfc_intrinsic_func_interface (e
, 0);
1405 gfc_error ("Function '%s' in initialization expression at %L "
1406 "must be an intrinsic function",
1407 e
->symtree
->n
.sym
->name
, &e
->where
);
1418 if (gfc_check_iter_variable (e
) == SUCCESS
)
1421 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1423 t
= simplify_parameter_variable (e
, 0);
1427 gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1428 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1437 case EXPR_SUBSTRING
:
1438 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1442 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1444 t
= gfc_simplify_expr (e
, 0);
1448 case EXPR_STRUCTURE
:
1449 t
= gfc_check_constructor (e
, check_init_expr
);
1453 t
= gfc_check_constructor (e
, check_init_expr
);
1457 t
= gfc_expand_constructor (e
);
1461 t
= gfc_check_constructor_type (e
);
1465 gfc_internal_error ("check_init_expr(): Unknown expression type");
1472 /* Match an initialization expression. We work by first matching an
1473 expression, then reducing it to a constant. */
1476 gfc_match_init_expr (gfc_expr
** result
)
1482 m
= gfc_match_expr (&expr
);
1487 t
= gfc_resolve_expr (expr
);
1489 t
= check_init_expr (expr
);
1494 gfc_free_expr (expr
);
1498 if (expr
->expr_type
== EXPR_ARRAY
1499 && (gfc_check_constructor_type (expr
) == FAILURE
1500 || gfc_expand_constructor (expr
) == FAILURE
))
1502 gfc_free_expr (expr
);
1506 if (!gfc_is_constant_expr (expr
))
1507 gfc_internal_error ("Initialization expression didn't reduce %C");
1516 static try check_restricted (gfc_expr
*);
1518 /* Given an actual argument list, test to see that each argument is a
1519 restricted expression and optionally if the expression type is
1520 integer or character. */
1523 restricted_args (gfc_actual_arglist
* a
)
1525 for (; a
; a
= a
->next
)
1527 if (check_restricted (a
->expr
) == FAILURE
)
1535 /************* Restricted/specification expressions *************/
1538 /* Make sure a non-intrinsic function is a specification function. */
1541 external_spec_function (gfc_expr
* e
)
1545 f
= e
->value
.function
.esym
;
1547 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1549 gfc_error ("Specification function '%s' at %L cannot be a statement "
1550 "function", f
->name
, &e
->where
);
1554 if (f
->attr
.proc
== PROC_INTERNAL
)
1556 gfc_error ("Specification function '%s' at %L cannot be an internal "
1557 "function", f
->name
, &e
->where
);
1563 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1568 if (f
->attr
.recursive
)
1570 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1571 f
->name
, &e
->where
);
1575 return restricted_args (e
->value
.function
.actual
);
1579 /* Check to see that a function reference to an intrinsic is a
1580 restricted expression. */
1583 restricted_intrinsic (gfc_expr
* e
)
1585 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1586 if (check_inquiry (e
) == SUCCESS
)
1589 return restricted_args (e
->value
.function
.actual
);
1593 /* Verify that an expression is a restricted expression. Like its
1594 cousin check_init_expr(), an error message is generated if we
1598 check_restricted (gfc_expr
* e
)
1606 switch (e
->expr_type
)
1609 t
= check_intrinsic_op (e
, check_restricted
);
1611 t
= gfc_simplify_expr (e
, 0);
1616 t
= e
->value
.function
.esym
?
1617 external_spec_function (e
) : restricted_intrinsic (e
);
1622 sym
= e
->symtree
->n
.sym
;
1625 if (sym
->attr
.optional
)
1627 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1628 sym
->name
, &e
->where
);
1632 if (sym
->attr
.intent
== INTENT_OUT
)
1634 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1635 sym
->name
, &e
->where
);
1639 if (sym
->attr
.in_common
1640 || sym
->attr
.use_assoc
1642 || sym
->ns
!= gfc_current_ns
1643 || (sym
->ns
->proc_name
!= NULL
1644 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
1650 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1651 sym
->name
, &e
->where
);
1660 case EXPR_SUBSTRING
:
1661 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
1665 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
1667 t
= gfc_simplify_expr (e
, 0);
1671 case EXPR_STRUCTURE
:
1672 t
= gfc_check_constructor (e
, check_restricted
);
1676 t
= gfc_check_constructor (e
, check_restricted
);
1680 gfc_internal_error ("check_restricted(): Unknown expression type");
1687 /* Check to see that an expression is a specification expression. If
1688 we return FAILURE, an error has been generated. */
1691 gfc_specification_expr (gfc_expr
* e
)
1694 if (e
->ts
.type
!= BT_INTEGER
)
1696 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
1702 gfc_error ("Expression at %L must be scalar", &e
->where
);
1706 if (gfc_simplify_expr (e
, 0) == FAILURE
)
1709 return check_restricted (e
);
1713 /************** Expression conformance checks. *************/
1715 /* Given two expressions, make sure that the arrays are conformable. */
1718 gfc_check_conformance (const char *optype
, gfc_expr
* op1
, gfc_expr
* op2
)
1720 int op1_flag
, op2_flag
, d
;
1721 mpz_t op1_size
, op2_size
;
1724 if (op1
->rank
== 0 || op2
->rank
== 0)
1727 if (op1
->rank
!= op2
->rank
)
1729 gfc_error ("Incompatible ranks in %s at %L", optype
, &op1
->where
);
1735 for (d
= 0; d
< op1
->rank
; d
++)
1737 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
1738 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
1740 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
1742 gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1743 optype
, &op1
->where
, d
+ 1, (int) mpz_get_si (op1_size
),
1744 (int) mpz_get_si (op2_size
));
1750 mpz_clear (op1_size
);
1752 mpz_clear (op2_size
);
1762 /* Given an assignable expression and an arbitrary expression, make
1763 sure that the assignment can take place. */
1766 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
1770 sym
= lvalue
->symtree
->n
.sym
;
1772 if (sym
->attr
.intent
== INTENT_IN
)
1774 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1775 sym
->name
, &lvalue
->where
);
1779 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
1781 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1782 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
1786 if (lvalue
->ts
.type
== BT_UNKNOWN
)
1788 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1793 /* This is a guaranteed segfault and possibly a typo: p = NULL()
1794 instead of p => NULL() */
1795 if (rvalue
->expr_type
== EXPR_NULL
)
1796 gfc_warning ("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
;