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.
359 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
361 mpz_t
*new_shape
, *s
;
367 || dim
->expr_type
!= EXPR_CONSTANT
368 || dim
->ts
.type
!= BT_INTEGER
)
371 n
= mpz_get_si (dim
->value
.integer
);
372 n
--; /* Convert to zero based index */
373 if (n
< 0 || n
>= rank
)
376 s
= new_shape
= gfc_get_shape (rank
- 1);
378 for (i
= 0; i
< rank
; i
++)
382 mpz_init_set (*s
, shape
[i
]);
390 /* Given an expression pointer, return a copy of the expression. This
391 subroutine is recursive. */
394 gfc_copy_expr (gfc_expr
*p
)
405 switch (q
->expr_type
)
408 s
= gfc_getmem (p
->value
.character
.length
+ 1);
409 q
->value
.character
.string
= s
;
411 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
415 /* Copy target representation, if it exists. */
416 if (p
->representation
.string
)
418 s
= gfc_getmem (p
->representation
.length
+ 1);
419 q
->representation
.string
= s
;
421 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
424 /* Copy the values of any pointer components of p->value. */
428 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
432 gfc_set_model_kind (q
->ts
.kind
);
433 mpfr_init (q
->value
.real
);
434 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
438 gfc_set_model_kind (q
->ts
.kind
);
439 mpfr_init (q
->value
.complex.r
);
440 mpfr_init (q
->value
.complex.i
);
441 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
442 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
446 if (p
->representation
.string
)
447 q
->value
.character
.string
= q
->representation
.string
;
450 s
= gfc_getmem (p
->value
.character
.length
+ 1);
451 q
->value
.character
.string
= s
;
453 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
460 break; /* Already done */
464 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
471 switch (q
->value
.op
.operator)
474 case INTRINSIC_PARENTHESES
:
475 case INTRINSIC_UPLUS
:
476 case INTRINSIC_UMINUS
:
477 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
480 default: /* Binary operators */
481 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
482 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
489 q
->value
.function
.actual
=
490 gfc_copy_actual_arglist (p
->value
.function
.actual
);
495 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
503 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
505 q
->ref
= copy_ref (p
->ref
);
511 /* Return the maximum kind of two expressions. In general, higher
512 kind numbers mean more precision for numeric types. */
515 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
517 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
521 /* Returns nonzero if the type is numeric, zero otherwise. */
524 numeric_type (bt type
)
526 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
530 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
533 gfc_numeric_ts (gfc_typespec
*ts
)
535 return numeric_type (ts
->type
);
539 /* Returns an expression node that is an integer constant. */
548 p
->expr_type
= EXPR_CONSTANT
;
549 p
->ts
.type
= BT_INTEGER
;
550 p
->ts
.kind
= gfc_default_integer_kind
;
552 p
->where
= gfc_current_locus
;
553 mpz_init_set_si (p
->value
.integer
, i
);
559 /* Returns an expression node that is a logical constant. */
562 gfc_logical_expr (int i
, locus
*where
)
568 p
->expr_type
= EXPR_CONSTANT
;
569 p
->ts
.type
= BT_LOGICAL
;
570 p
->ts
.kind
= gfc_default_logical_kind
;
573 where
= &gfc_current_locus
;
575 p
->value
.logical
= i
;
581 /* Return an expression node with an optional argument list attached.
582 A variable number of gfc_expr pointers are strung together in an
583 argument list with a NULL pointer terminating the list. */
586 gfc_build_conversion (gfc_expr
*e
)
591 p
->expr_type
= EXPR_FUNCTION
;
593 p
->value
.function
.actual
= NULL
;
595 p
->value
.function
.actual
= gfc_get_actual_arglist ();
596 p
->value
.function
.actual
->expr
= e
;
602 /* Given an expression node with some sort of numeric binary
603 expression, insert type conversions required to make the operands
606 The exception is that the operands of an exponential don't have to
607 have the same type. If possible, the base is promoted to the type
608 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
609 1.0**2 stays as it is. */
612 gfc_type_convert_binary (gfc_expr
*e
)
616 op1
= e
->value
.op
.op1
;
617 op2
= e
->value
.op
.op2
;
619 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
621 gfc_clear_ts (&e
->ts
);
625 /* Kind conversions of same type. */
626 if (op1
->ts
.type
== op2
->ts
.type
)
628 if (op1
->ts
.kind
== op2
->ts
.kind
)
630 /* No type conversions. */
635 if (op1
->ts
.kind
> op2
->ts
.kind
)
636 gfc_convert_type (op2
, &op1
->ts
, 2);
638 gfc_convert_type (op1
, &op2
->ts
, 2);
644 /* Integer combined with real or complex. */
645 if (op2
->ts
.type
== BT_INTEGER
)
649 /* Special case for ** operator. */
650 if (e
->value
.op
.operator == INTRINSIC_POWER
)
653 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
657 if (op1
->ts
.type
== BT_INTEGER
)
660 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
664 /* Real combined with complex. */
665 e
->ts
.type
= BT_COMPLEX
;
666 if (op1
->ts
.kind
> op2
->ts
.kind
)
667 e
->ts
.kind
= op1
->ts
.kind
;
669 e
->ts
.kind
= op2
->ts
.kind
;
670 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
671 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
672 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
673 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
680 /* Function to determine if an expression is constant or not. This
681 function expects that the expression has already been simplified. */
684 gfc_is_constant_expr (gfc_expr
*e
)
687 gfc_actual_arglist
*arg
;
693 switch (e
->expr_type
)
696 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
697 && (e
->value
.op
.op2
== NULL
698 || gfc_is_constant_expr (e
->value
.op
.op2
)));
707 /* Call to intrinsic with at least one argument. */
709 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
711 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
713 if (!gfc_is_constant_expr (arg
->expr
))
727 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
728 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
733 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
734 if (!gfc_is_constant_expr (c
->expr
))
742 rv
= gfc_constant_ac (e
);
746 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
753 /* Try to collapse intrinsic expressions. */
756 simplify_intrinsic_op (gfc_expr
*p
, int type
)
758 gfc_expr
*op1
, *op2
, *result
;
760 if (p
->value
.op
.operator == INTRINSIC_USER
)
763 op1
= p
->value
.op
.op1
;
764 op2
= p
->value
.op
.op2
;
766 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
768 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
771 if (!gfc_is_constant_expr (op1
)
772 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
776 p
->value
.op
.op1
= NULL
;
777 p
->value
.op
.op2
= NULL
;
779 switch (p
->value
.op
.operator)
781 case INTRINSIC_PARENTHESES
:
782 result
= gfc_parentheses (op1
);
785 case INTRINSIC_UPLUS
:
786 result
= gfc_uplus (op1
);
789 case INTRINSIC_UMINUS
:
790 result
= gfc_uminus (op1
);
794 result
= gfc_add (op1
, op2
);
797 case INTRINSIC_MINUS
:
798 result
= gfc_subtract (op1
, op2
);
801 case INTRINSIC_TIMES
:
802 result
= gfc_multiply (op1
, op2
);
805 case INTRINSIC_DIVIDE
:
806 result
= gfc_divide (op1
, op2
);
809 case INTRINSIC_POWER
:
810 result
= gfc_power (op1
, op2
);
813 case INTRINSIC_CONCAT
:
814 result
= gfc_concat (op1
, op2
);
818 result
= gfc_eq (op1
, op2
);
822 result
= gfc_ne (op1
, op2
);
826 result
= gfc_gt (op1
, op2
);
830 result
= gfc_ge (op1
, op2
);
834 result
= gfc_lt (op1
, op2
);
838 result
= gfc_le (op1
, op2
);
842 result
= gfc_not (op1
);
846 result
= gfc_and (op1
, op2
);
850 result
= gfc_or (op1
, op2
);
854 result
= gfc_eqv (op1
, op2
);
858 result
= gfc_neqv (op1
, op2
);
862 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
872 result
->rank
= p
->rank
;
873 result
->where
= p
->where
;
874 gfc_replace_expr (p
, result
);
880 /* Subroutine to simplify constructor expressions. Mutually recursive
881 with gfc_simplify_expr(). */
884 simplify_constructor (gfc_constructor
*c
, int type
)
886 for (; c
; c
= c
->next
)
889 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
890 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
891 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
894 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
902 /* Pull a single array element out of an array constructor. */
905 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
906 gfc_constructor
**rval
)
908 unsigned long nelemen
;
920 mpz_init_set_ui (offset
, 0);
923 mpz_init_set_ui (span
, 1);
924 for (i
= 0; i
< ar
->dimen
; i
++)
926 e
= gfc_copy_expr (ar
->start
[i
]);
927 if (e
->expr_type
!= EXPR_CONSTANT
)
933 /* Check the bounds. */
935 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
936 || mpz_cmp (e
->value
.integer
,
937 ar
->as
->lower
[i
]->value
.integer
) < 0))
939 gfc_error ("index in dimension %d is out of bounds "
940 "at %L", i
+ 1, &ar
->c_where
[i
]);
946 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
947 mpz_mul (delta
, delta
, span
);
948 mpz_add (offset
, offset
, delta
);
951 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
952 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
953 mpz_mul (span
, span
, tmp
);
958 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
981 /* Find a component of a structure constructor. */
983 static gfc_constructor
*
984 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
989 comp
= ref
->u
.c
.sym
->components
;
990 pick
= ref
->u
.c
.component
;
1001 /* Replace an expression with the contents of a constructor, removing
1002 the subobject reference in the process. */
1005 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1011 e
->ref
= p
->ref
->next
;
1012 p
->ref
->next
= NULL
;
1013 gfc_replace_expr (p
, e
);
1017 /* Pull an array section out of an array constructor. */
1020 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1026 long unsigned one
= 1;
1028 mpz_t start
[GFC_MAX_DIMENSIONS
];
1029 mpz_t end
[GFC_MAX_DIMENSIONS
];
1030 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1031 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1032 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1038 gfc_constructor
*cons
;
1039 gfc_constructor
*base
;
1045 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1050 base
= expr
->value
.constructor
;
1051 expr
->value
.constructor
= NULL
;
1053 rank
= ref
->u
.ar
.as
->rank
;
1055 if (expr
->shape
== NULL
)
1056 expr
->shape
= gfc_get_shape (rank
);
1058 mpz_init_set_ui (delta_mpz
, one
);
1059 mpz_init_set_ui (nelts
, one
);
1062 /* Do the initialization now, so that we can cleanup without
1063 keeping track of where we were. */
1064 for (d
= 0; d
< rank
; d
++)
1066 mpz_init (delta
[d
]);
1067 mpz_init (start
[d
]);
1070 mpz_init (stride
[d
]);
1074 /* Build the counters to clock through the array reference. */
1076 for (d
= 0; d
< rank
; d
++)
1078 /* Make this stretch of code easier on the eye! */
1079 begin
= ref
->u
.ar
.start
[d
];
1080 finish
= ref
->u
.ar
.end
[d
];
1081 step
= ref
->u
.ar
.stride
[d
];
1082 lower
= ref
->u
.ar
.as
->lower
[d
];
1083 upper
= ref
->u
.ar
.as
->upper
[d
];
1085 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1089 if (begin
->expr_type
!= EXPR_ARRAY
)
1095 gcc_assert (begin
->rank
== 1);
1096 gcc_assert (begin
->shape
);
1098 vecsub
[d
] = begin
->value
.constructor
;
1099 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1100 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1101 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1104 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1106 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1107 || mpz_cmp (c
->expr
->value
.integer
,
1108 lower
->value
.integer
) < 0)
1110 gfc_error ("index in dimension %d is out of bounds "
1111 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1119 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1120 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1121 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1127 /* Obtain the stride. */
1129 mpz_set (stride
[d
], step
->value
.integer
);
1131 mpz_set_ui (stride
[d
], one
);
1133 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1134 mpz_set_ui (stride
[d
], one
);
1136 /* Obtain the start value for the index. */
1138 mpz_set (start
[d
], begin
->value
.integer
);
1140 mpz_set (start
[d
], lower
->value
.integer
);
1142 mpz_set (ctr
[d
], start
[d
]);
1144 /* Obtain the end value for the index. */
1146 mpz_set (end
[d
], finish
->value
.integer
);
1148 mpz_set (end
[d
], upper
->value
.integer
);
1150 /* Separate 'if' because elements sometimes arrive with
1152 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1153 mpz_set (end
[d
], begin
->value
.integer
);
1155 /* Check the bounds. */
1156 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1157 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1158 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1159 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1161 gfc_error ("index in dimension %d is out of bounds "
1162 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1167 /* Calculate the number of elements and the shape. */
1168 mpz_set (tmp_mpz
, stride
[d
]);
1169 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1170 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1171 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1172 mpz_mul (nelts
, nelts
, tmp_mpz
);
1174 /* An element reference reduces the rank of the expression; don't
1175 add anything to the shape array. */
1176 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1177 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1180 /* Calculate the 'stride' (=delta) for conversion of the
1181 counter values into the index along the constructor. */
1182 mpz_set (delta
[d
], delta_mpz
);
1183 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1184 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1185 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1192 /* Now clock through the array reference, calculating the index in
1193 the source constructor and transferring the elements to the new
1195 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1197 if (ref
->u
.ar
.offset
)
1198 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1200 mpz_init_set_ui (ptr
, 0);
1203 for (d
= 0; d
< rank
; d
++)
1205 mpz_set (tmp_mpz
, ctr
[d
]);
1206 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1207 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1208 mpz_add (ptr
, ptr
, tmp_mpz
);
1210 if (!incr_ctr
) continue;
1212 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1214 gcc_assert(vecsub
[d
]);
1216 if (!vecsub
[d
]->next
)
1217 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1220 vecsub
[d
] = vecsub
[d
]->next
;
1223 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1227 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1229 if (mpz_cmp_ui (stride
[d
], 0) > 0
1230 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1231 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1232 mpz_set (ctr
[d
], start
[d
]);
1238 /* There must be a better way of dealing with negative strides
1239 than resetting the index and the constructor pointer! */
1240 if (mpz_cmp (ptr
, index
) < 0)
1242 mpz_set_ui (index
, 0);
1246 while (mpz_cmp (ptr
, index
) > 0)
1248 mpz_add_ui (index
, index
, one
);
1252 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1260 mpz_clear (delta_mpz
);
1261 mpz_clear (tmp_mpz
);
1263 for (d
= 0; d
< rank
; d
++)
1265 mpz_clear (delta
[d
]);
1266 mpz_clear (start
[d
]);
1269 mpz_clear (stride
[d
]);
1271 gfc_free_constructor (base
);
1275 /* Pull a substring out of an expression. */
1278 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1284 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1285 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1288 *newp
= gfc_copy_expr (p
);
1289 chr
= p
->value
.character
.string
;
1290 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1291 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1293 (*newp
)->value
.character
.length
= end
- start
+ 1;
1294 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1295 (*newp
)->value
.character
.length
);
1301 /* Simplify a subobject reference of a constructor. This occurs when
1302 parameter variable values are substituted. */
1305 simplify_const_ref (gfc_expr
*p
)
1307 gfc_constructor
*cons
;
1312 switch (p
->ref
->type
)
1315 switch (p
->ref
->u
.ar
.type
)
1318 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1325 remove_subobject_ref (p
, cons
);
1329 if (find_array_section (p
, p
->ref
) == FAILURE
)
1331 p
->ref
->u
.ar
.type
= AR_FULL
;
1336 if (p
->ref
->next
!= NULL
1337 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1339 cons
= p
->value
.constructor
;
1340 for (; cons
; cons
= cons
->next
)
1342 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1343 simplify_const_ref (cons
->expr
);
1346 gfc_free_ref_list (p
->ref
);
1357 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1358 remove_subobject_ref (p
, cons
);
1362 if (find_substring_ref (p
, &newp
) == FAILURE
)
1365 gfc_replace_expr (p
, newp
);
1366 gfc_free_ref_list (p
->ref
);
1376 /* Simplify a chain of references. */
1379 simplify_ref_chain (gfc_ref
*ref
, int type
)
1383 for (; ref
; ref
= ref
->next
)
1388 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1390 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1392 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1394 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1400 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1402 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1414 /* Try to substitute the value of a parameter variable. */
1416 simplify_parameter_variable (gfc_expr
*p
, int type
)
1421 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1427 /* Do not copy subobject refs for constant. */
1428 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1429 e
->ref
= copy_ref (p
->ref
);
1430 t
= gfc_simplify_expr (e
, type
);
1432 /* Only use the simplification if it eliminated all subobject
1434 if (t
== SUCCESS
&& !e
->ref
)
1435 gfc_replace_expr (p
, e
);
1442 /* Given an expression, simplify it by collapsing constant
1443 expressions. Most simplification takes place when the expression
1444 tree is being constructed. If an intrinsic function is simplified
1445 at some point, we get called again to collapse the result against
1448 We work by recursively simplifying expression nodes, simplifying
1449 intrinsic functions where possible, which can lead to further
1450 constant collapsing. If an operator has constant operand(s), we
1451 rip the expression apart, and rebuild it, hoping that it becomes
1454 The expression type is defined for:
1455 0 Basic expression parsing
1456 1 Simplifying array constructors -- will substitute
1458 Returns FAILURE on error, SUCCESS otherwise.
1459 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1462 gfc_simplify_expr (gfc_expr
*p
, int type
)
1464 gfc_actual_arglist
*ap
;
1469 switch (p
->expr_type
)
1476 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1477 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1480 if (p
->value
.function
.isym
!= NULL
1481 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1486 case EXPR_SUBSTRING
:
1487 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1490 if (gfc_is_constant_expr (p
))
1495 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1496 start
--; /* Convert from one-based to zero-based. */
1497 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1498 s
= gfc_getmem (end
- start
+ 2);
1499 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1500 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1501 gfc_free (p
->value
.character
.string
);
1502 p
->value
.character
.string
= s
;
1503 p
->value
.character
.length
= end
- start
;
1504 p
->ts
.cl
= gfc_get_charlen ();
1505 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1506 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1507 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1508 gfc_free_ref_list (p
->ref
);
1510 p
->expr_type
= EXPR_CONSTANT
;
1515 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1520 /* Only substitute array parameter variables if we are in an
1521 initialization expression, or we want a subsection. */
1522 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1523 && (gfc_init_expr
|| p
->ref
1524 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1526 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1533 gfc_simplify_iterator_var (p
);
1536 /* Simplify subcomponent references. */
1537 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1542 case EXPR_STRUCTURE
:
1544 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1547 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1550 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1551 && p
->ref
->u
.ar
.type
== AR_FULL
)
1552 gfc_expand_constructor (p
);
1554 if (simplify_const_ref (p
) == FAILURE
)
1564 /* Returns the type of an expression with the exception that iterator
1565 variables are automatically integers no matter what else they may
1571 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1578 /* Check an intrinsic arithmetic operation to see if it is consistent
1579 with some type of expression. */
1581 static try check_init_expr (gfc_expr
*);
1584 /* Scalarize an expression for an elemental intrinsic call. */
1587 scalarize_intrinsic_call (gfc_expr
*e
)
1589 gfc_actual_arglist
*a
, *b
;
1590 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1591 gfc_expr
*expr
, *old
;
1594 old
= gfc_copy_expr (e
);
1596 /* Assume that the old expression carries the type information and
1597 that the first arg carries all the shape information. */
1598 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1599 gfc_free_constructor (expr
->value
.constructor
);
1600 expr
->value
.constructor
= NULL
;
1603 expr
->expr_type
= EXPR_ARRAY
;
1605 /* Copy the array argument constructors into an array, with nulls
1608 a
= old
->value
.function
.actual
;
1609 for (; a
; a
= a
->next
)
1611 /* Check that this is OK for an initialization expression. */
1612 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1616 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1618 rank
[n
] = a
->expr
->rank
;
1619 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1620 args
[n
] = gfc_copy_constructor (ctor
);
1622 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1625 rank
[n
] = a
->expr
->rank
;
1628 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1635 for (i
= 1; i
< n
; i
++)
1636 if (rank
[i
] && rank
[i
] != rank
[0])
1639 /* Using the first argument as the master, step through the array
1640 calling the function for each element and advancing the array
1641 constructors together. */
1644 for (; ctor
; ctor
= ctor
->next
)
1646 if (expr
->value
.constructor
== NULL
)
1647 expr
->value
.constructor
1648 = new_ctor
= gfc_get_constructor ();
1651 new_ctor
->next
= gfc_get_constructor ();
1652 new_ctor
= new_ctor
->next
;
1654 new_ctor
->expr
= gfc_copy_expr (old
);
1655 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1657 b
= old
->value
.function
.actual
;
1658 for (i
= 0; i
< n
; i
++)
1661 new_ctor
->expr
->value
.function
.actual
1662 = a
= gfc_get_actual_arglist ();
1665 a
->next
= gfc_get_actual_arglist ();
1669 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1671 a
->expr
= gfc_copy_expr (b
->expr
);
1676 /* Simplify the function calls. */
1677 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1680 for (i
= 0; i
< n
; i
++)
1682 args
[i
] = args
[i
]->next
;
1684 for (i
= 1; i
< n
; i
++)
1685 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1686 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1692 gfc_free_expr (old
);
1696 gfc_error_now ("elemental function arguments at %C are not compliant");
1699 gfc_free_expr (expr
);
1700 gfc_free_expr (old
);
1706 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1708 gfc_expr
*op1
= e
->value
.op
.op1
;
1709 gfc_expr
*op2
= e
->value
.op
.op2
;
1711 if ((*check_function
) (op1
) == FAILURE
)
1714 switch (e
->value
.op
.operator)
1716 case INTRINSIC_UPLUS
:
1717 case INTRINSIC_UMINUS
:
1718 if (!numeric_type (et0 (op1
)))
1728 if ((*check_function
) (op2
) == FAILURE
)
1731 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1732 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1734 gfc_error ("Numeric or CHARACTER operands are required in "
1735 "expression at %L", &e
->where
);
1740 case INTRINSIC_PLUS
:
1741 case INTRINSIC_MINUS
:
1742 case INTRINSIC_TIMES
:
1743 case INTRINSIC_DIVIDE
:
1744 case INTRINSIC_POWER
:
1745 if ((*check_function
) (op2
) == FAILURE
)
1748 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1751 if (e
->value
.op
.operator == INTRINSIC_POWER
1752 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1754 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1755 "exponent in an initialization "
1756 "expression at %L", &op2
->where
)
1763 case INTRINSIC_CONCAT
:
1764 if ((*check_function
) (op2
) == FAILURE
)
1767 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1769 gfc_error ("Concatenation operator in expression at %L "
1770 "must have two CHARACTER operands", &op1
->where
);
1774 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1776 gfc_error ("Concat operator at %L must concatenate strings of the "
1777 "same kind", &e
->where
);
1784 if (et0 (op1
) != BT_LOGICAL
)
1786 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1787 "operand", &op1
->where
);
1796 case INTRINSIC_NEQV
:
1797 if ((*check_function
) (op2
) == FAILURE
)
1800 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1802 gfc_error ("LOGICAL operands are required in expression at %L",
1809 case INTRINSIC_PARENTHESES
:
1813 gfc_error ("Only intrinsic operators can be used in expression at %L",
1821 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1828 /* Certain inquiry functions are specifically allowed to have variable
1829 arguments, which is an exception to the normal requirement that an
1830 initialization function have initialization arguments. We head off
1831 this problem here. */
1834 check_inquiry (gfc_expr
*e
, int not_restricted
)
1838 /* FIXME: This should be moved into the intrinsic definitions,
1839 to eliminate this ugly hack. */
1840 static const char * const inquiry_function
[] = {
1841 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1842 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1843 "lbound", "ubound", NULL
1848 /* An undeclared parameter will get us here (PR25018). */
1849 if (e
->symtree
== NULL
)
1852 name
= e
->symtree
->n
.sym
->name
;
1854 for (i
= 0; inquiry_function
[i
]; i
++)
1855 if (strcmp (inquiry_function
[i
], name
) == 0)
1858 if (inquiry_function
[i
] == NULL
)
1861 e
= e
->value
.function
.actual
->expr
;
1863 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1866 /* At this point we have an inquiry function with a variable argument. The
1867 type of the variable might be undefined, but we need it now, because the
1868 arguments of these functions are allowed to be undefined. */
1870 if (e
->ts
.type
== BT_UNKNOWN
)
1872 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1873 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1877 e
->ts
= e
->symtree
->n
.sym
->ts
;
1880 /* Assumed character length will not reduce to a constant expression
1881 with LEN, as required by the standard. */
1882 if (i
== 4 && not_restricted
1883 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1884 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1885 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1886 "variable '%s' in constant expression at %L",
1887 e
->symtree
->n
.sym
->name
, &e
->where
);
1893 /* Verify that an expression is an initialization expression. A side
1894 effect is that the expression tree is reduced to a single constant
1895 node if all goes well. This would normally happen when the
1896 expression is constructed but function references are assumed to be
1897 intrinsics in the context of initialization expressions. If
1898 FAILURE is returned an error message has been generated. */
1901 check_init_expr (gfc_expr
*e
)
1903 gfc_actual_arglist
*ap
;
1906 gfc_intrinsic_sym
*isym
;
1911 switch (e
->expr_type
)
1914 t
= check_intrinsic_op (e
, check_init_expr
);
1916 t
= gfc_simplify_expr (e
, 0);
1923 if (check_inquiry (e
, 1) != SUCCESS
)
1926 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1927 if (check_init_expr (ap
->expr
) == FAILURE
)
1934 /* Try to scalarize an elemental intrinsic function that has an
1936 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
1937 if (isym
&& isym
->elemental
1938 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
1940 if (scalarize_intrinsic_call (e
) == SUCCESS
)
1946 m
= gfc_intrinsic_func_interface (e
, 0);
1949 gfc_error ("Function '%s' in initialization expression at %L "
1950 "must be an intrinsic function",
1951 e
->symtree
->n
.sym
->name
, &e
->where
);
1962 if (gfc_check_iter_variable (e
) == SUCCESS
)
1965 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1967 t
= simplify_parameter_variable (e
, 0);
1971 if (gfc_in_match_data ())
1974 gfc_error ("Parameter '%s' at %L has not been declared or is "
1975 "a variable, which does not reduce to a constant "
1976 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1985 case EXPR_SUBSTRING
:
1986 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1990 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1992 t
= gfc_simplify_expr (e
, 0);
1996 case EXPR_STRUCTURE
:
1997 t
= gfc_check_constructor (e
, check_init_expr
);
2001 t
= gfc_check_constructor (e
, check_init_expr
);
2005 t
= gfc_expand_constructor (e
);
2009 t
= gfc_check_constructor_type (e
);
2013 gfc_internal_error ("check_init_expr(): Unknown expression type");
2020 /* Match an initialization expression. We work by first matching an
2021 expression, then reducing it to a constant. */
2024 gfc_match_init_expr (gfc_expr
**result
)
2030 m
= gfc_match_expr (&expr
);
2035 t
= gfc_resolve_expr (expr
);
2037 t
= check_init_expr (expr
);
2042 gfc_free_expr (expr
);
2046 if (expr
->expr_type
== EXPR_ARRAY
2047 && (gfc_check_constructor_type (expr
) == FAILURE
2048 || gfc_expand_constructor (expr
) == FAILURE
))
2050 gfc_free_expr (expr
);
2054 /* Not all inquiry functions are simplified to constant expressions
2055 so it is necessary to call check_inquiry again. */
2056 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) == FAILURE
2057 && !gfc_in_match_data ())
2059 gfc_error ("Initialization expression didn't reduce %C");
2069 static try check_restricted (gfc_expr
*);
2071 /* Given an actual argument list, test to see that each argument is a
2072 restricted expression and optionally if the expression type is
2073 integer or character. */
2076 restricted_args (gfc_actual_arglist
*a
)
2078 for (; a
; a
= a
->next
)
2080 if (check_restricted (a
->expr
) == FAILURE
)
2088 /************* Restricted/specification expressions *************/
2091 /* Make sure a non-intrinsic function is a specification function. */
2094 external_spec_function (gfc_expr
*e
)
2098 f
= e
->value
.function
.esym
;
2100 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2102 gfc_error ("Specification function '%s' at %L cannot be a statement "
2103 "function", f
->name
, &e
->where
);
2107 if (f
->attr
.proc
== PROC_INTERNAL
)
2109 gfc_error ("Specification function '%s' at %L cannot be an internal "
2110 "function", f
->name
, &e
->where
);
2114 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2116 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2121 if (f
->attr
.recursive
)
2123 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2124 f
->name
, &e
->where
);
2128 return restricted_args (e
->value
.function
.actual
);
2132 /* Check to see that a function reference to an intrinsic is a
2133 restricted expression. */
2136 restricted_intrinsic (gfc_expr
*e
)
2138 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2139 if (check_inquiry (e
, 0) == SUCCESS
)
2142 return restricted_args (e
->value
.function
.actual
);
2146 /* Verify that an expression is a restricted expression. Like its
2147 cousin check_init_expr(), an error message is generated if we
2151 check_restricted (gfc_expr
*e
)
2159 switch (e
->expr_type
)
2162 t
= check_intrinsic_op (e
, check_restricted
);
2164 t
= gfc_simplify_expr (e
, 0);
2169 t
= e
->value
.function
.esym
? external_spec_function (e
)
2170 : restricted_intrinsic (e
);
2175 sym
= e
->symtree
->n
.sym
;
2178 if (sym
->attr
.optional
)
2180 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2181 sym
->name
, &e
->where
);
2185 if (sym
->attr
.intent
== INTENT_OUT
)
2187 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2188 sym
->name
, &e
->where
);
2192 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2193 processed in resolve.c(resolve_formal_arglist). This is done so
2194 that host associated dummy array indices are accepted (PR23446).
2195 This mechanism also does the same for the specification expressions
2196 of array-valued functions. */
2197 if (sym
->attr
.in_common
2198 || sym
->attr
.use_assoc
2200 || sym
->ns
!= gfc_current_ns
2201 || (sym
->ns
->proc_name
!= NULL
2202 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2203 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2209 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2210 sym
->name
, &e
->where
);
2219 case EXPR_SUBSTRING
:
2220 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2224 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2226 t
= gfc_simplify_expr (e
, 0);
2230 case EXPR_STRUCTURE
:
2231 t
= gfc_check_constructor (e
, check_restricted
);
2235 t
= gfc_check_constructor (e
, check_restricted
);
2239 gfc_internal_error ("check_restricted(): Unknown expression type");
2246 /* Check to see that an expression is a specification expression. If
2247 we return FAILURE, an error has been generated. */
2250 gfc_specification_expr (gfc_expr
*e
)
2255 if (e
->ts
.type
!= BT_INTEGER
)
2257 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2263 gfc_error ("Expression at %L must be scalar", &e
->where
);
2267 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2270 return check_restricted (e
);
2274 /************** Expression conformance checks. *************/
2276 /* Given two expressions, make sure that the arrays are conformable. */
2279 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2281 int op1_flag
, op2_flag
, d
;
2282 mpz_t op1_size
, op2_size
;
2285 if (op1
->rank
== 0 || op2
->rank
== 0)
2288 if (op1
->rank
!= op2
->rank
)
2290 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2297 for (d
= 0; d
< op1
->rank
; d
++)
2299 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2300 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2302 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2304 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2305 _(optype_msgid
), &op1
->where
, d
+ 1,
2306 (int) mpz_get_si (op1_size
),
2307 (int) mpz_get_si (op2_size
));
2313 mpz_clear (op1_size
);
2315 mpz_clear (op2_size
);
2325 /* Given an assignable expression and an arbitrary expression, make
2326 sure that the assignment can take place. */
2329 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2335 sym
= lvalue
->symtree
->n
.sym
;
2337 /* Check INTENT(IN), unless the object itself is the component or
2338 sub-component of a pointer. */
2339 has_pointer
= sym
->attr
.pointer
;
2341 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2342 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2348 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2350 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2351 sym
->name
, &lvalue
->where
);
2355 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2356 variable local to a function subprogram. Its existence begins when
2357 execution of the function is initiated and ends when execution of the
2358 function is terminated.....
2359 Therefore, the left hand side is no longer a varaiable, when it is: */
2360 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2361 && !sym
->attr
.external
)
2366 /* (i) Use associated; */
2367 if (sym
->attr
.use_assoc
)
2370 /* (ii) The assignment is in the main program; or */
2371 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2374 /* (iii) A module or internal procedure.... */
2375 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2376 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2377 && gfc_current_ns
->parent
2378 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2379 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2380 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2382 /* .... that is not a function.... */
2383 if (!gfc_current_ns
->proc_name
->attr
.function
)
2386 /* .... or is not an entry and has a different name. */
2387 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2393 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2398 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2400 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2401 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2405 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2407 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2412 if (rvalue
->expr_type
== EXPR_NULL
)
2414 gfc_error ("NULL appears on right-hand side in assignment at %L",
2419 if (sym
->attr
.cray_pointee
2420 && lvalue
->ref
!= NULL
2421 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2422 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2424 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2425 "is illegal", &lvalue
->where
);
2429 /* This is possibly a typo: x = f() instead of x => f() */
2430 if (gfc_option
.warn_surprising
2431 && rvalue
->expr_type
== EXPR_FUNCTION
2432 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2433 gfc_warning ("POINTER valued function appears on right-hand side of "
2434 "assignment at %L", &rvalue
->where
);
2436 /* Check size of array assignments. */
2437 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2438 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2441 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2446 /* Numeric can be converted to any other numeric. And Hollerith can be
2447 converted to any other type. */
2448 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2449 || rvalue
->ts
.type
== BT_HOLLERITH
)
2452 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2455 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2456 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2457 gfc_typename (&lvalue
->ts
));
2462 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2466 /* Check that a pointer assignment is OK. We first check lvalue, and
2467 we only check rvalue if it's not an assignment to NULL() or a
2468 NULLIFY statement. */
2471 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2473 symbol_attribute attr
;
2476 int pointer
, check_intent_in
;
2478 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2480 gfc_error ("Pointer assignment target is not a POINTER at %L",
2485 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2486 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2488 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2489 "l-value since it is a procedure",
2490 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2495 /* Check INTENT(IN), unless the object itself is the component or
2496 sub-component of a pointer. */
2497 check_intent_in
= 1;
2498 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2500 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2503 check_intent_in
= 0;
2505 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2509 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2511 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2512 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2518 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2522 is_pure
= gfc_pure (NULL
);
2524 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2526 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2530 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2531 kind, etc for lvalue and rvalue must match, and rvalue must be a
2532 pure variable if we're in a pure function. */
2533 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2536 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2538 gfc_error ("Different types in pointer assignment at %L",
2543 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2545 gfc_error ("Different kind type parameters in pointer "
2546 "assignment at %L", &lvalue
->where
);
2550 if (lvalue
->rank
!= rvalue
->rank
)
2552 gfc_error ("Different ranks in pointer assignment at %L",
2557 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2558 if (rvalue
->expr_type
== EXPR_NULL
)
2561 if (lvalue
->ts
.type
== BT_CHARACTER
2562 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2563 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2564 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2565 rvalue
->ts
.cl
->length
)) == 1)
2567 gfc_error ("Different character lengths in pointer "
2568 "assignment at %L", &lvalue
->where
);
2572 attr
= gfc_expr_attr (rvalue
);
2573 if (!attr
.target
&& !attr
.pointer
)
2575 gfc_error ("Pointer assignment target is neither TARGET "
2576 "nor POINTER at %L", &rvalue
->where
);
2580 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2582 gfc_error ("Bad target in pointer assignment in PURE "
2583 "procedure at %L", &rvalue
->where
);
2586 if (gfc_has_vector_index (rvalue
))
2588 gfc_error ("Pointer assignment with vector subscript "
2589 "on rhs at %L", &rvalue
->where
);
2593 if (attr
.protected && attr
.use_assoc
)
2595 gfc_error ("Pointer assigment target has PROTECTED "
2596 "attribute at %L", &rvalue
->where
);
2604 /* Relative of gfc_check_assign() except that the lvalue is a single
2605 symbol. Used for initialization assignments. */
2608 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2613 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2615 lvalue
.expr_type
= EXPR_VARIABLE
;
2616 lvalue
.ts
= sym
->ts
;
2618 lvalue
.rank
= sym
->as
->rank
;
2619 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2620 lvalue
.symtree
->n
.sym
= sym
;
2621 lvalue
.where
= sym
->declared_at
;
2623 if (sym
->attr
.pointer
)
2624 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2626 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2628 gfc_free (lvalue
.symtree
);
2634 /* Get an expression for a default initializer. */
2637 gfc_default_initializer (gfc_typespec
*ts
)
2639 gfc_constructor
*tail
;
2645 /* See if we have a default initializer. */
2646 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2648 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2649 init
= gfc_get_expr ();
2655 /* Build the constructor. */
2656 init
->expr_type
= EXPR_STRUCTURE
;
2658 init
->where
= ts
->derived
->declared_at
;
2660 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2663 init
->value
.constructor
= tail
= gfc_get_constructor ();
2666 tail
->next
= gfc_get_constructor ();
2671 tail
->expr
= gfc_copy_expr (c
->initializer
);
2675 tail
->expr
= gfc_get_expr ();
2676 tail
->expr
->expr_type
= EXPR_NULL
;
2677 tail
->expr
->ts
= c
->ts
;
2684 /* Given a symbol, create an expression node with that symbol as a
2685 variable. If the symbol is array valued, setup a reference of the
2689 gfc_get_variable_expr (gfc_symtree
*var
)
2693 e
= gfc_get_expr ();
2694 e
->expr_type
= EXPR_VARIABLE
;
2696 e
->ts
= var
->n
.sym
->ts
;
2698 if (var
->n
.sym
->as
!= NULL
)
2700 e
->rank
= var
->n
.sym
->as
->rank
;
2701 e
->ref
= gfc_get_ref ();
2702 e
->ref
->type
= REF_ARRAY
;
2703 e
->ref
->u
.ar
.type
= AR_FULL
;
2710 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2713 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2715 gfc_actual_arglist
*arg
;
2722 switch (expr
->expr_type
)
2725 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2726 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2730 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2731 gfc_expr_set_symbols_referenced (arg
->expr
);
2735 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2740 case EXPR_SUBSTRING
:
2743 case EXPR_STRUCTURE
:
2745 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2746 gfc_expr_set_symbols_referenced (c
->expr
);
2754 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2758 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2760 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2761 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2762 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2770 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2771 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);