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);
397 q
->op1
= gfc_copy_expr (p
->op1
);
398 q
->op2
= gfc_copy_expr (p
->op2
);
405 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
409 gfc_set_model_kind (q
->ts
.kind
);
410 mpfr_init (q
->value
.real
);
411 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
415 gfc_set_model_kind (q
->ts
.kind
);
416 mpfr_init (q
->value
.complex.r
);
417 mpfr_init (q
->value
.complex.i
);
418 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
419 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
423 s
= gfc_getmem (p
->value
.character
.length
+ 1);
424 q
->value
.character
.string
= s
;
426 memcpy (s
, p
->value
.character
.string
,
427 p
->value
.character
.length
+ 1);
432 break; /* Already done */
436 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
446 case INTRINSIC_UPLUS
:
447 case INTRINSIC_UMINUS
:
448 q
->op1
= gfc_copy_expr (p
->op1
);
451 default: /* Binary operators */
452 q
->op1
= gfc_copy_expr (p
->op1
);
453 q
->op2
= gfc_copy_expr (p
->op2
);
460 q
->value
.function
.actual
=
461 gfc_copy_actual_arglist (p
->value
.function
.actual
);
466 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
474 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
476 q
->ref
= copy_ref (p
->ref
);
482 /* Return the maximum kind of two expressions. In general, higher
483 kind numbers mean more precision for numeric types. */
486 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
489 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
493 /* Returns nonzero if the type is numeric, zero otherwise. */
496 numeric_type (bt type
)
499 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
503 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
506 gfc_numeric_ts (gfc_typespec
* ts
)
509 return numeric_type (ts
->type
);
513 /* Returns an expression node that is an integer constant. */
522 p
->expr_type
= EXPR_CONSTANT
;
523 p
->ts
.type
= BT_INTEGER
;
524 p
->ts
.kind
= gfc_default_integer_kind
;
526 p
->where
= gfc_current_locus
;
527 mpz_init_set_si (p
->value
.integer
, i
);
533 /* Returns an expression node that is a logical constant. */
536 gfc_logical_expr (int i
, locus
* where
)
542 p
->expr_type
= EXPR_CONSTANT
;
543 p
->ts
.type
= BT_LOGICAL
;
544 p
->ts
.kind
= gfc_default_logical_kind
;
547 where
= &gfc_current_locus
;
549 p
->value
.logical
= i
;
555 /* Return an expression node with an optional argument list attached.
556 A variable number of gfc_expr pointers are strung together in an
557 argument list with a NULL pointer terminating the list. */
560 gfc_build_conversion (gfc_expr
* e
)
565 p
->expr_type
= EXPR_FUNCTION
;
567 p
->value
.function
.actual
= NULL
;
569 p
->value
.function
.actual
= gfc_get_actual_arglist ();
570 p
->value
.function
.actual
->expr
= e
;
576 /* Given an expression node with some sort of numeric binary
577 expression, insert type conversions required to make the operands
580 The exception is that the operands of an exponential don't have to
581 have the same type. If possible, the base is promoted to the type
582 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
583 1.0**2 stays as it is. */
586 gfc_type_convert_binary (gfc_expr
* e
)
593 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
595 gfc_clear_ts (&e
->ts
);
599 /* Kind conversions of same type. */
600 if (op1
->ts
.type
== op2
->ts
.type
)
603 if (op1
->ts
.kind
== op2
->ts
.kind
)
605 /* No type conversions. */
610 if (op1
->ts
.kind
> op2
->ts
.kind
)
611 gfc_convert_type (op2
, &op1
->ts
, 2);
613 gfc_convert_type (op1
, &op2
->ts
, 2);
619 /* Integer combined with real or complex. */
620 if (op2
->ts
.type
== BT_INTEGER
)
624 /* Special cose for ** operator. */
625 if (e
->operator == INTRINSIC_POWER
)
628 gfc_convert_type (e
->op2
, &e
->ts
, 2);
632 if (op1
->ts
.type
== BT_INTEGER
)
635 gfc_convert_type (e
->op1
, &e
->ts
, 2);
639 /* Real combined with complex. */
640 e
->ts
.type
= BT_COMPLEX
;
641 if (op1
->ts
.kind
> op2
->ts
.kind
)
642 e
->ts
.kind
= op1
->ts
.kind
;
644 e
->ts
.kind
= op2
->ts
.kind
;
645 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
646 gfc_convert_type (e
->op1
, &e
->ts
, 2);
647 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
648 gfc_convert_type (e
->op2
, &e
->ts
, 2);
655 /* Function to determine if an expression is constant or not. This
656 function expects that the expression has already been simplified. */
659 gfc_is_constant_expr (gfc_expr
* e
)
662 gfc_actual_arglist
*arg
;
668 switch (e
->expr_type
)
671 rv
= (gfc_is_constant_expr (e
->op1
)
673 || gfc_is_constant_expr (e
->op2
)));
682 /* Call to intrinsic with at least one argument. */
684 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
686 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
688 if (!gfc_is_constant_expr (arg
->expr
))
702 rv
= gfc_is_constant_expr (e
->op1
) && gfc_is_constant_expr (e
->op2
);
707 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
708 if (!gfc_is_constant_expr (c
->expr
))
716 rv
= gfc_constant_ac (e
);
720 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
727 /* Try to collapse intrinsic expressions. */
730 simplify_intrinsic_op (gfc_expr
* p
, int type
)
732 gfc_expr
*op1
, *op2
, *result
;
734 if (p
->operator == INTRINSIC_USER
)
740 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
742 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
745 if (!gfc_is_constant_expr (op1
)
746 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
755 case INTRINSIC_UPLUS
:
756 result
= gfc_uplus (op1
);
759 case INTRINSIC_UMINUS
:
760 result
= gfc_uminus (op1
);
764 result
= gfc_add (op1
, op2
);
767 case INTRINSIC_MINUS
:
768 result
= gfc_subtract (op1
, op2
);
771 case INTRINSIC_TIMES
:
772 result
= gfc_multiply (op1
, op2
);
775 case INTRINSIC_DIVIDE
:
776 result
= gfc_divide (op1
, op2
);
779 case INTRINSIC_POWER
:
780 result
= gfc_power (op1
, op2
);
783 case INTRINSIC_CONCAT
:
784 result
= gfc_concat (op1
, op2
);
788 result
= gfc_eq (op1
, op2
);
792 result
= gfc_ne (op1
, op2
);
796 result
= gfc_gt (op1
, op2
);
800 result
= gfc_ge (op1
, op2
);
804 result
= gfc_lt (op1
, op2
);
808 result
= gfc_le (op1
, op2
);
812 result
= gfc_not (op1
);
816 result
= gfc_and (op1
, op2
);
820 result
= gfc_or (op1
, op2
);
824 result
= gfc_eqv (op1
, op2
);
828 result
= gfc_neqv (op1
, op2
);
832 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
842 gfc_replace_expr (p
, result
);
848 /* Subroutine to simplify constructor expressions. Mutually recursive
849 with gfc_simplify_expr(). */
852 simplify_constructor (gfc_constructor
* c
, int type
)
855 for (; c
; c
= c
->next
)
858 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
859 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
860 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
863 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
871 /* Pull a single array element out of an array constructor. */
873 static gfc_constructor
*
874 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
)
876 unsigned long nelemen
;
881 mpz_init_set_ui (offset
, 0);
883 for (i
= 0; i
< ar
->dimen
; i
++)
885 if (ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
)
890 mpz_sub (delta
, ar
->start
[i
]->value
.integer
,
891 ar
->as
->lower
[i
]->value
.integer
);
892 mpz_add (offset
, offset
, delta
);
897 if (mpz_fits_ulong_p (offset
))
899 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
920 /* Find a component of a structure constructor. */
922 static gfc_constructor
*
923 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
928 comp
= ref
->u
.c
.sym
->components
;
929 pick
= ref
->u
.c
.component
;
940 /* Replace an expression with the contents of a constructor, removing
941 the subobject reference in the process. */
944 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
950 e
->ref
= p
->ref
->next
;
952 gfc_replace_expr (p
, e
);
956 /* Simplify a subobject reference of a constructor. This occurs when
957 parameter variable values are substituted. */
960 simplify_const_ref (gfc_expr
* p
)
962 gfc_constructor
*cons
;
966 switch (p
->ref
->type
)
969 switch (p
->ref
->u
.ar
.type
)
972 cons
= find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
);
975 remove_subobject_ref (p
, cons
);
979 if (p
->ref
->next
!= NULL
)
981 /* TODO: Simplify array subobject references. */
984 gfc_free_ref_list (p
->ref
);
989 /* TODO: Simplify array subsections. */
996 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
997 remove_subobject_ref (p
, cons
);
1001 /* TODO: Constant substrings. */
1010 /* Simplify a chain of references. */
1013 simplify_ref_chain (gfc_ref
* ref
, int type
)
1017 for (; ref
; ref
= ref
->next
)
1022 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1024 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
1027 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
1030 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
1037 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1039 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1051 /* Try to substitute the value of a parameter variable. */
1053 simplify_parameter_variable (gfc_expr
* p
, int type
)
1058 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1060 e
->ref
= copy_ref (p
->ref
);
1061 t
= gfc_simplify_expr (e
, type
);
1063 /* Only use the simplification if it eliminated all subobject
1065 if (t
== SUCCESS
&& ! e
->ref
)
1066 gfc_replace_expr (p
, e
);
1073 /* Given an expression, simplify it by collapsing constant
1074 expressions. Most simplification takes place when the expression
1075 tree is being constructed. If an intrinsic function is simplified
1076 at some point, we get called again to collapse the result against
1079 We work by recursively simplifying expression nodes, simplifying
1080 intrinsic functions where possible, which can lead to further
1081 constant collapsing. If an operator has constant operand(s), we
1082 rip the expression apart, and rebuild it, hoping that it becomes
1085 The expression type is defined for:
1086 0 Basic expression parsing
1087 1 Simplifying array constructors -- will substitute
1089 Returns FAILURE on error, SUCCESS otherwise.
1090 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1093 gfc_simplify_expr (gfc_expr
* p
, int type
)
1095 gfc_actual_arglist
*ap
;
1100 switch (p
->expr_type
)
1107 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1108 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1111 if (p
->value
.function
.isym
!= NULL
1112 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1117 case EXPR_SUBSTRING
:
1118 if (gfc_simplify_expr (p
->op1
, type
) == FAILURE
1119 || gfc_simplify_expr (p
->op2
, type
) == FAILURE
)
1122 /* TODO: evaluate constant substrings. */
1127 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1132 /* Only substitute array parameter variables if we are in an
1133 initialization expression, or we want a subsection. */
1134 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1135 && (gfc_init_expr
|| p
->ref
1136 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1138 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1145 gfc_simplify_iterator_var (p
);
1148 /* Simplify subcomponent references. */
1149 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1154 case EXPR_STRUCTURE
:
1156 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1159 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1162 if (p
->expr_type
== EXPR_ARRAY
)
1163 gfc_expand_constructor (p
);
1165 if (simplify_const_ref (p
) == FAILURE
)
1175 /* Returns the type of an expression with the exception that iterator
1176 variables are automatically integers no matter what else they may
1183 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1190 /* Check an intrinsic arithmetic operation to see if it is consistent
1191 with some type of expression. */
1193 static try check_init_expr (gfc_expr
*);
1196 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1199 if ((*check_function
) (e
->op1
) == FAILURE
)
1202 switch (e
->operator)
1204 case INTRINSIC_UPLUS
:
1205 case INTRINSIC_UMINUS
:
1206 if (!numeric_type (et0 (e
->op1
)))
1216 if ((*check_function
) (e
->op2
) == FAILURE
)
1219 if (!(et0 (e
->op1
) == BT_CHARACTER
&& et0 (e
->op2
) == BT_CHARACTER
)
1220 && !(numeric_type (et0 (e
->op1
)) && numeric_type (et0 (e
->op2
))))
1222 gfc_error ("Numeric or CHARACTER operands are required in "
1223 "expression at %L", &e
->where
);
1228 case INTRINSIC_PLUS
:
1229 case INTRINSIC_MINUS
:
1230 case INTRINSIC_TIMES
:
1231 case INTRINSIC_DIVIDE
:
1232 case INTRINSIC_POWER
:
1233 if ((*check_function
) (e
->op2
) == FAILURE
)
1236 if (!numeric_type (et0 (e
->op1
)) || !numeric_type (et0 (e
->op2
)))
1239 if (e
->operator == INTRINSIC_POWER
1240 && check_function
== check_init_expr
&& et0 (e
->op2
) != BT_INTEGER
)
1242 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1243 "expression", &e
->op2
->where
);
1249 case INTRINSIC_CONCAT
:
1250 if ((*check_function
) (e
->op2
) == FAILURE
)
1253 if (et0 (e
->op1
) != BT_CHARACTER
|| et0 (e
->op2
) != BT_CHARACTER
)
1255 gfc_error ("Concatenation operator in expression at %L "
1256 "must have two CHARACTER operands", &e
->op1
->where
);
1260 if (e
->op1
->ts
.kind
!= e
->op2
->ts
.kind
)
1262 gfc_error ("Concat operator at %L must concatenate strings of the "
1263 "same kind", &e
->where
);
1270 if (et0 (e
->op1
) != BT_LOGICAL
)
1272 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1273 "operand", &e
->op1
->where
);
1282 case INTRINSIC_NEQV
:
1283 if ((*check_function
) (e
->op2
) == FAILURE
)
1286 if (et0 (e
->op1
) != BT_LOGICAL
|| et0 (e
->op2
) != BT_LOGICAL
)
1288 gfc_error ("LOGICAL operands are required in expression at %L",
1296 gfc_error ("Only intrinsic operators can be used in expression at %L",
1304 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1311 /* Certain inquiry functions are specifically allowed to have variable
1312 arguments, which is an exception to the normal requirement that an
1313 initialization function have initialization arguments. We head off
1314 this problem here. */
1317 check_inquiry (gfc_expr
* e
)
1321 /* FIXME: This should be moved into the intrinsic definitions,
1322 to eliminate this ugly hack. */
1323 static const char * const inquiry_function
[] = {
1324 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
1325 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1326 "lbound", "ubound", NULL
1331 name
= e
->symtree
->n
.sym
->name
;
1333 for (i
= 0; inquiry_function
[i
]; i
++)
1334 if (strcmp (inquiry_function
[i
], name
) == 0)
1337 if (inquiry_function
[i
] == NULL
)
1340 e
= e
->value
.function
.actual
->expr
;
1342 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1345 /* At this point we have a numeric inquiry function with a variable
1346 argument. The type of the variable might be undefined, but we
1347 need it now, because the arguments of these functions are allowed
1350 if (e
->ts
.type
== BT_UNKNOWN
)
1352 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1353 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1357 e
->ts
= e
->symtree
->n
.sym
->ts
;
1364 /* Verify that an expression is an initialization expression. A side
1365 effect is that the expression tree is reduced to a single constant
1366 node if all goes well. This would normally happen when the
1367 expression is constructed but function references are assumed to be
1368 intrinsics in the context of initialization expressions. If
1369 FAILURE is returned an error message has been generated. */
1372 check_init_expr (gfc_expr
* e
)
1374 gfc_actual_arglist
*ap
;
1381 switch (e
->expr_type
)
1384 t
= check_intrinsic_op (e
, check_init_expr
);
1386 t
= gfc_simplify_expr (e
, 0);
1393 if (check_inquiry (e
) != SUCCESS
)
1396 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1397 if (check_init_expr (ap
->expr
) == FAILURE
)
1406 m
= gfc_intrinsic_func_interface (e
, 0);
1409 gfc_error ("Function '%s' in initialization expression at %L "
1410 "must be an intrinsic function",
1411 e
->symtree
->n
.sym
->name
, &e
->where
);
1422 if (gfc_check_iter_variable (e
) == SUCCESS
)
1425 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1427 t
= simplify_parameter_variable (e
, 0);
1431 gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1432 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1441 case EXPR_SUBSTRING
:
1442 t
= check_init_expr (e
->op1
);
1446 t
= check_init_expr (e
->op2
);
1448 t
= gfc_simplify_expr (e
, 0);
1452 case EXPR_STRUCTURE
:
1453 t
= gfc_check_constructor (e
, check_init_expr
);
1457 t
= gfc_check_constructor (e
, check_init_expr
);
1461 t
= gfc_expand_constructor (e
);
1465 t
= gfc_check_constructor_type (e
);
1469 gfc_internal_error ("check_init_expr(): Unknown expression type");
1476 /* Match an initialization expression. We work by first matching an
1477 expression, then reducing it to a constant. */
1480 gfc_match_init_expr (gfc_expr
** result
)
1486 m
= gfc_match_expr (&expr
);
1491 t
= gfc_resolve_expr (expr
);
1493 t
= check_init_expr (expr
);
1498 gfc_free_expr (expr
);
1502 if (expr
->expr_type
== EXPR_ARRAY
1503 && (gfc_check_constructor_type (expr
) == FAILURE
1504 || gfc_expand_constructor (expr
) == FAILURE
))
1506 gfc_free_expr (expr
);
1510 if (!gfc_is_constant_expr (expr
))
1511 gfc_internal_error ("Initialization expression didn't reduce %C");
1520 static try check_restricted (gfc_expr
*);
1522 /* Given an actual argument list, test to see that each argument is a
1523 restricted expression and optionally if the expression type is
1524 integer or character. */
1527 restricted_args (gfc_actual_arglist
* a
)
1529 for (; a
; a
= a
->next
)
1531 if (check_restricted (a
->expr
) == FAILURE
)
1539 /************* Restricted/specification expressions *************/
1542 /* Make sure a non-intrinsic function is a specification function. */
1545 external_spec_function (gfc_expr
* e
)
1549 f
= e
->value
.function
.esym
;
1551 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1553 gfc_error ("Specification function '%s' at %L cannot be a statement "
1554 "function", f
->name
, &e
->where
);
1558 if (f
->attr
.proc
== PROC_INTERNAL
)
1560 gfc_error ("Specification function '%s' at %L cannot be an internal "
1561 "function", f
->name
, &e
->where
);
1567 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1572 if (f
->attr
.recursive
)
1574 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1575 f
->name
, &e
->where
);
1579 return restricted_args (e
->value
.function
.actual
);
1583 /* Check to see that a function reference to an intrinsic is a
1584 restricted expression. */
1587 restricted_intrinsic (gfc_expr
* e
)
1589 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1590 if (check_inquiry (e
) == SUCCESS
)
1593 return restricted_args (e
->value
.function
.actual
);
1597 /* Verify that an expression is a restricted expression. Like its
1598 cousin check_init_expr(), an error message is generated if we
1602 check_restricted (gfc_expr
* e
)
1610 switch (e
->expr_type
)
1613 t
= check_intrinsic_op (e
, check_restricted
);
1615 t
= gfc_simplify_expr (e
, 0);
1620 t
= e
->value
.function
.esym
?
1621 external_spec_function (e
) : restricted_intrinsic (e
);
1626 sym
= e
->symtree
->n
.sym
;
1629 if (sym
->attr
.optional
)
1631 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1632 sym
->name
, &e
->where
);
1636 if (sym
->attr
.intent
== INTENT_OUT
)
1638 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1639 sym
->name
, &e
->where
);
1643 if (sym
->attr
.in_common
1644 || sym
->attr
.use_assoc
1646 || sym
->ns
!= gfc_current_ns
1647 || (sym
->ns
->proc_name
!= NULL
1648 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
1654 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1655 sym
->name
, &e
->where
);
1664 case EXPR_SUBSTRING
:
1665 t
= gfc_specification_expr (e
->op1
);
1669 t
= gfc_specification_expr (e
->op2
);
1671 t
= gfc_simplify_expr (e
, 0);
1675 case EXPR_STRUCTURE
:
1676 t
= gfc_check_constructor (e
, check_restricted
);
1680 t
= gfc_check_constructor (e
, check_restricted
);
1684 gfc_internal_error ("check_restricted(): Unknown expression type");
1691 /* Check to see that an expression is a specification expression. If
1692 we return FAILURE, an error has been generated. */
1695 gfc_specification_expr (gfc_expr
* e
)
1698 if (e
->ts
.type
!= BT_INTEGER
)
1700 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
1706 gfc_error ("Expression at %L must be scalar", &e
->where
);
1710 if (gfc_simplify_expr (e
, 0) == FAILURE
)
1713 return check_restricted (e
);
1717 /************** Expression conformance checks. *************/
1719 /* Given two expressions, make sure that the arrays are conformable. */
1722 gfc_check_conformance (const char *optype
, gfc_expr
* op1
, gfc_expr
* op2
)
1724 int op1_flag
, op2_flag
, d
;
1725 mpz_t op1_size
, op2_size
;
1728 if (op1
->rank
== 0 || op2
->rank
== 0)
1731 if (op1
->rank
!= op2
->rank
)
1733 gfc_error ("Incompatible ranks in %s at %L", optype
, &op1
->where
);
1739 for (d
= 0; d
< op1
->rank
; d
++)
1741 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
1742 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
1744 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
1746 gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1747 optype
, &op1
->where
, d
+ 1, (int) mpz_get_si (op1_size
),
1748 (int) mpz_get_si (op2_size
));
1754 mpz_clear (op1_size
);
1756 mpz_clear (op2_size
);
1766 /* Given an assignable expression and an arbitrary expression, make
1767 sure that the assignment can take place. */
1770 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
1774 sym
= lvalue
->symtree
->n
.sym
;
1776 if (sym
->attr
.intent
== INTENT_IN
)
1778 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1779 sym
->name
, &lvalue
->where
);
1783 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
1785 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1786 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
1790 if (lvalue
->ts
.type
== BT_UNKNOWN
)
1792 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1797 /* This is a guaranteed segfault and possibly a typo: p = NULL()
1798 instead of p => NULL() */
1799 if (rvalue
->expr_type
== EXPR_NULL
)
1800 gfc_warning ("NULL appears on right-hand side in assignment at %L",
1803 /* This is possibly a typo: x = f() instead of x => f() */
1804 if (gfc_option
.warn_surprising
1805 && rvalue
->expr_type
== EXPR_FUNCTION
1806 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
1807 gfc_warning ("POINTER valued function appears on right-hand side of "
1808 "assignment at %L", &rvalue
->where
);
1810 /* Check size of array assignments. */
1811 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
1812 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
1815 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1820 if (gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
1823 gfc_error ("Incompatible types in assignment at %L, %s to %s",
1824 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
1825 gfc_typename (&lvalue
->ts
));
1830 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
1834 /* Check that a pointer assignment is OK. We first check lvalue, and
1835 we only check rvalue if it's not an assignment to NULL() or a
1836 NULLIFY statement. */
1839 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
1841 symbol_attribute attr
;
1844 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
1846 gfc_error ("Pointer assignment target is not a POINTER at %L",
1851 attr
= gfc_variable_attr (lvalue
, NULL
);
1854 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
1858 is_pure
= gfc_pure (NULL
);
1860 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
1862 gfc_error ("Bad pointer object in PURE procedure at %L",
1867 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1868 kind, etc for lvalue and rvalue must match, and rvalue must be a
1869 pure variable if we're in a pure function. */
1870 if (rvalue
->expr_type
== EXPR_NULL
)
1873 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1875 gfc_error ("Different types in pointer assignment at %L",
1880 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
1882 gfc_error ("Different kind type parameters in pointer "
1883 "assignment at %L", &lvalue
->where
);
1887 attr
= gfc_expr_attr (rvalue
);
1888 if (!attr
.target
&& !attr
.pointer
)
1890 gfc_error ("Pointer assignment target is neither TARGET "
1891 "nor POINTER at %L", &rvalue
->where
);
1895 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
1897 gfc_error ("Bad target in pointer assignment in PURE "
1898 "procedure at %L", &rvalue
->where
);
1901 if (lvalue
->rank
!= rvalue
->rank
)
1903 gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
1904 lvalue
->rank
, rvalue
->rank
, &rvalue
->where
);
1912 /* Relative of gfc_check_assign() except that the lvalue is a single
1913 symbol. Used for initialization assignments. */
1916 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
1921 memset (&lvalue
, '\0', sizeof (gfc_expr
));
1923 lvalue
.expr_type
= EXPR_VARIABLE
;
1924 lvalue
.ts
= sym
->ts
;
1926 lvalue
.rank
= sym
->as
->rank
;
1927 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
1928 lvalue
.symtree
->n
.sym
= sym
;
1929 lvalue
.where
= sym
->declared_at
;
1931 if (sym
->attr
.pointer
)
1932 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
1934 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
1936 gfc_free (lvalue
.symtree
);
1942 /* Get an expression for a default initializer. */
1945 gfc_default_initializer (gfc_typespec
*ts
)
1947 gfc_constructor
*tail
;
1953 /* See if we have a default initializer. */
1954 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1956 if (c
->initializer
&& init
== NULL
)
1957 init
= gfc_get_expr ();
1963 /* Build the constructor. */
1964 init
->expr_type
= EXPR_STRUCTURE
;
1966 init
->where
= ts
->derived
->declared_at
;
1968 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1971 init
->value
.constructor
= tail
= gfc_get_constructor ();
1974 tail
->next
= gfc_get_constructor ();
1979 tail
->expr
= gfc_copy_expr (c
->initializer
);
1985 /* Given a symbol, create an expression node with that symbol as a
1986 variable. If the symbol is array valued, setup a reference of the
1990 gfc_get_variable_expr (gfc_symtree
* var
)
1994 e
= gfc_get_expr ();
1995 e
->expr_type
= EXPR_VARIABLE
;
1997 e
->ts
= var
->n
.sym
->ts
;
1999 if (var
->n
.sym
->as
!= NULL
)
2001 e
->rank
= var
->n
.sym
->as
->rank
;
2002 e
->ref
= gfc_get_ref ();
2003 e
->ref
->type
= REF_ARRAY
;
2004 e
->ref
->u
.ar
.type
= AR_FULL
;