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 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
459 break; /* Already done */
463 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
470 switch (q
->value
.op
.operator)
473 case INTRINSIC_PARENTHESES
:
474 case INTRINSIC_UPLUS
:
475 case INTRINSIC_UMINUS
:
476 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
479 default: /* Binary operators. */
480 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
481 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
488 q
->value
.function
.actual
=
489 gfc_copy_actual_arglist (p
->value
.function
.actual
);
494 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
502 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
504 q
->ref
= copy_ref (p
->ref
);
510 /* Return the maximum kind of two expressions. In general, higher
511 kind numbers mean more precision for numeric types. */
514 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
516 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
520 /* Returns nonzero if the type is numeric, zero otherwise. */
523 numeric_type (bt type
)
525 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
529 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
532 gfc_numeric_ts (gfc_typespec
*ts
)
534 return numeric_type (ts
->type
);
538 /* Returns an expression node that is an integer constant. */
547 p
->expr_type
= EXPR_CONSTANT
;
548 p
->ts
.type
= BT_INTEGER
;
549 p
->ts
.kind
= gfc_default_integer_kind
;
551 p
->where
= gfc_current_locus
;
552 mpz_init_set_si (p
->value
.integer
, i
);
558 /* Returns an expression node that is a logical constant. */
561 gfc_logical_expr (int i
, locus
*where
)
567 p
->expr_type
= EXPR_CONSTANT
;
568 p
->ts
.type
= BT_LOGICAL
;
569 p
->ts
.kind
= gfc_default_logical_kind
;
572 where
= &gfc_current_locus
;
574 p
->value
.logical
= i
;
580 /* Return an expression node with an optional argument list attached.
581 A variable number of gfc_expr pointers are strung together in an
582 argument list with a NULL pointer terminating the list. */
585 gfc_build_conversion (gfc_expr
*e
)
590 p
->expr_type
= EXPR_FUNCTION
;
592 p
->value
.function
.actual
= NULL
;
594 p
->value
.function
.actual
= gfc_get_actual_arglist ();
595 p
->value
.function
.actual
->expr
= e
;
601 /* Given an expression node with some sort of numeric binary
602 expression, insert type conversions required to make the operands
605 The exception is that the operands of an exponential don't have to
606 have the same type. If possible, the base is promoted to the type
607 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
608 1.0**2 stays as it is. */
611 gfc_type_convert_binary (gfc_expr
*e
)
615 op1
= e
->value
.op
.op1
;
616 op2
= e
->value
.op
.op2
;
618 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
620 gfc_clear_ts (&e
->ts
);
624 /* Kind conversions of same type. */
625 if (op1
->ts
.type
== op2
->ts
.type
)
627 if (op1
->ts
.kind
== op2
->ts
.kind
)
629 /* No type conversions. */
634 if (op1
->ts
.kind
> op2
->ts
.kind
)
635 gfc_convert_type (op2
, &op1
->ts
, 2);
637 gfc_convert_type (op1
, &op2
->ts
, 2);
643 /* Integer combined with real or complex. */
644 if (op2
->ts
.type
== BT_INTEGER
)
648 /* Special case for ** operator. */
649 if (e
->value
.op
.operator == INTRINSIC_POWER
)
652 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
656 if (op1
->ts
.type
== BT_INTEGER
)
659 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
663 /* Real combined with complex. */
664 e
->ts
.type
= BT_COMPLEX
;
665 if (op1
->ts
.kind
> op2
->ts
.kind
)
666 e
->ts
.kind
= op1
->ts
.kind
;
668 e
->ts
.kind
= op2
->ts
.kind
;
669 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
670 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
671 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
672 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
679 /* Function to determine if an expression is constant or not. This
680 function expects that the expression has already been simplified. */
683 gfc_is_constant_expr (gfc_expr
*e
)
686 gfc_actual_arglist
*arg
;
692 switch (e
->expr_type
)
695 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
696 && (e
->value
.op
.op2
== NULL
697 || gfc_is_constant_expr (e
->value
.op
.op2
)));
705 /* Call to intrinsic with at least one argument. */
707 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
709 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
711 if (!gfc_is_constant_expr (arg
->expr
))
725 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
726 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
731 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
732 if (!gfc_is_constant_expr (c
->expr
))
740 rv
= gfc_constant_ac (e
);
744 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
751 /* Try to collapse intrinsic expressions. */
754 simplify_intrinsic_op (gfc_expr
*p
, int type
)
756 gfc_expr
*op1
, *op2
, *result
;
758 if (p
->value
.op
.operator == INTRINSIC_USER
)
761 op1
= p
->value
.op
.op1
;
762 op2
= p
->value
.op
.op2
;
764 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
766 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
769 if (!gfc_is_constant_expr (op1
)
770 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
774 p
->value
.op
.op1
= NULL
;
775 p
->value
.op
.op2
= NULL
;
777 switch (p
->value
.op
.operator)
779 case INTRINSIC_PARENTHESES
:
780 result
= gfc_parentheses (op1
);
783 case INTRINSIC_UPLUS
:
784 result
= gfc_uplus (op1
);
787 case INTRINSIC_UMINUS
:
788 result
= gfc_uminus (op1
);
792 result
= gfc_add (op1
, op2
);
795 case INTRINSIC_MINUS
:
796 result
= gfc_subtract (op1
, op2
);
799 case INTRINSIC_TIMES
:
800 result
= gfc_multiply (op1
, op2
);
803 case INTRINSIC_DIVIDE
:
804 result
= gfc_divide (op1
, op2
);
807 case INTRINSIC_POWER
:
808 result
= gfc_power (op1
, op2
);
811 case INTRINSIC_CONCAT
:
812 result
= gfc_concat (op1
, op2
);
816 result
= gfc_eq (op1
, op2
);
820 result
= gfc_ne (op1
, op2
);
824 result
= gfc_gt (op1
, op2
);
828 result
= gfc_ge (op1
, op2
);
832 result
= gfc_lt (op1
, op2
);
836 result
= gfc_le (op1
, op2
);
840 result
= gfc_not (op1
);
844 result
= gfc_and (op1
, op2
);
848 result
= gfc_or (op1
, op2
);
852 result
= gfc_eqv (op1
, op2
);
856 result
= gfc_neqv (op1
, op2
);
860 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
870 result
->rank
= p
->rank
;
871 result
->where
= p
->where
;
872 gfc_replace_expr (p
, result
);
878 /* Subroutine to simplify constructor expressions. Mutually recursive
879 with gfc_simplify_expr(). */
882 simplify_constructor (gfc_constructor
*c
, int type
)
884 for (; c
; c
= c
->next
)
887 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
888 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
889 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
892 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
900 /* Pull a single array element out of an array constructor. */
903 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
904 gfc_constructor
**rval
)
906 unsigned long nelemen
;
918 mpz_init_set_ui (offset
, 0);
921 mpz_init_set_ui (span
, 1);
922 for (i
= 0; i
< ar
->dimen
; i
++)
924 e
= gfc_copy_expr (ar
->start
[i
]);
925 if (e
->expr_type
!= EXPR_CONSTANT
)
931 /* Check the bounds. */
933 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
934 || mpz_cmp (e
->value
.integer
,
935 ar
->as
->lower
[i
]->value
.integer
) < 0))
937 gfc_error ("index in dimension %d is out of bounds "
938 "at %L", i
+ 1, &ar
->c_where
[i
]);
944 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
945 mpz_mul (delta
, delta
, span
);
946 mpz_add (offset
, offset
, delta
);
949 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
950 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
951 mpz_mul (span
, span
, tmp
);
956 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
979 /* Find a component of a structure constructor. */
981 static gfc_constructor
*
982 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
987 comp
= ref
->u
.c
.sym
->components
;
988 pick
= ref
->u
.c
.component
;
999 /* Replace an expression with the contents of a constructor, removing
1000 the subobject reference in the process. */
1003 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1009 e
->ref
= p
->ref
->next
;
1010 p
->ref
->next
= NULL
;
1011 gfc_replace_expr (p
, e
);
1015 /* Pull an array section out of an array constructor. */
1018 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1024 long unsigned one
= 1;
1026 mpz_t start
[GFC_MAX_DIMENSIONS
];
1027 mpz_t end
[GFC_MAX_DIMENSIONS
];
1028 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1029 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1030 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1036 gfc_constructor
*cons
;
1037 gfc_constructor
*base
;
1043 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1048 base
= expr
->value
.constructor
;
1049 expr
->value
.constructor
= NULL
;
1051 rank
= ref
->u
.ar
.as
->rank
;
1053 if (expr
->shape
== NULL
)
1054 expr
->shape
= gfc_get_shape (rank
);
1056 mpz_init_set_ui (delta_mpz
, one
);
1057 mpz_init_set_ui (nelts
, one
);
1060 /* Do the initialization now, so that we can cleanup without
1061 keeping track of where we were. */
1062 for (d
= 0; d
< rank
; d
++)
1064 mpz_init (delta
[d
]);
1065 mpz_init (start
[d
]);
1068 mpz_init (stride
[d
]);
1072 /* Build the counters to clock through the array reference. */
1074 for (d
= 0; d
< rank
; d
++)
1076 /* Make this stretch of code easier on the eye! */
1077 begin
= ref
->u
.ar
.start
[d
];
1078 finish
= ref
->u
.ar
.end
[d
];
1079 step
= ref
->u
.ar
.stride
[d
];
1080 lower
= ref
->u
.ar
.as
->lower
[d
];
1081 upper
= ref
->u
.ar
.as
->upper
[d
];
1083 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1087 if (begin
->expr_type
!= EXPR_ARRAY
)
1093 gcc_assert (begin
->rank
== 1);
1094 gcc_assert (begin
->shape
);
1096 vecsub
[d
] = begin
->value
.constructor
;
1097 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1098 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1099 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1102 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1104 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1105 || mpz_cmp (c
->expr
->value
.integer
,
1106 lower
->value
.integer
) < 0)
1108 gfc_error ("index in dimension %d is out of bounds "
1109 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1117 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1118 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1119 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1125 /* Obtain the stride. */
1127 mpz_set (stride
[d
], step
->value
.integer
);
1129 mpz_set_ui (stride
[d
], one
);
1131 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1132 mpz_set_ui (stride
[d
], one
);
1134 /* Obtain the start value for the index. */
1136 mpz_set (start
[d
], begin
->value
.integer
);
1138 mpz_set (start
[d
], lower
->value
.integer
);
1140 mpz_set (ctr
[d
], start
[d
]);
1142 /* Obtain the end value for the index. */
1144 mpz_set (end
[d
], finish
->value
.integer
);
1146 mpz_set (end
[d
], upper
->value
.integer
);
1148 /* Separate 'if' because elements sometimes arrive with
1150 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1151 mpz_set (end
[d
], begin
->value
.integer
);
1153 /* Check the bounds. */
1154 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1155 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1156 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1157 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1159 gfc_error ("index in dimension %d is out of bounds "
1160 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1165 /* Calculate the number of elements and the shape. */
1166 mpz_set (tmp_mpz
, stride
[d
]);
1167 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1168 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1169 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1170 mpz_mul (nelts
, nelts
, tmp_mpz
);
1172 /* An element reference reduces the rank of the expression; don't
1173 add anything to the shape array. */
1174 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1175 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1178 /* Calculate the 'stride' (=delta) for conversion of the
1179 counter values into the index along the constructor. */
1180 mpz_set (delta
[d
], delta_mpz
);
1181 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1182 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1183 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1190 /* Now clock through the array reference, calculating the index in
1191 the source constructor and transferring the elements to the new
1193 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1195 if (ref
->u
.ar
.offset
)
1196 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1198 mpz_init_set_ui (ptr
, 0);
1201 for (d
= 0; d
< rank
; d
++)
1203 mpz_set (tmp_mpz
, ctr
[d
]);
1204 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1205 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1206 mpz_add (ptr
, ptr
, tmp_mpz
);
1208 if (!incr_ctr
) continue;
1210 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1212 gcc_assert(vecsub
[d
]);
1214 if (!vecsub
[d
]->next
)
1215 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1218 vecsub
[d
] = vecsub
[d
]->next
;
1221 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1225 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1227 if (mpz_cmp_ui (stride
[d
], 0) > 0
1228 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1229 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1230 mpz_set (ctr
[d
], start
[d
]);
1236 /* There must be a better way of dealing with negative strides
1237 than resetting the index and the constructor pointer! */
1238 if (mpz_cmp (ptr
, index
) < 0)
1240 mpz_set_ui (index
, 0);
1244 while (mpz_cmp (ptr
, index
) > 0)
1246 mpz_add_ui (index
, index
, one
);
1250 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1258 mpz_clear (delta_mpz
);
1259 mpz_clear (tmp_mpz
);
1261 for (d
= 0; d
< rank
; d
++)
1263 mpz_clear (delta
[d
]);
1264 mpz_clear (start
[d
]);
1267 mpz_clear (stride
[d
]);
1269 gfc_free_constructor (base
);
1273 /* Pull a substring out of an expression. */
1276 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1282 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1283 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1286 *newp
= gfc_copy_expr (p
);
1287 chr
= p
->value
.character
.string
;
1288 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1289 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1291 (*newp
)->value
.character
.length
= end
- start
+ 1;
1292 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1293 (*newp
)->value
.character
.length
);
1299 /* Simplify a subobject reference of a constructor. This occurs when
1300 parameter variable values are substituted. */
1303 simplify_const_ref (gfc_expr
*p
)
1305 gfc_constructor
*cons
;
1310 switch (p
->ref
->type
)
1313 switch (p
->ref
->u
.ar
.type
)
1316 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1323 remove_subobject_ref (p
, cons
);
1327 if (find_array_section (p
, p
->ref
) == FAILURE
)
1329 p
->ref
->u
.ar
.type
= AR_FULL
;
1334 if (p
->ref
->next
!= NULL
1335 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1337 cons
= p
->value
.constructor
;
1338 for (; cons
; cons
= cons
->next
)
1340 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1341 simplify_const_ref (cons
->expr
);
1344 gfc_free_ref_list (p
->ref
);
1355 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1356 remove_subobject_ref (p
, cons
);
1360 if (find_substring_ref (p
, &newp
) == FAILURE
)
1363 gfc_replace_expr (p
, newp
);
1364 gfc_free_ref_list (p
->ref
);
1374 /* Simplify a chain of references. */
1377 simplify_ref_chain (gfc_ref
*ref
, int type
)
1381 for (; ref
; ref
= ref
->next
)
1386 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1388 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1390 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1392 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1398 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1400 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1412 /* Try to substitute the value of a parameter variable. */
1415 simplify_parameter_variable (gfc_expr
*p
, int type
)
1420 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1426 /* Do not copy subobject refs for constant. */
1427 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1428 e
->ref
= copy_ref (p
->ref
);
1429 t
= gfc_simplify_expr (e
, type
);
1431 /* Only use the simplification if it eliminated all subobject references. */
1432 if (t
== SUCCESS
&& !e
->ref
)
1433 gfc_replace_expr (p
, e
);
1440 /* Given an expression, simplify it by collapsing constant
1441 expressions. Most simplification takes place when the expression
1442 tree is being constructed. If an intrinsic function is simplified
1443 at some point, we get called again to collapse the result against
1446 We work by recursively simplifying expression nodes, simplifying
1447 intrinsic functions where possible, which can lead to further
1448 constant collapsing. If an operator has constant operand(s), we
1449 rip the expression apart, and rebuild it, hoping that it becomes
1452 The expression type is defined for:
1453 0 Basic expression parsing
1454 1 Simplifying array constructors -- will substitute
1456 Returns FAILURE on error, SUCCESS otherwise.
1457 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1460 gfc_simplify_expr (gfc_expr
*p
, int type
)
1462 gfc_actual_arglist
*ap
;
1467 switch (p
->expr_type
)
1474 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1475 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1478 if (p
->value
.function
.isym
!= NULL
1479 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1484 case EXPR_SUBSTRING
:
1485 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1488 if (gfc_is_constant_expr (p
))
1493 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1494 start
--; /* Convert from one-based to zero-based. */
1495 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1496 s
= gfc_getmem (end
- start
+ 2);
1497 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1498 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1499 gfc_free (p
->value
.character
.string
);
1500 p
->value
.character
.string
= s
;
1501 p
->value
.character
.length
= end
- start
;
1502 p
->ts
.cl
= gfc_get_charlen ();
1503 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1504 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1505 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1506 gfc_free_ref_list (p
->ref
);
1508 p
->expr_type
= EXPR_CONSTANT
;
1513 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1518 /* Only substitute array parameter variables if we are in an
1519 initialization expression, or we want a subsection. */
1520 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1521 && (gfc_init_expr
|| p
->ref
1522 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1524 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1531 gfc_simplify_iterator_var (p
);
1534 /* Simplify subcomponent references. */
1535 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1540 case EXPR_STRUCTURE
:
1542 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1545 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1548 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1549 && p
->ref
->u
.ar
.type
== AR_FULL
)
1550 gfc_expand_constructor (p
);
1552 if (simplify_const_ref (p
) == FAILURE
)
1562 /* Returns the type of an expression with the exception that iterator
1563 variables are automatically integers no matter what else they may
1569 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1576 /* Check an intrinsic arithmetic operation to see if it is consistent
1577 with some type of expression. */
1579 static try check_init_expr (gfc_expr
*);
1582 /* Scalarize an expression for an elemental intrinsic call. */
1585 scalarize_intrinsic_call (gfc_expr
*e
)
1587 gfc_actual_arglist
*a
, *b
;
1588 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1589 gfc_expr
*expr
, *old
;
1592 old
= gfc_copy_expr (e
);
1594 /* Assume that the old expression carries the type information and
1595 that the first arg carries all the shape information. */
1596 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1597 gfc_free_constructor (expr
->value
.constructor
);
1598 expr
->value
.constructor
= NULL
;
1601 expr
->expr_type
= EXPR_ARRAY
;
1603 /* Copy the array argument constructors into an array, with nulls
1606 a
= old
->value
.function
.actual
;
1607 for (; a
; a
= a
->next
)
1609 /* Check that this is OK for an initialization expression. */
1610 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1614 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1616 rank
[n
] = a
->expr
->rank
;
1617 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1618 args
[n
] = gfc_copy_constructor (ctor
);
1620 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1623 rank
[n
] = a
->expr
->rank
;
1626 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1633 for (i
= 1; i
< n
; i
++)
1634 if (rank
[i
] && rank
[i
] != rank
[0])
1637 /* Using the first argument as the master, step through the array
1638 calling the function for each element and advancing the array
1639 constructors together. */
1642 for (; ctor
; ctor
= ctor
->next
)
1644 if (expr
->value
.constructor
== NULL
)
1645 expr
->value
.constructor
1646 = new_ctor
= gfc_get_constructor ();
1649 new_ctor
->next
= gfc_get_constructor ();
1650 new_ctor
= new_ctor
->next
;
1652 new_ctor
->expr
= gfc_copy_expr (old
);
1653 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1655 b
= old
->value
.function
.actual
;
1656 for (i
= 0; i
< n
; i
++)
1659 new_ctor
->expr
->value
.function
.actual
1660 = a
= gfc_get_actual_arglist ();
1663 a
->next
= gfc_get_actual_arglist ();
1667 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1669 a
->expr
= gfc_copy_expr (b
->expr
);
1674 /* Simplify the function calls. */
1675 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1678 for (i
= 0; i
< n
; i
++)
1680 args
[i
] = args
[i
]->next
;
1682 for (i
= 1; i
< n
; i
++)
1683 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1684 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1690 gfc_free_expr (old
);
1694 gfc_error_now ("elemental function arguments at %C are not compliant");
1697 gfc_free_expr (expr
);
1698 gfc_free_expr (old
);
1704 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1706 gfc_expr
*op1
= e
->value
.op
.op1
;
1707 gfc_expr
*op2
= e
->value
.op
.op2
;
1709 if ((*check_function
) (op1
) == FAILURE
)
1712 switch (e
->value
.op
.operator)
1714 case INTRINSIC_UPLUS
:
1715 case INTRINSIC_UMINUS
:
1716 if (!numeric_type (et0 (op1
)))
1726 if ((*check_function
) (op2
) == FAILURE
)
1729 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1730 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1732 gfc_error ("Numeric or CHARACTER operands are required in "
1733 "expression at %L", &e
->where
);
1738 case INTRINSIC_PLUS
:
1739 case INTRINSIC_MINUS
:
1740 case INTRINSIC_TIMES
:
1741 case INTRINSIC_DIVIDE
:
1742 case INTRINSIC_POWER
:
1743 if ((*check_function
) (op2
) == FAILURE
)
1746 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1749 if (e
->value
.op
.operator == INTRINSIC_POWER
1750 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1752 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1753 "exponent in an initialization "
1754 "expression at %L", &op2
->where
)
1761 case INTRINSIC_CONCAT
:
1762 if ((*check_function
) (op2
) == FAILURE
)
1765 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1767 gfc_error ("Concatenation operator in expression at %L "
1768 "must have two CHARACTER operands", &op1
->where
);
1772 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1774 gfc_error ("Concat operator at %L must concatenate strings of the "
1775 "same kind", &e
->where
);
1782 if (et0 (op1
) != BT_LOGICAL
)
1784 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1785 "operand", &op1
->where
);
1794 case INTRINSIC_NEQV
:
1795 if ((*check_function
) (op2
) == FAILURE
)
1798 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1800 gfc_error ("LOGICAL operands are required in expression at %L",
1807 case INTRINSIC_PARENTHESES
:
1811 gfc_error ("Only intrinsic operators can be used in expression at %L",
1819 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1826 /* Certain inquiry functions are specifically allowed to have variable
1827 arguments, which is an exception to the normal requirement that an
1828 initialization function have initialization arguments. We head off
1829 this problem here. */
1832 check_inquiry (gfc_expr
*e
, int not_restricted
)
1836 /* FIXME: This should be moved into the intrinsic definitions,
1837 to eliminate this ugly hack. */
1838 static const char * const inquiry_function
[] = {
1839 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1840 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1841 "lbound", "ubound", NULL
1846 /* An undeclared parameter will get us here (PR25018). */
1847 if (e
->symtree
== NULL
)
1850 name
= e
->symtree
->n
.sym
->name
;
1852 for (i
= 0; inquiry_function
[i
]; i
++)
1853 if (strcmp (inquiry_function
[i
], name
) == 0)
1856 if (inquiry_function
[i
] == NULL
)
1859 e
= e
->value
.function
.actual
->expr
;
1861 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1864 /* At this point we have an inquiry function with a variable argument. The
1865 type of the variable might be undefined, but we need it now, because the
1866 arguments of these functions are allowed to be undefined. */
1868 if (e
->ts
.type
== BT_UNKNOWN
)
1870 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1871 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1875 e
->ts
= e
->symtree
->n
.sym
->ts
;
1878 /* Assumed character length will not reduce to a constant expression
1879 with LEN, as required by the standard. */
1880 if (i
== 4 && not_restricted
1881 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1882 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1883 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1884 "variable '%s' in constant expression at %L",
1885 e
->symtree
->n
.sym
->name
, &e
->where
);
1891 /* Verify that an expression is an initialization expression. A side
1892 effect is that the expression tree is reduced to a single constant
1893 node if all goes well. This would normally happen when the
1894 expression is constructed but function references are assumed to be
1895 intrinsics in the context of initialization expressions. If
1896 FAILURE is returned an error message has been generated. */
1899 check_init_expr (gfc_expr
*e
)
1901 gfc_actual_arglist
*ap
;
1904 gfc_intrinsic_sym
*isym
;
1909 switch (e
->expr_type
)
1912 t
= check_intrinsic_op (e
, check_init_expr
);
1914 t
= gfc_simplify_expr (e
, 0);
1921 if (check_inquiry (e
, 1) != SUCCESS
)
1924 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1925 if (check_init_expr (ap
->expr
) == FAILURE
)
1932 /* Try to scalarize an elemental intrinsic function that has an
1934 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
1935 if (isym
&& isym
->elemental
1936 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
1938 if (scalarize_intrinsic_call (e
) == SUCCESS
)
1944 m
= gfc_intrinsic_func_interface (e
, 0);
1947 gfc_error ("Function '%s' in initialization expression at %L "
1948 "must be an intrinsic function",
1949 e
->symtree
->n
.sym
->name
, &e
->where
);
1960 if (gfc_check_iter_variable (e
) == SUCCESS
)
1963 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1965 t
= simplify_parameter_variable (e
, 0);
1969 if (gfc_in_match_data ())
1972 gfc_error ("Parameter '%s' at %L has not been declared or is "
1973 "a variable, which does not reduce to a constant "
1974 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1983 case EXPR_SUBSTRING
:
1984 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1988 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1990 t
= gfc_simplify_expr (e
, 0);
1994 case EXPR_STRUCTURE
:
1995 t
= gfc_check_constructor (e
, check_init_expr
);
1999 t
= gfc_check_constructor (e
, check_init_expr
);
2003 t
= gfc_expand_constructor (e
);
2007 t
= gfc_check_constructor_type (e
);
2011 gfc_internal_error ("check_init_expr(): Unknown expression type");
2018 /* Match an initialization expression. We work by first matching an
2019 expression, then reducing it to a constant. */
2022 gfc_match_init_expr (gfc_expr
**result
)
2028 m
= gfc_match_expr (&expr
);
2033 t
= gfc_resolve_expr (expr
);
2035 t
= check_init_expr (expr
);
2040 gfc_free_expr (expr
);
2044 if (expr
->expr_type
== EXPR_ARRAY
2045 && (gfc_check_constructor_type (expr
) == FAILURE
2046 || gfc_expand_constructor (expr
) == FAILURE
))
2048 gfc_free_expr (expr
);
2052 /* Not all inquiry functions are simplified to constant expressions
2053 so it is necessary to call check_inquiry again. */
2054 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) == FAILURE
2055 && !gfc_in_match_data ())
2057 gfc_error ("Initialization expression didn't reduce %C");
2067 static try check_restricted (gfc_expr
*);
2069 /* Given an actual argument list, test to see that each argument is a
2070 restricted expression and optionally if the expression type is
2071 integer or character. */
2074 restricted_args (gfc_actual_arglist
*a
)
2076 for (; a
; a
= a
->next
)
2078 if (check_restricted (a
->expr
) == FAILURE
)
2086 /************* Restricted/specification expressions *************/
2089 /* Make sure a non-intrinsic function is a specification function. */
2092 external_spec_function (gfc_expr
*e
)
2096 f
= e
->value
.function
.esym
;
2098 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2100 gfc_error ("Specification function '%s' at %L cannot be a statement "
2101 "function", f
->name
, &e
->where
);
2105 if (f
->attr
.proc
== PROC_INTERNAL
)
2107 gfc_error ("Specification function '%s' at %L cannot be an internal "
2108 "function", f
->name
, &e
->where
);
2112 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2114 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2119 if (f
->attr
.recursive
)
2121 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2122 f
->name
, &e
->where
);
2126 return restricted_args (e
->value
.function
.actual
);
2130 /* Check to see that a function reference to an intrinsic is a
2131 restricted expression. */
2134 restricted_intrinsic (gfc_expr
*e
)
2136 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2137 if (check_inquiry (e
, 0) == SUCCESS
)
2140 return restricted_args (e
->value
.function
.actual
);
2144 /* Verify that an expression is a restricted expression. Like its
2145 cousin check_init_expr(), an error message is generated if we
2149 check_restricted (gfc_expr
*e
)
2157 switch (e
->expr_type
)
2160 t
= check_intrinsic_op (e
, check_restricted
);
2162 t
= gfc_simplify_expr (e
, 0);
2167 t
= e
->value
.function
.esym
? external_spec_function (e
)
2168 : restricted_intrinsic (e
);
2172 sym
= e
->symtree
->n
.sym
;
2175 if (sym
->attr
.optional
)
2177 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2178 sym
->name
, &e
->where
);
2182 if (sym
->attr
.intent
== INTENT_OUT
)
2184 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2185 sym
->name
, &e
->where
);
2189 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2190 processed in resolve.c(resolve_formal_arglist). This is done so
2191 that host associated dummy array indices are accepted (PR23446).
2192 This mechanism also does the same for the specification expressions
2193 of array-valued functions. */
2194 if (sym
->attr
.in_common
2195 || sym
->attr
.use_assoc
2197 || sym
->ns
!= gfc_current_ns
2198 || (sym
->ns
->proc_name
!= NULL
2199 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2200 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2206 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2207 sym
->name
, &e
->where
);
2216 case EXPR_SUBSTRING
:
2217 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2221 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2223 t
= gfc_simplify_expr (e
, 0);
2227 case EXPR_STRUCTURE
:
2228 t
= gfc_check_constructor (e
, check_restricted
);
2232 t
= gfc_check_constructor (e
, check_restricted
);
2236 gfc_internal_error ("check_restricted(): Unknown expression type");
2243 /* Check to see that an expression is a specification expression. If
2244 we return FAILURE, an error has been generated. */
2247 gfc_specification_expr (gfc_expr
*e
)
2253 if (e
->ts
.type
!= BT_INTEGER
)
2255 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2261 gfc_error ("Expression at %L must be scalar", &e
->where
);
2265 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2268 return check_restricted (e
);
2272 /************** Expression conformance checks. *************/
2274 /* Given two expressions, make sure that the arrays are conformable. */
2277 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2279 int op1_flag
, op2_flag
, d
;
2280 mpz_t op1_size
, op2_size
;
2283 if (op1
->rank
== 0 || op2
->rank
== 0)
2286 if (op1
->rank
!= op2
->rank
)
2288 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2295 for (d
= 0; d
< op1
->rank
; d
++)
2297 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2298 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2300 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2302 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2303 _(optype_msgid
), &op1
->where
, d
+ 1,
2304 (int) mpz_get_si (op1_size
),
2305 (int) mpz_get_si (op2_size
));
2311 mpz_clear (op1_size
);
2313 mpz_clear (op2_size
);
2323 /* Given an assignable expression and an arbitrary expression, make
2324 sure that the assignment can take place. */
2327 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2333 sym
= lvalue
->symtree
->n
.sym
;
2335 /* Check INTENT(IN), unless the object itself is the component or
2336 sub-component of a pointer. */
2337 has_pointer
= sym
->attr
.pointer
;
2339 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2340 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2346 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2348 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2349 sym
->name
, &lvalue
->where
);
2353 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2354 variable local to a function subprogram. Its existence begins when
2355 execution of the function is initiated and ends when execution of the
2356 function is terminated...
2357 Therefore, the left hand side is no longer a variable, when it is: */
2358 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2359 && !sym
->attr
.external
)
2364 /* (i) Use associated; */
2365 if (sym
->attr
.use_assoc
)
2368 /* (ii) The assignment is in the main program; or */
2369 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2372 /* (iii) A module or internal procedure... */
2373 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2374 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2375 && gfc_current_ns
->parent
2376 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2377 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2378 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2380 /* ... that is not a function... */
2381 if (!gfc_current_ns
->proc_name
->attr
.function
)
2384 /* ... or is not an entry and has a different name. */
2385 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2391 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2396 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2398 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2399 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2403 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2405 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2410 if (rvalue
->expr_type
== EXPR_NULL
)
2412 gfc_error ("NULL appears on right-hand side in assignment at %L",
2417 if (sym
->attr
.cray_pointee
2418 && lvalue
->ref
!= NULL
2419 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2420 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2422 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2423 "is illegal", &lvalue
->where
);
2427 /* This is possibly a typo: x = f() instead of x => f(). */
2428 if (gfc_option
.warn_surprising
2429 && rvalue
->expr_type
== EXPR_FUNCTION
2430 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2431 gfc_warning ("POINTER valued function appears on right-hand side of "
2432 "assignment at %L", &rvalue
->where
);
2434 /* Check size of array assignments. */
2435 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2436 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2439 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2444 /* Numeric can be converted to any other numeric. And Hollerith can be
2445 converted to any other type. */
2446 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2447 || rvalue
->ts
.type
== BT_HOLLERITH
)
2450 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2453 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2454 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2455 gfc_typename (&lvalue
->ts
));
2460 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2464 /* Check that a pointer assignment is OK. We first check lvalue, and
2465 we only check rvalue if it's not an assignment to NULL() or a
2466 NULLIFY statement. */
2469 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2471 symbol_attribute attr
;
2474 int pointer
, check_intent_in
;
2476 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2478 gfc_error ("Pointer assignment target is not a POINTER at %L",
2483 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2484 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2486 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2487 "l-value since it is a procedure",
2488 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2493 /* Check INTENT(IN), unless the object itself is the component or
2494 sub-component of a pointer. */
2495 check_intent_in
= 1;
2496 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2498 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2501 check_intent_in
= 0;
2503 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2507 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2509 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2510 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2516 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2520 is_pure
= gfc_pure (NULL
);
2522 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2524 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2528 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2529 kind, etc for lvalue and rvalue must match, and rvalue must be a
2530 pure variable if we're in a pure function. */
2531 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2534 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2536 gfc_error ("Different types in pointer assignment at %L",
2541 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2543 gfc_error ("Different kind type parameters in pointer "
2544 "assignment at %L", &lvalue
->where
);
2548 if (lvalue
->rank
!= rvalue
->rank
)
2550 gfc_error ("Different ranks in pointer assignment at %L",
2555 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2556 if (rvalue
->expr_type
== EXPR_NULL
)
2559 if (lvalue
->ts
.type
== BT_CHARACTER
2560 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2561 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2562 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2563 rvalue
->ts
.cl
->length
)) == 1)
2565 gfc_error ("Different character lengths in pointer "
2566 "assignment at %L", &lvalue
->where
);
2570 attr
= gfc_expr_attr (rvalue
);
2571 if (!attr
.target
&& !attr
.pointer
)
2573 gfc_error ("Pointer assignment target is neither TARGET "
2574 "nor POINTER at %L", &rvalue
->where
);
2578 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2580 gfc_error ("Bad target in pointer assignment in PURE "
2581 "procedure at %L", &rvalue
->where
);
2584 if (gfc_has_vector_index (rvalue
))
2586 gfc_error ("Pointer assignment with vector subscript "
2587 "on rhs at %L", &rvalue
->where
);
2591 if (attr
.protected && attr
.use_assoc
)
2593 gfc_error ("Pointer assigment target has PROTECTED "
2594 "attribute at %L", &rvalue
->where
);
2602 /* Relative of gfc_check_assign() except that the lvalue is a single
2603 symbol. Used for initialization assignments. */
2606 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2611 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2613 lvalue
.expr_type
= EXPR_VARIABLE
;
2614 lvalue
.ts
= sym
->ts
;
2616 lvalue
.rank
= sym
->as
->rank
;
2617 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2618 lvalue
.symtree
->n
.sym
= sym
;
2619 lvalue
.where
= sym
->declared_at
;
2621 if (sym
->attr
.pointer
)
2622 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2624 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2626 gfc_free (lvalue
.symtree
);
2632 /* Get an expression for a default initializer. */
2635 gfc_default_initializer (gfc_typespec
*ts
)
2637 gfc_constructor
*tail
;
2643 /* See if we have a default initializer. */
2644 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2646 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2647 init
= gfc_get_expr ();
2653 /* Build the constructor. */
2654 init
->expr_type
= EXPR_STRUCTURE
;
2656 init
->where
= ts
->derived
->declared_at
;
2658 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2661 init
->value
.constructor
= tail
= gfc_get_constructor ();
2664 tail
->next
= gfc_get_constructor ();
2669 tail
->expr
= gfc_copy_expr (c
->initializer
);
2673 tail
->expr
= gfc_get_expr ();
2674 tail
->expr
->expr_type
= EXPR_NULL
;
2675 tail
->expr
->ts
= c
->ts
;
2682 /* Given a symbol, create an expression node with that symbol as a
2683 variable. If the symbol is array valued, setup a reference of the
2687 gfc_get_variable_expr (gfc_symtree
*var
)
2691 e
= gfc_get_expr ();
2692 e
->expr_type
= EXPR_VARIABLE
;
2694 e
->ts
= var
->n
.sym
->ts
;
2696 if (var
->n
.sym
->as
!= NULL
)
2698 e
->rank
= var
->n
.sym
->as
->rank
;
2699 e
->ref
= gfc_get_ref ();
2700 e
->ref
->type
= REF_ARRAY
;
2701 e
->ref
->u
.ar
.type
= AR_FULL
;
2708 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2711 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2713 gfc_actual_arglist
*arg
;
2720 switch (expr
->expr_type
)
2723 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2724 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2728 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2729 gfc_expr_set_symbols_referenced (arg
->expr
);
2733 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2738 case EXPR_SUBSTRING
:
2741 case EXPR_STRUCTURE
:
2743 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2744 gfc_expr_set_symbols_referenced (c
->expr
);
2752 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2756 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2758 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2759 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2760 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2768 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2769 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);