1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004 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
32 /* Get a new expr node. */
39 e
= gfc_getmem (sizeof (gfc_expr
));
41 gfc_clear_ts (&e
->ts
);
53 /* Free an argument list and everything below it. */
56 gfc_free_actual_arglist (gfc_actual_arglist
* a1
)
58 gfc_actual_arglist
*a2
;
63 gfc_free_expr (a1
->expr
);
70 /* Copy an arglist structure and all of the arguments. */
73 gfc_copy_actual_arglist (gfc_actual_arglist
* p
)
75 gfc_actual_arglist
*head
, *tail
, *new;
79 for (; p
; p
= p
->next
)
81 new = gfc_get_actual_arglist ();
84 new->expr
= gfc_copy_expr (p
->expr
);
99 /* Free a list of reference structures. */
102 gfc_free_ref_list (gfc_ref
* p
)
114 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
116 gfc_free_expr (p
->u
.ar
.start
[i
]);
117 gfc_free_expr (p
->u
.ar
.end
[i
]);
118 gfc_free_expr (p
->u
.ar
.stride
[i
]);
124 gfc_free_expr (p
->u
.ss
.start
);
125 gfc_free_expr (p
->u
.ss
.end
);
137 /* Workhorse function for gfc_free_expr() that frees everything
138 beneath an expression node, but not the node itself. This is
139 useful when we want to simplify a node and replace it with
140 something else or the expression node belongs to another structure. */
143 free_expr0 (gfc_expr
* e
)
147 switch (e
->expr_type
)
153 mpz_clear (e
->value
.integer
);
157 mpfr_clear (e
->value
.real
);
161 gfc_free (e
->value
.character
.string
);
165 mpfr_clear (e
->value
.complex.r
);
166 mpfr_clear (e
->value
.complex.i
);
177 gfc_free_expr (e
->op1
);
179 gfc_free_expr (e
->op2
);
183 gfc_free_actual_arglist (e
->value
.function
.actual
);
191 gfc_free_constructor (e
->value
.constructor
);
195 gfc_free (e
->value
.character
.string
);
202 gfc_internal_error ("free_expr0(): Bad expr type");
205 /* Free a shape array. */
206 if (e
->shape
!= NULL
)
208 for (n
= 0; n
< e
->rank
; n
++)
209 mpz_clear (e
->shape
[n
]);
214 gfc_free_ref_list (e
->ref
);
216 memset (e
, '\0', sizeof (gfc_expr
));
220 /* Free an expression node and everything beneath it. */
223 gfc_free_expr (gfc_expr
* e
)
234 /* Graft the *src expression onto the *dest subexpression. */
237 gfc_replace_expr (gfc_expr
* dest
, gfc_expr
* src
)
247 /* Try to extract an integer constant from the passed expression node.
248 Returns an error message or NULL if the result is set. It is
249 tempting to generate an error and return SUCCESS or FAILURE, but
250 failure is OK for some callers. */
253 gfc_extract_int (gfc_expr
* expr
, int *result
)
256 if (expr
->expr_type
!= EXPR_CONSTANT
)
257 return "Constant expression required at %C";
259 if (expr
->ts
.type
!= BT_INTEGER
)
260 return "Integer expression required at %C";
262 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
263 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
265 return "Integer value too large in expression at %C";
268 *result
= (int) mpz_get_si (expr
->value
.integer
);
274 /* Recursively copy a list of reference structures. */
277 copy_ref (gfc_ref
* src
)
285 dest
= gfc_get_ref ();
286 dest
->type
= src
->type
;
291 ar
= gfc_copy_array_ref (&src
->u
.ar
);
297 dest
->u
.c
= src
->u
.c
;
301 dest
->u
.ss
= src
->u
.ss
;
302 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
303 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
307 dest
->next
= copy_ref (src
->next
);
313 /* Copy a shape array. */
316 gfc_copy_shape (mpz_t
* shape
, int rank
)
324 new_shape
= gfc_get_shape (rank
);
326 for (n
= 0; n
< rank
; n
++)
327 mpz_init_set (new_shape
[n
], shape
[n
]);
333 /* Given an expression pointer, return a copy of the expression. This
334 subroutine is recursive. */
337 gfc_copy_expr (gfc_expr
* p
)
348 switch (q
->expr_type
)
351 s
= gfc_getmem (p
->value
.character
.length
+ 1);
352 q
->value
.character
.string
= s
;
354 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
356 q
->op1
= gfc_copy_expr (p
->op1
);
357 q
->op2
= gfc_copy_expr (p
->op2
);
364 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
368 gfc_set_model_kind (q
->ts
.kind
);
369 mpfr_init (q
->value
.real
);
370 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
374 gfc_set_model_kind (q
->ts
.kind
);
375 mpfr_init (q
->value
.complex.r
);
376 mpfr_init (q
->value
.complex.i
);
377 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
378 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
382 s
= gfc_getmem (p
->value
.character
.length
+ 1);
383 q
->value
.character
.string
= s
;
385 memcpy (s
, p
->value
.character
.string
,
386 p
->value
.character
.length
+ 1);
391 break; /* Already done */
395 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
405 case INTRINSIC_UPLUS
:
406 case INTRINSIC_UMINUS
:
407 q
->op1
= gfc_copy_expr (p
->op1
);
410 default: /* Binary operators */
411 q
->op1
= gfc_copy_expr (p
->op1
);
412 q
->op2
= gfc_copy_expr (p
->op2
);
419 q
->value
.function
.actual
=
420 gfc_copy_actual_arglist (p
->value
.function
.actual
);
425 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
433 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
435 q
->ref
= copy_ref (p
->ref
);
441 /* Return the maximum kind of two expressions. In general, higher
442 kind numbers mean more precision for numeric types. */
445 gfc_kind_max (gfc_expr
* e1
, gfc_expr
* e2
)
448 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
452 /* Returns nonzero if the type is numeric, zero otherwise. */
455 numeric_type (bt type
)
458 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
462 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
465 gfc_numeric_ts (gfc_typespec
* ts
)
468 return numeric_type (ts
->type
);
472 /* Returns an expression node that is an integer constant. */
481 p
->expr_type
= EXPR_CONSTANT
;
482 p
->ts
.type
= BT_INTEGER
;
483 p
->ts
.kind
= gfc_default_integer_kind ();
485 p
->where
= gfc_current_locus
;
486 mpz_init_set_si (p
->value
.integer
, i
);
492 /* Returns an expression node that is a logical constant. */
495 gfc_logical_expr (int i
, locus
* where
)
501 p
->expr_type
= EXPR_CONSTANT
;
502 p
->ts
.type
= BT_LOGICAL
;
503 p
->ts
.kind
= gfc_default_logical_kind ();
506 where
= &gfc_current_locus
;
508 p
->value
.logical
= i
;
514 /* Return an expression node with an optional argument list attached.
515 A variable number of gfc_expr pointers are strung together in an
516 argument list with a NULL pointer terminating the list. */
519 gfc_build_conversion (gfc_expr
* e
)
524 p
->expr_type
= EXPR_FUNCTION
;
526 p
->value
.function
.actual
= NULL
;
528 p
->value
.function
.actual
= gfc_get_actual_arglist ();
529 p
->value
.function
.actual
->expr
= e
;
535 /* Given an expression node with some sort of numeric binary
536 expression, insert type conversions required to make the operands
539 The exception is that the operands of an exponential don't have to
540 have the same type. If possible, the base is promoted to the type
541 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
542 1.0**2 stays as it is. */
545 gfc_type_convert_binary (gfc_expr
* e
)
552 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
554 gfc_clear_ts (&e
->ts
);
558 /* Kind conversions of same type. */
559 if (op1
->ts
.type
== op2
->ts
.type
)
562 if (op1
->ts
.kind
== op2
->ts
.kind
)
564 /* No type conversions. */
569 if (op1
->ts
.kind
> op2
->ts
.kind
)
570 gfc_convert_type (op2
, &op1
->ts
, 2);
572 gfc_convert_type (op1
, &op2
->ts
, 2);
578 /* Integer combined with real or complex. */
579 if (op2
->ts
.type
== BT_INTEGER
)
583 /* Special cose for ** operator. */
584 if (e
->operator == INTRINSIC_POWER
)
587 gfc_convert_type (e
->op2
, &e
->ts
, 2);
591 if (op1
->ts
.type
== BT_INTEGER
)
594 gfc_convert_type (e
->op1
, &e
->ts
, 2);
598 /* Real combined with complex. */
599 e
->ts
.type
= BT_COMPLEX
;
600 if (op1
->ts
.kind
> op2
->ts
.kind
)
601 e
->ts
.kind
= op1
->ts
.kind
;
603 e
->ts
.kind
= op2
->ts
.kind
;
604 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
605 gfc_convert_type (e
->op1
, &e
->ts
, 2);
606 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
607 gfc_convert_type (e
->op2
, &e
->ts
, 2);
614 /* Function to determine if an expression is constant or not. This
615 function expects that the expression has already been simplified. */
618 gfc_is_constant_expr (gfc_expr
* e
)
621 gfc_actual_arglist
*arg
;
627 switch (e
->expr_type
)
630 rv
= (gfc_is_constant_expr (e
->op1
)
632 || gfc_is_constant_expr (e
->op2
)));
641 /* Call to intrinsic with at least one argument. */
643 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
645 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
647 if (!gfc_is_constant_expr (arg
->expr
))
661 rv
= gfc_is_constant_expr (e
->op1
) && gfc_is_constant_expr (e
->op2
);
666 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
667 if (!gfc_is_constant_expr (c
->expr
))
675 rv
= gfc_constant_ac (e
);
679 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
686 /* Try to collapse intrinsic expressions. */
689 simplify_intrinsic_op (gfc_expr
* p
, int type
)
691 gfc_expr
*op1
, *op2
, *result
;
693 if (p
->operator == INTRINSIC_USER
)
699 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
701 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
704 if (!gfc_is_constant_expr (op1
)
705 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
714 case INTRINSIC_UPLUS
:
715 result
= gfc_uplus (op1
);
718 case INTRINSIC_UMINUS
:
719 result
= gfc_uminus (op1
);
723 result
= gfc_add (op1
, op2
);
726 case INTRINSIC_MINUS
:
727 result
= gfc_subtract (op1
, op2
);
730 case INTRINSIC_TIMES
:
731 result
= gfc_multiply (op1
, op2
);
734 case INTRINSIC_DIVIDE
:
735 result
= gfc_divide (op1
, op2
);
738 case INTRINSIC_POWER
:
739 result
= gfc_power (op1
, op2
);
742 case INTRINSIC_CONCAT
:
743 result
= gfc_concat (op1
, op2
);
747 result
= gfc_eq (op1
, op2
);
751 result
= gfc_ne (op1
, op2
);
755 result
= gfc_gt (op1
, op2
);
759 result
= gfc_ge (op1
, op2
);
763 result
= gfc_lt (op1
, op2
);
767 result
= gfc_le (op1
, op2
);
771 result
= gfc_not (op1
);
775 result
= gfc_and (op1
, op2
);
779 result
= gfc_or (op1
, op2
);
783 result
= gfc_eqv (op1
, op2
);
787 result
= gfc_neqv (op1
, op2
);
791 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
801 gfc_replace_expr (p
, result
);
807 /* Subroutine to simplify constructor expressions. Mutually recursive
808 with gfc_simplify_expr(). */
811 simplify_constructor (gfc_constructor
* c
, int type
)
814 for (; c
; c
= c
->next
)
817 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
818 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
819 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
822 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
830 /* Pull a single array element out of an array constructor. */
832 static gfc_constructor
*
833 find_array_element (gfc_constructor
* cons
, gfc_array_ref
* ar
)
835 unsigned long nelemen
;
840 mpz_init_set_ui (offset
, 0);
842 for (i
= 0; i
< ar
->dimen
; i
++)
844 if (ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
)
849 mpz_sub (delta
, ar
->start
[i
]->value
.integer
,
850 ar
->as
->lower
[i
]->value
.integer
);
851 mpz_add (offset
, offset
, delta
);
856 if (mpz_fits_ulong_p (offset
))
858 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
879 /* Find a component of a structure constructor. */
881 static gfc_constructor
*
882 find_component_ref (gfc_constructor
* cons
, gfc_ref
* ref
)
887 comp
= ref
->u
.c
.sym
->components
;
888 pick
= ref
->u
.c
.component
;
899 /* Replace an expression with the contents of a constructor, removing
900 the subobject reference in the process. */
903 remove_subobject_ref (gfc_expr
* p
, gfc_constructor
* cons
)
909 e
->ref
= p
->ref
->next
;
911 gfc_replace_expr (p
, e
);
915 /* Simplify a subobject reference of a constructor. This occurs when
916 parameter variable values are substituted. */
919 simplify_const_ref (gfc_expr
* p
)
921 gfc_constructor
*cons
;
925 switch (p
->ref
->type
)
928 switch (p
->ref
->u
.ar
.type
)
931 cons
= find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
);
934 remove_subobject_ref (p
, cons
);
938 if (p
->ref
->next
!= NULL
)
940 /* TODO: Simplify array subobject references. */
943 gfc_free_ref_list (p
->ref
);
948 /* TODO: Simplify array subsections. */
955 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
956 remove_subobject_ref (p
, cons
);
960 /* TODO: Constant substrings. */
969 /* Simplify a chain of references. */
972 simplify_ref_chain (gfc_ref
* ref
, int type
)
976 for (; ref
; ref
= ref
->next
)
981 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
983 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
)
986 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
)
989 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
)
996 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
998 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1010 /* Try to substitute the value of a parameter variable. */
1012 simplify_parameter_variable (gfc_expr
* p
, int type
)
1017 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1019 e
->ref
= copy_ref (p
->ref
);
1020 t
= gfc_simplify_expr (e
, type
);
1022 /* Only use the simplification if it eliminated all subobject
1024 if (t
== SUCCESS
&& ! e
->ref
)
1025 gfc_replace_expr (p
, e
);
1032 /* Given an expression, simplify it by collapsing constant
1033 expressions. Most simplification takes place when the expression
1034 tree is being constructed. If an intrinsic function is simplified
1035 at some point, we get called again to collapse the result against
1038 We work by recursively simplifying expression nodes, simplifying
1039 intrinsic functions where possible, which can lead to further
1040 constant collapsing. If an operator has constant operand(s), we
1041 rip the expression apart, and rebuild it, hoping that it becomes
1044 The expression type is defined for:
1045 0 Basic expression parsing
1046 1 Simplifying array constructors -- will substitute
1048 Returns FAILURE on error, SUCCESS otherwise.
1049 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1052 gfc_simplify_expr (gfc_expr
* p
, int type
)
1054 gfc_actual_arglist
*ap
;
1059 switch (p
->expr_type
)
1066 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1067 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1070 if (p
->value
.function
.isym
!= NULL
1071 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1076 case EXPR_SUBSTRING
:
1077 if (gfc_simplify_expr (p
->op1
, type
) == FAILURE
1078 || gfc_simplify_expr (p
->op2
, type
) == FAILURE
)
1081 /* TODO: evaluate constant substrings. */
1086 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1091 /* Only substitute array parameter variables if we are in an
1092 initialization expression, or we want a subsection. */
1093 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1094 && (gfc_init_expr
|| p
->ref
1095 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1097 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1104 gfc_simplify_iterator_var (p
);
1107 /* Simplify subcomponent references. */
1108 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1113 case EXPR_STRUCTURE
:
1115 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1118 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1121 if (p
->expr_type
== EXPR_ARRAY
)
1122 gfc_expand_constructor (p
);
1124 if (simplify_const_ref (p
) == FAILURE
)
1134 /* Returns the type of an expression with the exception that iterator
1135 variables are automatically integers no matter what else they may
1142 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1149 /* Check an intrinsic arithmetic operation to see if it is consistent
1150 with some type of expression. */
1152 static try check_init_expr (gfc_expr
*);
1155 check_intrinsic_op (gfc_expr
* e
, try (*check_function
) (gfc_expr
*))
1158 if ((*check_function
) (e
->op1
) == FAILURE
)
1161 switch (e
->operator)
1163 case INTRINSIC_UPLUS
:
1164 case INTRINSIC_UMINUS
:
1165 if (!numeric_type (et0 (e
->op1
)))
1175 if ((*check_function
) (e
->op2
) == FAILURE
)
1178 if (!(et0 (e
->op1
) == BT_CHARACTER
&& et0 (e
->op2
) == BT_CHARACTER
)
1179 && !(numeric_type (et0 (e
->op1
)) && numeric_type (et0 (e
->op2
))))
1181 gfc_error ("Numeric or CHARACTER operands are required in "
1182 "expression at %L", &e
->where
);
1187 case INTRINSIC_PLUS
:
1188 case INTRINSIC_MINUS
:
1189 case INTRINSIC_TIMES
:
1190 case INTRINSIC_DIVIDE
:
1191 case INTRINSIC_POWER
:
1192 if ((*check_function
) (e
->op2
) == FAILURE
)
1195 if (!numeric_type (et0 (e
->op1
)) || !numeric_type (et0 (e
->op2
)))
1198 if (e
->operator == INTRINSIC_POWER
1199 && check_function
== check_init_expr
&& et0 (e
->op2
) != BT_INTEGER
)
1201 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1202 "expression", &e
->op2
->where
);
1208 case INTRINSIC_CONCAT
:
1209 if ((*check_function
) (e
->op2
) == FAILURE
)
1212 if (et0 (e
->op1
) != BT_CHARACTER
|| et0 (e
->op2
) != BT_CHARACTER
)
1214 gfc_error ("Concatenation operator in expression at %L "
1215 "must have two CHARACTER operands", &e
->op1
->where
);
1219 if (e
->op1
->ts
.kind
!= e
->op2
->ts
.kind
)
1221 gfc_error ("Concat operator at %L must concatenate strings of the "
1222 "same kind", &e
->where
);
1229 if (et0 (e
->op1
) != BT_LOGICAL
)
1231 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1232 "operand", &e
->op1
->where
);
1241 case INTRINSIC_NEQV
:
1242 if ((*check_function
) (e
->op2
) == FAILURE
)
1245 if (et0 (e
->op1
) != BT_LOGICAL
|| et0 (e
->op2
) != BT_LOGICAL
)
1247 gfc_error ("LOGICAL operands are required in expression at %L",
1255 gfc_error ("Only intrinsic operators can be used in expression at %L",
1263 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1270 /* Certain inquiry functions are specifically allowed to have variable
1271 arguments, which is an exception to the normal requirement that an
1272 initialization function have initialization arguments. We head off
1273 this problem here. */
1276 check_inquiry (gfc_expr
* e
)
1280 /* FIXME: This should be moved into the intrinsic definitions,
1281 to eliminate this ugly hack. */
1282 static const char * const inquiry_function
[] = {
1283 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
1284 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1285 "lbound", "ubound", NULL
1290 name
= e
->symtree
->n
.sym
->name
;
1292 for (i
= 0; inquiry_function
[i
]; i
++)
1293 if (strcmp (inquiry_function
[i
], name
) == 0)
1296 if (inquiry_function
[i
] == NULL
)
1299 e
= e
->value
.function
.actual
->expr
;
1301 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1304 /* At this point we have a numeric inquiry function with a variable
1305 argument. The type of the variable might be undefined, but we
1306 need it now, because the arguments of these functions are allowed
1309 if (e
->ts
.type
== BT_UNKNOWN
)
1311 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1312 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1316 e
->ts
= e
->symtree
->n
.sym
->ts
;
1323 /* Verify that an expression is an initialization expression. A side
1324 effect is that the expression tree is reduced to a single constant
1325 node if all goes well. This would normally happen when the
1326 expression is constructed but function references are assumed to be
1327 intrinsics in the context of initialization expressions. If
1328 FAILURE is returned an error message has been generated. */
1331 check_init_expr (gfc_expr
* e
)
1333 gfc_actual_arglist
*ap
;
1340 switch (e
->expr_type
)
1343 t
= check_intrinsic_op (e
, check_init_expr
);
1345 t
= gfc_simplify_expr (e
, 0);
1352 if (check_inquiry (e
) != SUCCESS
)
1355 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1356 if (check_init_expr (ap
->expr
) == FAILURE
)
1365 m
= gfc_intrinsic_func_interface (e
, 0);
1368 gfc_error ("Function '%s' in initialization expression at %L "
1369 "must be an intrinsic function",
1370 e
->symtree
->n
.sym
->name
, &e
->where
);
1381 if (gfc_check_iter_variable (e
) == SUCCESS
)
1384 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1386 t
= simplify_parameter_variable (e
, 0);
1390 gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1391 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1400 case EXPR_SUBSTRING
:
1401 t
= check_init_expr (e
->op1
);
1405 t
= check_init_expr (e
->op2
);
1407 t
= gfc_simplify_expr (e
, 0);
1411 case EXPR_STRUCTURE
:
1412 t
= gfc_check_constructor (e
, check_init_expr
);
1416 t
= gfc_check_constructor (e
, check_init_expr
);
1420 t
= gfc_expand_constructor (e
);
1424 t
= gfc_check_constructor_type (e
);
1428 gfc_internal_error ("check_init_expr(): Unknown expression type");
1435 /* Match an initialization expression. We work by first matching an
1436 expression, then reducing it to a constant. */
1439 gfc_match_init_expr (gfc_expr
** result
)
1445 m
= gfc_match_expr (&expr
);
1450 t
= gfc_resolve_expr (expr
);
1452 t
= check_init_expr (expr
);
1457 gfc_free_expr (expr
);
1461 if (expr
->expr_type
== EXPR_ARRAY
1462 && (gfc_check_constructor_type (expr
) == FAILURE
1463 || gfc_expand_constructor (expr
) == FAILURE
))
1465 gfc_free_expr (expr
);
1469 if (!gfc_is_constant_expr (expr
))
1470 gfc_internal_error ("Initialization expression didn't reduce %C");
1479 static try check_restricted (gfc_expr
*);
1481 /* Given an actual argument list, test to see that each argument is a
1482 restricted expression and optionally if the expression type is
1483 integer or character. */
1486 restricted_args (gfc_actual_arglist
* a
)
1488 for (; a
; a
= a
->next
)
1490 if (check_restricted (a
->expr
) == FAILURE
)
1498 /************* Restricted/specification expressions *************/
1501 /* Make sure a non-intrinsic function is a specification function. */
1504 external_spec_function (gfc_expr
* e
)
1508 f
= e
->value
.function
.esym
;
1510 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1512 gfc_error ("Specification function '%s' at %L cannot be a statement "
1513 "function", f
->name
, &e
->where
);
1517 if (f
->attr
.proc
== PROC_INTERNAL
)
1519 gfc_error ("Specification function '%s' at %L cannot be an internal "
1520 "function", f
->name
, &e
->where
);
1526 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1531 if (f
->attr
.recursive
)
1533 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1534 f
->name
, &e
->where
);
1538 return restricted_args (e
->value
.function
.actual
);
1542 /* Check to see that a function reference to an intrinsic is a
1543 restricted expression. */
1546 restricted_intrinsic (gfc_expr
* e
)
1548 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1549 if (check_inquiry (e
) == SUCCESS
)
1552 return restricted_args (e
->value
.function
.actual
);
1556 /* Verify that an expression is a restricted expression. Like its
1557 cousin check_init_expr(), an error message is generated if we
1561 check_restricted (gfc_expr
* e
)
1569 switch (e
->expr_type
)
1572 t
= check_intrinsic_op (e
, check_restricted
);
1574 t
= gfc_simplify_expr (e
, 0);
1579 t
= e
->value
.function
.esym
?
1580 external_spec_function (e
) : restricted_intrinsic (e
);
1585 sym
= e
->symtree
->n
.sym
;
1588 if (sym
->attr
.optional
)
1590 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1591 sym
->name
, &e
->where
);
1595 if (sym
->attr
.intent
== INTENT_OUT
)
1597 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1598 sym
->name
, &e
->where
);
1602 if (sym
->attr
.in_common
1603 || sym
->attr
.use_assoc
1605 || sym
->ns
!= gfc_current_ns
1606 || (sym
->ns
->proc_name
!= NULL
1607 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
1613 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1614 sym
->name
, &e
->where
);
1623 case EXPR_SUBSTRING
:
1624 t
= gfc_specification_expr (e
->op1
);
1628 t
= gfc_specification_expr (e
->op2
);
1630 t
= gfc_simplify_expr (e
, 0);
1634 case EXPR_STRUCTURE
:
1635 t
= gfc_check_constructor (e
, check_restricted
);
1639 t
= gfc_check_constructor (e
, check_restricted
);
1643 gfc_internal_error ("check_restricted(): Unknown expression type");
1650 /* Check to see that an expression is a specification expression. If
1651 we return FAILURE, an error has been generated. */
1654 gfc_specification_expr (gfc_expr
* e
)
1657 if (e
->ts
.type
!= BT_INTEGER
)
1659 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
1665 gfc_error ("Expression at %L must be scalar", &e
->where
);
1669 if (gfc_simplify_expr (e
, 0) == FAILURE
)
1672 return check_restricted (e
);
1676 /************** Expression conformance checks. *************/
1678 /* Given two expressions, make sure that the arrays are conformable. */
1681 gfc_check_conformance (const char *optype
, gfc_expr
* op1
, gfc_expr
* op2
)
1683 int op1_flag
, op2_flag
, d
;
1684 mpz_t op1_size
, op2_size
;
1687 if (op1
->rank
== 0 || op2
->rank
== 0)
1690 if (op1
->rank
!= op2
->rank
)
1692 gfc_error ("Incompatible ranks in %s at %L", optype
, &op1
->where
);
1698 for (d
= 0; d
< op1
->rank
; d
++)
1700 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
1701 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
1703 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
1705 gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1706 optype
, &op1
->where
, d
+ 1, (int) mpz_get_si (op1_size
),
1707 (int) mpz_get_si (op2_size
));
1713 mpz_clear (op1_size
);
1715 mpz_clear (op2_size
);
1725 /* Given an assignable expression and an arbitrary expression, make
1726 sure that the assignment can take place. */
1729 gfc_check_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
, int conform
)
1733 sym
= lvalue
->symtree
->n
.sym
;
1735 if (sym
->attr
.intent
== INTENT_IN
)
1737 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1738 sym
->name
, &lvalue
->where
);
1742 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
1744 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1745 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
1749 if (lvalue
->ts
.type
== BT_UNKNOWN
)
1751 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1756 if (rvalue
->expr_type
== EXPR_NULL
)
1757 gfc_warning ("NULL appears on right-hand side in assignment at %L",
1760 /* Check size of array assignments. */
1761 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
1762 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
1765 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1770 if (gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
1773 gfc_error ("Incompatible types in assignment at %L, %s to %s",
1774 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
1775 gfc_typename (&lvalue
->ts
));
1780 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
1784 /* Check that a pointer assignment is OK. We first check lvalue, and
1785 we only check rvalue if it's not an assignment to NULL() or a
1786 NULLIFY statement. */
1789 gfc_check_pointer_assign (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
1791 symbol_attribute attr
;
1794 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
1796 gfc_error ("Pointer assignment target is not a POINTER at %L",
1801 attr
= gfc_variable_attr (lvalue
, NULL
);
1804 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
1808 is_pure
= gfc_pure (NULL
);
1810 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
1812 gfc_error ("Bad pointer object in PURE procedure at %L",
1817 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1818 kind, etc for lvalue and rvalue must match, and rvalue must be a
1819 pure variable if we're in a pure function. */
1820 if (rvalue
->expr_type
== EXPR_NULL
)
1823 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
1825 gfc_error ("Different types in pointer assignment at %L",
1830 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
1832 gfc_error ("Different kind type parameters in pointer "
1833 "assignment at %L", &lvalue
->where
);
1837 attr
= gfc_expr_attr (rvalue
);
1838 if (!attr
.target
&& !attr
.pointer
)
1840 gfc_error ("Pointer assignment target is neither TARGET "
1841 "nor POINTER at %L", &rvalue
->where
);
1845 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
1847 gfc_error ("Bad target in pointer assignment in PURE "
1848 "procedure at %L", &rvalue
->where
);
1851 if (lvalue
->rank
!= rvalue
->rank
)
1853 gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
1854 lvalue
->rank
, rvalue
->rank
, &rvalue
->where
);
1862 /* Relative of gfc_check_assign() except that the lvalue is a single
1863 symbol. Used for initialization assignments. */
1866 gfc_check_assign_symbol (gfc_symbol
* sym
, gfc_expr
* rvalue
)
1871 memset (&lvalue
, '\0', sizeof (gfc_expr
));
1873 lvalue
.expr_type
= EXPR_VARIABLE
;
1874 lvalue
.ts
= sym
->ts
;
1876 lvalue
.rank
= sym
->as
->rank
;
1877 lvalue
.symtree
= (gfc_symtree
*)gfc_getmem (sizeof (gfc_symtree
));
1878 lvalue
.symtree
->n
.sym
= sym
;
1879 lvalue
.where
= sym
->declared_at
;
1881 if (sym
->attr
.pointer
)
1882 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
1884 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
1886 gfc_free (lvalue
.symtree
);
1892 /* Get an expression for a default initializer. */
1895 gfc_default_initializer (gfc_typespec
*ts
)
1897 gfc_constructor
*tail
;
1903 /* See if we have a default initializer. */
1904 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1906 if (c
->initializer
&& init
== NULL
)
1907 init
= gfc_get_expr ();
1913 /* Build the constructor. */
1914 init
->expr_type
= EXPR_STRUCTURE
;
1916 init
->where
= ts
->derived
->declared_at
;
1918 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
1921 init
->value
.constructor
= tail
= gfc_get_constructor ();
1924 tail
->next
= gfc_get_constructor ();
1929 tail
->expr
= gfc_copy_expr (c
->initializer
);