1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new;
72 for (; p
; p
= p
->next
)
74 new = gfc_get_actual_arglist ();
77 new->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
109 gfc_free_expr (p
->u
.ar
.start
[i
]);
110 gfc_free_expr (p
->u
.ar
.end
[i
]);
111 gfc_free_expr (p
->u
.ar
.stride
[i
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
159 mpfr_clear (e
->value
.complex.r
);
160 mpfr_clear (e
->value
.complex.i
);
167 /* Free the representation, except in character constants where it
168 is the same as value.character.string and thus already freed. */
169 if (e
->representation
.string
&& e
->ts
.type
!= BT_CHARACTER
)
170 gfc_free (e
->representation
.string
);
175 if (e
->value
.op
.op1
!= NULL
)
176 gfc_free_expr (e
->value
.op
.op1
);
177 if (e
->value
.op
.op2
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op2
);
182 gfc_free_actual_arglist (e
->value
.function
.actual
);
190 gfc_free_constructor (e
->value
.constructor
);
194 gfc_free (e
->value
.character
.string
);
201 gfc_internal_error ("free_expr0(): Bad expr type");
204 /* Free a shape array. */
205 if (e
->shape
!= NULL
)
207 for (n
= 0; n
< e
->rank
; n
++)
208 mpz_clear (e
->shape
[n
]);
213 gfc_free_ref_list (e
->ref
);
215 memset (e
, '\0', sizeof (gfc_expr
));
219 /* Free an expression node and everything beneath it. */
222 gfc_free_expr (gfc_expr
*e
)
226 if (e
->con_by_offset
)
227 splay_tree_delete (e
->con_by_offset
);
233 /* Graft the *src expression onto the *dest subexpression. */
236 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
)
252 if (expr
->expr_type
!= EXPR_CONSTANT
)
253 return _("Constant expression required at %C");
255 if (expr
->ts
.type
!= BT_INTEGER
)
256 return _("Integer expression required at %C");
258 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
259 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
261 return _("Integer value too large in expression at %C");
264 *result
= (int) mpz_get_si (expr
->value
.integer
);
270 /* Recursively copy a list of reference structures. */
273 copy_ref (gfc_ref
*src
)
281 dest
= gfc_get_ref ();
282 dest
->type
= src
->type
;
287 ar
= gfc_copy_array_ref (&src
->u
.ar
);
293 dest
->u
.c
= src
->u
.c
;
297 dest
->u
.ss
= src
->u
.ss
;
298 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
299 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
303 dest
->next
= copy_ref (src
->next
);
309 /* Detect whether an expression has any vector index array references. */
312 gfc_has_vector_index (gfc_expr
*e
)
316 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
317 if (ref
->type
== REF_ARRAY
)
318 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
319 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
325 /* Copy a shape array. */
328 gfc_copy_shape (mpz_t
*shape
, int rank
)
336 new_shape
= gfc_get_shape (rank
);
338 for (n
= 0; n
< rank
; n
++)
339 mpz_init_set (new_shape
[n
], shape
[n
]);
345 /* Copy a shape array excluding dimension N, where N is an integer
346 constant expression. Dimensions are numbered in fortran style --
349 So, if the original shape array contains R elements
350 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
351 the result contains R-1 elements:
352 { s1 ... sN-1 sN+1 ... sR-1}
354 If anything goes wrong -- N is not a constant, its value is out
355 of range -- or anything else, just returns NULL. */
358 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
360 mpz_t
*new_shape
, *s
;
366 || dim
->expr_type
!= EXPR_CONSTANT
367 || dim
->ts
.type
!= BT_INTEGER
)
370 n
= mpz_get_si (dim
->value
.integer
);
371 n
--; /* Convert to zero based index. */
372 if (n
< 0 || n
>= rank
)
375 s
= new_shape
= gfc_get_shape (rank
- 1);
377 for (i
= 0; i
< rank
; i
++)
381 mpz_init_set (*s
, shape
[i
]);
389 /* Given an expression pointer, return a copy of the expression. This
390 subroutine is recursive. */
393 gfc_copy_expr (gfc_expr
*p
)
404 switch (q
->expr_type
)
407 s
= gfc_getmem (p
->value
.character
.length
+ 1);
408 q
->value
.character
.string
= s
;
410 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
414 /* Copy target representation, if it exists. */
415 if (p
->representation
.string
)
417 s
= gfc_getmem (p
->representation
.length
+ 1);
418 q
->representation
.string
= s
;
420 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
423 /* Copy the values of any pointer components of p->value. */
427 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
431 gfc_set_model_kind (q
->ts
.kind
);
432 mpfr_init (q
->value
.real
);
433 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
437 gfc_set_model_kind (q
->ts
.kind
);
438 mpfr_init (q
->value
.complex.r
);
439 mpfr_init (q
->value
.complex.i
);
440 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
441 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
445 if (p
->representation
.string
)
446 q
->value
.character
.string
= q
->representation
.string
;
449 s
= gfc_getmem (p
->value
.character
.length
+ 1);
450 q
->value
.character
.string
= s
;
452 /* This is the case for the C_NULL_CHAR named constant. */
453 if (p
->value
.character
.length
== 0
454 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
457 /* Need to set the length to 1 to make sure the NUL
458 terminator is copied. */
459 q
->value
.character
.length
= 1;
462 memcpy (s
, p
->value
.character
.string
,
463 p
->value
.character
.length
+ 1);
470 break; /* Already done. */
474 /* Should never be reached. */
476 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
483 switch (q
->value
.op
.operator)
486 case INTRINSIC_PARENTHESES
:
487 case INTRINSIC_UPLUS
:
488 case INTRINSIC_UMINUS
:
489 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
492 default: /* Binary operators. */
493 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
494 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
501 q
->value
.function
.actual
=
502 gfc_copy_actual_arglist (p
->value
.function
.actual
);
507 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
515 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
517 q
->ref
= copy_ref (p
->ref
);
523 /* Return the maximum kind of two expressions. In general, higher
524 kind numbers mean more precision for numeric types. */
527 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
529 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
533 /* Returns nonzero if the type is numeric, zero otherwise. */
536 numeric_type (bt type
)
538 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
542 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
545 gfc_numeric_ts (gfc_typespec
*ts
)
547 return numeric_type (ts
->type
);
551 /* Returns an expression node that is an integer constant. */
560 p
->expr_type
= EXPR_CONSTANT
;
561 p
->ts
.type
= BT_INTEGER
;
562 p
->ts
.kind
= gfc_default_integer_kind
;
564 p
->where
= gfc_current_locus
;
565 mpz_init_set_si (p
->value
.integer
, i
);
571 /* Returns an expression node that is a logical constant. */
574 gfc_logical_expr (int i
, locus
*where
)
580 p
->expr_type
= EXPR_CONSTANT
;
581 p
->ts
.type
= BT_LOGICAL
;
582 p
->ts
.kind
= gfc_default_logical_kind
;
585 where
= &gfc_current_locus
;
587 p
->value
.logical
= i
;
593 /* Return an expression node with an optional argument list attached.
594 A variable number of gfc_expr pointers are strung together in an
595 argument list with a NULL pointer terminating the list. */
598 gfc_build_conversion (gfc_expr
*e
)
603 p
->expr_type
= EXPR_FUNCTION
;
605 p
->value
.function
.actual
= NULL
;
607 p
->value
.function
.actual
= gfc_get_actual_arglist ();
608 p
->value
.function
.actual
->expr
= e
;
614 /* Given an expression node with some sort of numeric binary
615 expression, insert type conversions required to make the operands
618 The exception is that the operands of an exponential don't have to
619 have the same type. If possible, the base is promoted to the type
620 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
621 1.0**2 stays as it is. */
624 gfc_type_convert_binary (gfc_expr
*e
)
628 op1
= e
->value
.op
.op1
;
629 op2
= e
->value
.op
.op2
;
631 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
633 gfc_clear_ts (&e
->ts
);
637 /* Kind conversions of same type. */
638 if (op1
->ts
.type
== op2
->ts
.type
)
640 if (op1
->ts
.kind
== op2
->ts
.kind
)
642 /* No type conversions. */
647 if (op1
->ts
.kind
> op2
->ts
.kind
)
648 gfc_convert_type (op2
, &op1
->ts
, 2);
650 gfc_convert_type (op1
, &op2
->ts
, 2);
656 /* Integer combined with real or complex. */
657 if (op2
->ts
.type
== BT_INTEGER
)
661 /* Special case for ** operator. */
662 if (e
->value
.op
.operator == INTRINSIC_POWER
)
665 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
669 if (op1
->ts
.type
== BT_INTEGER
)
672 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
676 /* Real combined with complex. */
677 e
->ts
.type
= BT_COMPLEX
;
678 if (op1
->ts
.kind
> op2
->ts
.kind
)
679 e
->ts
.kind
= op1
->ts
.kind
;
681 e
->ts
.kind
= op2
->ts
.kind
;
682 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
683 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
684 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
685 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
692 /* Function to determine if an expression is constant or not. This
693 function expects that the expression has already been simplified. */
696 gfc_is_constant_expr (gfc_expr
*e
)
699 gfc_actual_arglist
*arg
;
705 switch (e
->expr_type
)
708 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
709 && (e
->value
.op
.op2
== NULL
710 || gfc_is_constant_expr (e
->value
.op
.op2
)));
718 /* Call to intrinsic with at least one argument. */
720 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
722 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
724 if (!gfc_is_constant_expr (arg
->expr
))
738 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
739 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
744 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
745 if (!gfc_is_constant_expr (c
->expr
))
753 rv
= gfc_constant_ac (e
);
757 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
764 /* Try to collapse intrinsic expressions. */
767 simplify_intrinsic_op (gfc_expr
*p
, int type
)
770 gfc_expr
*op1
, *op2
, *result
;
772 if (p
->value
.op
.operator == INTRINSIC_USER
)
775 op1
= p
->value
.op
.op1
;
776 op2
= p
->value
.op
.op2
;
777 op
= p
->value
.op
.operator;
779 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
781 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
784 if (!gfc_is_constant_expr (op1
)
785 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
789 p
->value
.op
.op1
= NULL
;
790 p
->value
.op
.op2
= NULL
;
794 case INTRINSIC_PARENTHESES
:
795 result
= gfc_parentheses (op1
);
798 case INTRINSIC_UPLUS
:
799 result
= gfc_uplus (op1
);
802 case INTRINSIC_UMINUS
:
803 result
= gfc_uminus (op1
);
807 result
= gfc_add (op1
, op2
);
810 case INTRINSIC_MINUS
:
811 result
= gfc_subtract (op1
, op2
);
814 case INTRINSIC_TIMES
:
815 result
= gfc_multiply (op1
, op2
);
818 case INTRINSIC_DIVIDE
:
819 result
= gfc_divide (op1
, op2
);
822 case INTRINSIC_POWER
:
823 result
= gfc_power (op1
, op2
);
826 case INTRINSIC_CONCAT
:
827 result
= gfc_concat (op1
, op2
);
831 case INTRINSIC_EQ_OS
:
832 result
= gfc_eq (op1
, op2
, op
);
836 case INTRINSIC_NE_OS
:
837 result
= gfc_ne (op1
, op2
, op
);
841 case INTRINSIC_GT_OS
:
842 result
= gfc_gt (op1
, op2
, op
);
846 case INTRINSIC_GE_OS
:
847 result
= gfc_ge (op1
, op2
, op
);
851 case INTRINSIC_LT_OS
:
852 result
= gfc_lt (op1
, op2
, op
);
856 case INTRINSIC_LE_OS
:
857 result
= gfc_le (op1
, op2
, op
);
861 result
= gfc_not (op1
);
865 result
= gfc_and (op1
, op2
);
869 result
= gfc_or (op1
, op2
);
873 result
= gfc_eqv (op1
, op2
);
877 result
= gfc_neqv (op1
, op2
);
881 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
891 result
->rank
= p
->rank
;
892 result
->where
= p
->where
;
893 gfc_replace_expr (p
, result
);
899 /* Subroutine to simplify constructor expressions. Mutually recursive
900 with gfc_simplify_expr(). */
903 simplify_constructor (gfc_constructor
*c
, int type
)
905 for (; c
; c
= c
->next
)
908 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
909 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
910 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
913 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
921 /* Pull a single array element out of an array constructor. */
924 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
925 gfc_constructor
**rval
)
927 unsigned long nelemen
;
939 mpz_init_set_ui (offset
, 0);
942 mpz_init_set_ui (span
, 1);
943 for (i
= 0; i
< ar
->dimen
; i
++)
945 e
= gfc_copy_expr (ar
->start
[i
]);
946 if (e
->expr_type
!= EXPR_CONSTANT
)
952 /* Check the bounds. */
954 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
955 || mpz_cmp (e
->value
.integer
,
956 ar
->as
->lower
[i
]->value
.integer
) < 0))
958 gfc_error ("index in dimension %d is out of bounds "
959 "at %L", i
+ 1, &ar
->c_where
[i
]);
965 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
966 mpz_mul (delta
, delta
, span
);
967 mpz_add (offset
, offset
, delta
);
970 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
971 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
972 mpz_mul (span
, span
, tmp
);
977 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1000 /* Find a component of a structure constructor. */
1002 static gfc_constructor
*
1003 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1005 gfc_component
*comp
;
1006 gfc_component
*pick
;
1008 comp
= ref
->u
.c
.sym
->components
;
1009 pick
= ref
->u
.c
.component
;
1010 while (comp
!= pick
)
1020 /* Replace an expression with the contents of a constructor, removing
1021 the subobject reference in the process. */
1024 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1030 e
->ref
= p
->ref
->next
;
1031 p
->ref
->next
= NULL
;
1032 gfc_replace_expr (p
, e
);
1036 /* Pull an array section out of an array constructor. */
1039 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1045 long unsigned one
= 1;
1047 mpz_t start
[GFC_MAX_DIMENSIONS
];
1048 mpz_t end
[GFC_MAX_DIMENSIONS
];
1049 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1050 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1051 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1057 gfc_constructor
*cons
;
1058 gfc_constructor
*base
;
1064 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1069 base
= expr
->value
.constructor
;
1070 expr
->value
.constructor
= NULL
;
1072 rank
= ref
->u
.ar
.as
->rank
;
1074 if (expr
->shape
== NULL
)
1075 expr
->shape
= gfc_get_shape (rank
);
1077 mpz_init_set_ui (delta_mpz
, one
);
1078 mpz_init_set_ui (nelts
, one
);
1081 /* Do the initialization now, so that we can cleanup without
1082 keeping track of where we were. */
1083 for (d
= 0; d
< rank
; d
++)
1085 mpz_init (delta
[d
]);
1086 mpz_init (start
[d
]);
1089 mpz_init (stride
[d
]);
1093 /* Build the counters to clock through the array reference. */
1095 for (d
= 0; d
< rank
; d
++)
1097 /* Make this stretch of code easier on the eye! */
1098 begin
= ref
->u
.ar
.start
[d
];
1099 finish
= ref
->u
.ar
.end
[d
];
1100 step
= ref
->u
.ar
.stride
[d
];
1101 lower
= ref
->u
.ar
.as
->lower
[d
];
1102 upper
= ref
->u
.ar
.as
->upper
[d
];
1104 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1108 if (begin
->expr_type
!= EXPR_ARRAY
)
1114 gcc_assert (begin
->rank
== 1);
1115 gcc_assert (begin
->shape
);
1117 vecsub
[d
] = begin
->value
.constructor
;
1118 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1119 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1120 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1123 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1125 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1126 || mpz_cmp (c
->expr
->value
.integer
,
1127 lower
->value
.integer
) < 0)
1129 gfc_error ("index in dimension %d is out of bounds "
1130 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1138 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1139 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1140 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1146 /* Obtain the stride. */
1148 mpz_set (stride
[d
], step
->value
.integer
);
1150 mpz_set_ui (stride
[d
], one
);
1152 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1153 mpz_set_ui (stride
[d
], one
);
1155 /* Obtain the start value for the index. */
1157 mpz_set (start
[d
], begin
->value
.integer
);
1159 mpz_set (start
[d
], lower
->value
.integer
);
1161 mpz_set (ctr
[d
], start
[d
]);
1163 /* Obtain the end value for the index. */
1165 mpz_set (end
[d
], finish
->value
.integer
);
1167 mpz_set (end
[d
], upper
->value
.integer
);
1169 /* Separate 'if' because elements sometimes arrive with
1171 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1172 mpz_set (end
[d
], begin
->value
.integer
);
1174 /* Check the bounds. */
1175 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1176 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1177 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1178 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1180 gfc_error ("index in dimension %d is out of bounds "
1181 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1186 /* Calculate the number of elements and the shape. */
1187 mpz_set (tmp_mpz
, stride
[d
]);
1188 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1189 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1190 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1191 mpz_mul (nelts
, nelts
, tmp_mpz
);
1193 /* An element reference reduces the rank of the expression; don't
1194 add anything to the shape array. */
1195 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1196 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1199 /* Calculate the 'stride' (=delta) for conversion of the
1200 counter values into the index along the constructor. */
1201 mpz_set (delta
[d
], delta_mpz
);
1202 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1203 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1204 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1211 /* Now clock through the array reference, calculating the index in
1212 the source constructor and transferring the elements to the new
1214 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1216 if (ref
->u
.ar
.offset
)
1217 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1219 mpz_init_set_ui (ptr
, 0);
1222 for (d
= 0; d
< rank
; d
++)
1224 mpz_set (tmp_mpz
, ctr
[d
]);
1225 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1226 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1227 mpz_add (ptr
, ptr
, tmp_mpz
);
1229 if (!incr_ctr
) continue;
1231 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1233 gcc_assert(vecsub
[d
]);
1235 if (!vecsub
[d
]->next
)
1236 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1239 vecsub
[d
] = vecsub
[d
]->next
;
1242 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1246 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1248 if (mpz_cmp_ui (stride
[d
], 0) > 0
1249 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1250 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1251 mpz_set (ctr
[d
], start
[d
]);
1257 /* There must be a better way of dealing with negative strides
1258 than resetting the index and the constructor pointer! */
1259 if (mpz_cmp (ptr
, index
) < 0)
1261 mpz_set_ui (index
, 0);
1265 while (mpz_cmp (ptr
, index
) > 0)
1267 mpz_add_ui (index
, index
, one
);
1271 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1279 mpz_clear (delta_mpz
);
1280 mpz_clear (tmp_mpz
);
1282 for (d
= 0; d
< rank
; d
++)
1284 mpz_clear (delta
[d
]);
1285 mpz_clear (start
[d
]);
1288 mpz_clear (stride
[d
]);
1290 gfc_free_constructor (base
);
1294 /* Pull a substring out of an expression. */
1297 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1303 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1304 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1307 *newp
= gfc_copy_expr (p
);
1308 chr
= p
->value
.character
.string
;
1309 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1310 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1312 (*newp
)->value
.character
.length
= end
- start
+ 1;
1313 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1314 (*newp
)->value
.character
.length
);
1320 /* Simplify a subobject reference of a constructor. This occurs when
1321 parameter variable values are substituted. */
1324 simplify_const_ref (gfc_expr
*p
)
1326 gfc_constructor
*cons
;
1331 switch (p
->ref
->type
)
1334 switch (p
->ref
->u
.ar
.type
)
1337 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1344 remove_subobject_ref (p
, cons
);
1348 if (find_array_section (p
, p
->ref
) == FAILURE
)
1350 p
->ref
->u
.ar
.type
= AR_FULL
;
1355 if (p
->ref
->next
!= NULL
1356 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1358 cons
= p
->value
.constructor
;
1359 for (; cons
; cons
= cons
->next
)
1361 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1362 simplify_const_ref (cons
->expr
);
1365 gfc_free_ref_list (p
->ref
);
1376 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1377 remove_subobject_ref (p
, cons
);
1381 if (find_substring_ref (p
, &newp
) == FAILURE
)
1384 gfc_replace_expr (p
, newp
);
1385 gfc_free_ref_list (p
->ref
);
1395 /* Simplify a chain of references. */
1398 simplify_ref_chain (gfc_ref
*ref
, int type
)
1402 for (; ref
; ref
= ref
->next
)
1407 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1409 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1411 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1413 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1419 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1421 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1433 /* Try to substitute the value of a parameter variable. */
1436 simplify_parameter_variable (gfc_expr
*p
, int type
)
1441 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1447 /* Do not copy subobject refs for constant. */
1448 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1449 e
->ref
= copy_ref (p
->ref
);
1450 t
= gfc_simplify_expr (e
, type
);
1452 /* Only use the simplification if it eliminated all subobject references. */
1453 if (t
== SUCCESS
&& !e
->ref
)
1454 gfc_replace_expr (p
, e
);
1461 /* Given an expression, simplify it by collapsing constant
1462 expressions. Most simplification takes place when the expression
1463 tree is being constructed. If an intrinsic function is simplified
1464 at some point, we get called again to collapse the result against
1467 We work by recursively simplifying expression nodes, simplifying
1468 intrinsic functions where possible, which can lead to further
1469 constant collapsing. If an operator has constant operand(s), we
1470 rip the expression apart, and rebuild it, hoping that it becomes
1473 The expression type is defined for:
1474 0 Basic expression parsing
1475 1 Simplifying array constructors -- will substitute
1477 Returns FAILURE on error, SUCCESS otherwise.
1478 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1481 gfc_simplify_expr (gfc_expr
*p
, int type
)
1483 gfc_actual_arglist
*ap
;
1488 switch (p
->expr_type
)
1495 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1496 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1499 if (p
->value
.function
.isym
!= NULL
1500 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1505 case EXPR_SUBSTRING
:
1506 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1509 if (gfc_is_constant_expr (p
))
1514 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1515 start
--; /* Convert from one-based to zero-based. */
1516 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1517 s
= gfc_getmem (end
- start
+ 2);
1518 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1519 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1520 gfc_free (p
->value
.character
.string
);
1521 p
->value
.character
.string
= s
;
1522 p
->value
.character
.length
= end
- start
;
1523 p
->ts
.cl
= gfc_get_charlen ();
1524 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1525 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1526 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1527 gfc_free_ref_list (p
->ref
);
1529 p
->expr_type
= EXPR_CONSTANT
;
1534 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1539 /* Only substitute array parameter variables if we are in an
1540 initialization expression, or we want a subsection. */
1541 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1542 && (gfc_init_expr
|| p
->ref
1543 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1545 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1552 gfc_simplify_iterator_var (p
);
1555 /* Simplify subcomponent references. */
1556 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1561 case EXPR_STRUCTURE
:
1563 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1566 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1569 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1570 && p
->ref
->u
.ar
.type
== AR_FULL
)
1571 gfc_expand_constructor (p
);
1573 if (simplify_const_ref (p
) == FAILURE
)
1583 /* Returns the type of an expression with the exception that iterator
1584 variables are automatically integers no matter what else they may
1590 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1597 /* Check an intrinsic arithmetic operation to see if it is consistent
1598 with some type of expression. */
1600 static try check_init_expr (gfc_expr
*);
1603 /* Scalarize an expression for an elemental intrinsic call. */
1606 scalarize_intrinsic_call (gfc_expr
*e
)
1608 gfc_actual_arglist
*a
, *b
;
1609 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1610 gfc_expr
*expr
, *old
;
1613 old
= gfc_copy_expr (e
);
1615 /* Assume that the old expression carries the type information and
1616 that the first arg carries all the shape information. */
1617 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1618 gfc_free_constructor (expr
->value
.constructor
);
1619 expr
->value
.constructor
= NULL
;
1622 expr
->expr_type
= EXPR_ARRAY
;
1624 /* Copy the array argument constructors into an array, with nulls
1627 a
= old
->value
.function
.actual
;
1628 for (; a
; a
= a
->next
)
1630 /* Check that this is OK for an initialization expression. */
1631 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1635 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1637 rank
[n
] = a
->expr
->rank
;
1638 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1639 args
[n
] = gfc_copy_constructor (ctor
);
1641 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1644 rank
[n
] = a
->expr
->rank
;
1647 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1654 for (i
= 1; i
< n
; i
++)
1655 if (rank
[i
] && rank
[i
] != rank
[0])
1658 /* Using the first argument as the master, step through the array
1659 calling the function for each element and advancing the array
1660 constructors together. */
1663 for (; ctor
; ctor
= ctor
->next
)
1665 if (expr
->value
.constructor
== NULL
)
1666 expr
->value
.constructor
1667 = new_ctor
= gfc_get_constructor ();
1670 new_ctor
->next
= gfc_get_constructor ();
1671 new_ctor
= new_ctor
->next
;
1673 new_ctor
->expr
= gfc_copy_expr (old
);
1674 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1676 b
= old
->value
.function
.actual
;
1677 for (i
= 0; i
< n
; i
++)
1680 new_ctor
->expr
->value
.function
.actual
1681 = a
= gfc_get_actual_arglist ();
1684 a
->next
= gfc_get_actual_arglist ();
1688 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1690 a
->expr
= gfc_copy_expr (b
->expr
);
1695 /* Simplify the function calls. */
1696 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1699 for (i
= 0; i
< n
; i
++)
1701 args
[i
] = args
[i
]->next
;
1703 for (i
= 1; i
< n
; i
++)
1704 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1705 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1711 gfc_free_expr (old
);
1715 gfc_error_now ("elemental function arguments at %C are not compliant");
1718 gfc_free_expr (expr
);
1719 gfc_free_expr (old
);
1725 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1727 gfc_expr
*op1
= e
->value
.op
.op1
;
1728 gfc_expr
*op2
= e
->value
.op
.op2
;
1730 if ((*check_function
) (op1
) == FAILURE
)
1733 switch (e
->value
.op
.operator)
1735 case INTRINSIC_UPLUS
:
1736 case INTRINSIC_UMINUS
:
1737 if (!numeric_type (et0 (op1
)))
1742 case INTRINSIC_EQ_OS
:
1744 case INTRINSIC_NE_OS
:
1746 case INTRINSIC_GT_OS
:
1748 case INTRINSIC_GE_OS
:
1750 case INTRINSIC_LT_OS
:
1752 case INTRINSIC_LE_OS
:
1753 if ((*check_function
) (op2
) == FAILURE
)
1756 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1757 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1759 gfc_error ("Numeric or CHARACTER operands are required in "
1760 "expression at %L", &e
->where
);
1765 case INTRINSIC_PLUS
:
1766 case INTRINSIC_MINUS
:
1767 case INTRINSIC_TIMES
:
1768 case INTRINSIC_DIVIDE
:
1769 case INTRINSIC_POWER
:
1770 if ((*check_function
) (op2
) == FAILURE
)
1773 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1776 if (e
->value
.op
.operator == INTRINSIC_POWER
1777 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1779 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1780 "exponent in an initialization "
1781 "expression at %L", &op2
->where
)
1788 case INTRINSIC_CONCAT
:
1789 if ((*check_function
) (op2
) == FAILURE
)
1792 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1794 gfc_error ("Concatenation operator in expression at %L "
1795 "must have two CHARACTER operands", &op1
->where
);
1799 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1801 gfc_error ("Concat operator at %L must concatenate strings of the "
1802 "same kind", &e
->where
);
1809 if (et0 (op1
) != BT_LOGICAL
)
1811 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1812 "operand", &op1
->where
);
1821 case INTRINSIC_NEQV
:
1822 if ((*check_function
) (op2
) == FAILURE
)
1825 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1827 gfc_error ("LOGICAL operands are required in expression at %L",
1834 case INTRINSIC_PARENTHESES
:
1838 gfc_error ("Only intrinsic operators can be used in expression at %L",
1846 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1853 /* Certain inquiry functions are specifically allowed to have variable
1854 arguments, which is an exception to the normal requirement that an
1855 initialization function have initialization arguments. We head off
1856 this problem here. */
1859 check_inquiry (gfc_expr
*e
, int not_restricted
)
1863 /* FIXME: This should be moved into the intrinsic definitions,
1864 to eliminate this ugly hack. */
1865 static const char * const inquiry_function
[] = {
1866 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1867 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1868 "lbound", "ubound", NULL
1873 /* An undeclared parameter will get us here (PR25018). */
1874 if (e
->symtree
== NULL
)
1877 name
= e
->symtree
->n
.sym
->name
;
1879 for (i
= 0; inquiry_function
[i
]; i
++)
1880 if (strcmp (inquiry_function
[i
], name
) == 0)
1883 if (inquiry_function
[i
] == NULL
)
1886 e
= e
->value
.function
.actual
->expr
;
1888 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1891 /* At this point we have an inquiry function with a variable argument. The
1892 type of the variable might be undefined, but we need it now, because the
1893 arguments of these functions are allowed to be undefined. */
1895 if (e
->ts
.type
== BT_UNKNOWN
)
1897 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1898 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1902 e
->ts
= e
->symtree
->n
.sym
->ts
;
1905 /* Assumed character length will not reduce to a constant expression
1906 with LEN, as required by the standard. */
1907 if (i
== 4 && not_restricted
1908 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1909 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1910 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1911 "variable '%s' in constant expression at %L",
1912 e
->symtree
->n
.sym
->name
, &e
->where
);
1918 /* Verify that an expression is an initialization expression. A side
1919 effect is that the expression tree is reduced to a single constant
1920 node if all goes well. This would normally happen when the
1921 expression is constructed but function references are assumed to be
1922 intrinsics in the context of initialization expressions. If
1923 FAILURE is returned an error message has been generated. */
1926 check_init_expr (gfc_expr
*e
)
1928 gfc_actual_arglist
*ap
;
1931 gfc_intrinsic_sym
*isym
;
1936 switch (e
->expr_type
)
1939 t
= check_intrinsic_op (e
, check_init_expr
);
1941 t
= gfc_simplify_expr (e
, 0);
1948 if (check_inquiry (e
, 1) != SUCCESS
)
1951 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1952 if (check_init_expr (ap
->expr
) == FAILURE
)
1959 /* Try to scalarize an elemental intrinsic function that has an
1961 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
1962 if (isym
&& isym
->elemental
1963 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
1965 if (scalarize_intrinsic_call (e
) == SUCCESS
)
1971 m
= gfc_intrinsic_func_interface (e
, 0);
1974 gfc_error ("Function '%s' in initialization expression at %L "
1975 "must be an intrinsic function",
1976 e
->symtree
->n
.sym
->name
, &e
->where
);
1987 if (gfc_check_iter_variable (e
) == SUCCESS
)
1990 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1992 t
= simplify_parameter_variable (e
, 0);
1996 if (gfc_in_match_data ())
1999 gfc_error ("Parameter '%s' at %L has not been declared or is "
2000 "a variable, which does not reduce to a constant "
2001 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2010 case EXPR_SUBSTRING
:
2011 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2015 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2017 t
= gfc_simplify_expr (e
, 0);
2021 case EXPR_STRUCTURE
:
2022 t
= gfc_check_constructor (e
, check_init_expr
);
2026 t
= gfc_check_constructor (e
, check_init_expr
);
2030 t
= gfc_expand_constructor (e
);
2034 t
= gfc_check_constructor_type (e
);
2038 gfc_internal_error ("check_init_expr(): Unknown expression type");
2045 /* Match an initialization expression. We work by first matching an
2046 expression, then reducing it to a constant. */
2049 gfc_match_init_expr (gfc_expr
**result
)
2055 m
= gfc_match_expr (&expr
);
2060 t
= gfc_resolve_expr (expr
);
2062 t
= check_init_expr (expr
);
2067 gfc_free_expr (expr
);
2071 if (expr
->expr_type
== EXPR_ARRAY
2072 && (gfc_check_constructor_type (expr
) == FAILURE
2073 || gfc_expand_constructor (expr
) == FAILURE
))
2075 gfc_free_expr (expr
);
2079 /* Not all inquiry functions are simplified to constant expressions
2080 so it is necessary to call check_inquiry again. */
2081 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) == FAILURE
2082 && !gfc_in_match_data ())
2084 gfc_error ("Initialization expression didn't reduce %C");
2094 static try check_restricted (gfc_expr
*);
2096 /* Given an actual argument list, test to see that each argument is a
2097 restricted expression and optionally if the expression type is
2098 integer or character. */
2101 restricted_args (gfc_actual_arglist
*a
)
2103 for (; a
; a
= a
->next
)
2105 if (check_restricted (a
->expr
) == FAILURE
)
2113 /************* Restricted/specification expressions *************/
2116 /* Make sure a non-intrinsic function is a specification function. */
2119 external_spec_function (gfc_expr
*e
)
2123 f
= e
->value
.function
.esym
;
2125 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2127 gfc_error ("Specification function '%s' at %L cannot be a statement "
2128 "function", f
->name
, &e
->where
);
2132 if (f
->attr
.proc
== PROC_INTERNAL
)
2134 gfc_error ("Specification function '%s' at %L cannot be an internal "
2135 "function", f
->name
, &e
->where
);
2139 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2141 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2146 if (f
->attr
.recursive
)
2148 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2149 f
->name
, &e
->where
);
2153 return restricted_args (e
->value
.function
.actual
);
2157 /* Check to see that a function reference to an intrinsic is a
2158 restricted expression. */
2161 restricted_intrinsic (gfc_expr
*e
)
2163 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2164 if (check_inquiry (e
, 0) == SUCCESS
)
2167 return restricted_args (e
->value
.function
.actual
);
2171 /* Verify that an expression is a restricted expression. Like its
2172 cousin check_init_expr(), an error message is generated if we
2176 check_restricted (gfc_expr
*e
)
2184 switch (e
->expr_type
)
2187 t
= check_intrinsic_op (e
, check_restricted
);
2189 t
= gfc_simplify_expr (e
, 0);
2194 t
= e
->value
.function
.esym
? external_spec_function (e
)
2195 : restricted_intrinsic (e
);
2199 sym
= e
->symtree
->n
.sym
;
2202 if (sym
->attr
.optional
)
2204 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2205 sym
->name
, &e
->where
);
2209 if (sym
->attr
.intent
== INTENT_OUT
)
2211 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2212 sym
->name
, &e
->where
);
2216 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2217 processed in resolve.c(resolve_formal_arglist). This is done so
2218 that host associated dummy array indices are accepted (PR23446).
2219 This mechanism also does the same for the specification expressions
2220 of array-valued functions. */
2221 if (sym
->attr
.in_common
2222 || sym
->attr
.use_assoc
2224 || sym
->ns
!= gfc_current_ns
2225 || (sym
->ns
->proc_name
!= NULL
2226 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2227 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2233 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2234 sym
->name
, &e
->where
);
2243 case EXPR_SUBSTRING
:
2244 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2248 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2250 t
= gfc_simplify_expr (e
, 0);
2254 case EXPR_STRUCTURE
:
2255 t
= gfc_check_constructor (e
, check_restricted
);
2259 t
= gfc_check_constructor (e
, check_restricted
);
2263 gfc_internal_error ("check_restricted(): Unknown expression type");
2270 /* Check to see that an expression is a specification expression. If
2271 we return FAILURE, an error has been generated. */
2274 gfc_specification_expr (gfc_expr
*e
)
2280 if (e
->ts
.type
!= BT_INTEGER
)
2282 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2288 gfc_error ("Expression at %L must be scalar", &e
->where
);
2292 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2295 return check_restricted (e
);
2299 /************** Expression conformance checks. *************/
2301 /* Given two expressions, make sure that the arrays are conformable. */
2304 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2306 int op1_flag
, op2_flag
, d
;
2307 mpz_t op1_size
, op2_size
;
2310 if (op1
->rank
== 0 || op2
->rank
== 0)
2313 if (op1
->rank
!= op2
->rank
)
2315 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2322 for (d
= 0; d
< op1
->rank
; d
++)
2324 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2325 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2327 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2329 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2330 _(optype_msgid
), &op1
->where
, d
+ 1,
2331 (int) mpz_get_si (op1_size
),
2332 (int) mpz_get_si (op2_size
));
2338 mpz_clear (op1_size
);
2340 mpz_clear (op2_size
);
2350 /* Given an assignable expression and an arbitrary expression, make
2351 sure that the assignment can take place. */
2354 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2360 sym
= lvalue
->symtree
->n
.sym
;
2362 /* Check INTENT(IN), unless the object itself is the component or
2363 sub-component of a pointer. */
2364 has_pointer
= sym
->attr
.pointer
;
2366 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2367 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2373 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2375 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2376 sym
->name
, &lvalue
->where
);
2380 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2381 variable local to a function subprogram. Its existence begins when
2382 execution of the function is initiated and ends when execution of the
2383 function is terminated...
2384 Therefore, the left hand side is no longer a variable, when it is: */
2385 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2386 && !sym
->attr
.external
)
2391 /* (i) Use associated; */
2392 if (sym
->attr
.use_assoc
)
2395 /* (ii) The assignment is in the main program; or */
2396 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2399 /* (iii) A module or internal procedure... */
2400 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2401 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2402 && gfc_current_ns
->parent
2403 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2404 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2405 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2407 /* ... that is not a function... */
2408 if (!gfc_current_ns
->proc_name
->attr
.function
)
2411 /* ... or is not an entry and has a different name. */
2412 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2418 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2423 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2425 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2426 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2430 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2432 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2437 if (rvalue
->expr_type
== EXPR_NULL
)
2439 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2440 && lvalue
->symtree
->n
.sym
->attr
.data
)
2444 gfc_error ("NULL appears on right-hand side in assignment at %L",
2450 if (sym
->attr
.cray_pointee
2451 && lvalue
->ref
!= NULL
2452 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2453 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2455 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2456 "is illegal", &lvalue
->where
);
2460 /* This is possibly a typo: x = f() instead of x => f(). */
2461 if (gfc_option
.warn_surprising
2462 && rvalue
->expr_type
== EXPR_FUNCTION
2463 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2464 gfc_warning ("POINTER valued function appears on right-hand side of "
2465 "assignment at %L", &rvalue
->where
);
2467 /* Check size of array assignments. */
2468 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2469 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2472 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2477 /* Numeric can be converted to any other numeric. And Hollerith can be
2478 converted to any other type. */
2479 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2480 || rvalue
->ts
.type
== BT_HOLLERITH
)
2483 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2486 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2487 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2488 gfc_typename (&lvalue
->ts
));
2493 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2497 /* Check that a pointer assignment is OK. We first check lvalue, and
2498 we only check rvalue if it's not an assignment to NULL() or a
2499 NULLIFY statement. */
2502 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2504 symbol_attribute attr
;
2507 int pointer
, check_intent_in
;
2509 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2511 gfc_error ("Pointer assignment target is not a POINTER at %L",
2516 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2517 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2519 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2520 "l-value since it is a procedure",
2521 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2526 /* Check INTENT(IN), unless the object itself is the component or
2527 sub-component of a pointer. */
2528 check_intent_in
= 1;
2529 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2531 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2534 check_intent_in
= 0;
2536 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2540 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2542 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2543 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2549 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2553 is_pure
= gfc_pure (NULL
);
2555 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2557 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2561 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2562 kind, etc for lvalue and rvalue must match, and rvalue must be a
2563 pure variable if we're in a pure function. */
2564 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2567 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2569 gfc_error ("Different types in pointer assignment at %L",
2574 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2576 gfc_error ("Different kind type parameters in pointer "
2577 "assignment at %L", &lvalue
->where
);
2581 if (lvalue
->rank
!= rvalue
->rank
)
2583 gfc_error ("Different ranks in pointer assignment at %L",
2588 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2589 if (rvalue
->expr_type
== EXPR_NULL
)
2592 if (lvalue
->ts
.type
== BT_CHARACTER
2593 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2594 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2595 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2596 rvalue
->ts
.cl
->length
)) == 1)
2598 gfc_error ("Different character lengths in pointer "
2599 "assignment at %L", &lvalue
->where
);
2603 attr
= gfc_expr_attr (rvalue
);
2604 if (!attr
.target
&& !attr
.pointer
)
2606 gfc_error ("Pointer assignment target is neither TARGET "
2607 "nor POINTER at %L", &rvalue
->where
);
2611 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2613 gfc_error ("Bad target in pointer assignment in PURE "
2614 "procedure at %L", &rvalue
->where
);
2617 if (gfc_has_vector_index (rvalue
))
2619 gfc_error ("Pointer assignment with vector subscript "
2620 "on rhs at %L", &rvalue
->where
);
2624 if (attr
.protected && attr
.use_assoc
)
2626 gfc_error ("Pointer assigment target has PROTECTED "
2627 "attribute at %L", &rvalue
->where
);
2635 /* Relative of gfc_check_assign() except that the lvalue is a single
2636 symbol. Used for initialization assignments. */
2639 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2644 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2646 lvalue
.expr_type
= EXPR_VARIABLE
;
2647 lvalue
.ts
= sym
->ts
;
2649 lvalue
.rank
= sym
->as
->rank
;
2650 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2651 lvalue
.symtree
->n
.sym
= sym
;
2652 lvalue
.where
= sym
->declared_at
;
2654 if (sym
->attr
.pointer
)
2655 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2657 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2659 gfc_free (lvalue
.symtree
);
2665 /* Get an expression for a default initializer. */
2668 gfc_default_initializer (gfc_typespec
*ts
)
2670 gfc_constructor
*tail
;
2676 /* See if we have a default initializer. */
2677 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2679 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2680 init
= gfc_get_expr ();
2686 /* Build the constructor. */
2687 init
->expr_type
= EXPR_STRUCTURE
;
2689 init
->where
= ts
->derived
->declared_at
;
2691 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2694 init
->value
.constructor
= tail
= gfc_get_constructor ();
2697 tail
->next
= gfc_get_constructor ();
2702 tail
->expr
= gfc_copy_expr (c
->initializer
);
2706 tail
->expr
= gfc_get_expr ();
2707 tail
->expr
->expr_type
= EXPR_NULL
;
2708 tail
->expr
->ts
= c
->ts
;
2715 /* Given a symbol, create an expression node with that symbol as a
2716 variable. If the symbol is array valued, setup a reference of the
2720 gfc_get_variable_expr (gfc_symtree
*var
)
2724 e
= gfc_get_expr ();
2725 e
->expr_type
= EXPR_VARIABLE
;
2727 e
->ts
= var
->n
.sym
->ts
;
2729 if (var
->n
.sym
->as
!= NULL
)
2731 e
->rank
= var
->n
.sym
->as
->rank
;
2732 e
->ref
= gfc_get_ref ();
2733 e
->ref
->type
= REF_ARRAY
;
2734 e
->ref
->u
.ar
.type
= AR_FULL
;
2741 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2744 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2746 gfc_actual_arglist
*arg
;
2753 switch (expr
->expr_type
)
2756 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2757 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2761 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2762 gfc_expr_set_symbols_referenced (arg
->expr
);
2766 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2771 case EXPR_SUBSTRING
:
2774 case EXPR_STRUCTURE
:
2776 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2777 gfc_expr_set_symbols_referenced (c
->expr
);
2785 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2789 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2791 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2792 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2793 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2801 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2802 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);