1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new;
72 for (; p
; p
= p
->next
)
74 new = gfc_get_actual_arglist ();
77 new->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
109 gfc_free_expr (p
->u
.ar
.start
[i
]);
110 gfc_free_expr (p
->u
.ar
.end
[i
]);
111 gfc_free_expr (p
->u
.ar
.stride
[i
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
159 mpfr_clear (e
->value
.complex.r
);
160 mpfr_clear (e
->value
.complex.i
);
167 /* Free the representation, except in character constants where it
168 is the same as value.character.string and thus already freed. */
169 if (e
->representation
.string
&& e
->ts
.type
!= BT_CHARACTER
)
170 gfc_free (e
->representation
.string
);
175 if (e
->value
.op
.op1
!= NULL
)
176 gfc_free_expr (e
->value
.op
.op1
);
177 if (e
->value
.op
.op2
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op2
);
182 gfc_free_actual_arglist (e
->value
.function
.actual
);
190 gfc_free_constructor (e
->value
.constructor
);
194 gfc_free (e
->value
.character
.string
);
201 gfc_internal_error ("free_expr0(): Bad expr type");
204 /* Free a shape array. */
205 if (e
->shape
!= NULL
)
207 for (n
= 0; n
< e
->rank
; n
++)
208 mpz_clear (e
->shape
[n
]);
213 gfc_free_ref_list (e
->ref
);
215 memset (e
, '\0', sizeof (gfc_expr
));
219 /* Free an expression node and everything beneath it. */
222 gfc_free_expr (gfc_expr
*e
)
226 if (e
->con_by_offset
)
227 splay_tree_delete (e
->con_by_offset
);
233 /* Graft the *src expression onto the *dest subexpression. */
236 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
244 /* Try to extract an integer constant from the passed expression node.
245 Returns an error message or NULL if the result is set. It is
246 tempting to generate an error and return SUCCESS or FAILURE, but
247 failure is OK for some callers. */
250 gfc_extract_int (gfc_expr
*expr
, int *result
)
252 if (expr
->expr_type
!= EXPR_CONSTANT
)
253 return _("Constant expression required at %C");
255 if (expr
->ts
.type
!= BT_INTEGER
)
256 return _("Integer expression required at %C");
258 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
259 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
261 return _("Integer value too large in expression at %C");
264 *result
= (int) mpz_get_si (expr
->value
.integer
);
270 /* Recursively copy a list of reference structures. */
273 copy_ref (gfc_ref
*src
)
281 dest
= gfc_get_ref ();
282 dest
->type
= src
->type
;
287 ar
= gfc_copy_array_ref (&src
->u
.ar
);
293 dest
->u
.c
= src
->u
.c
;
297 dest
->u
.ss
= src
->u
.ss
;
298 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
299 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
303 dest
->next
= copy_ref (src
->next
);
309 /* Detect whether an expression has any vector index array references. */
312 gfc_has_vector_index (gfc_expr
*e
)
316 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
317 if (ref
->type
== REF_ARRAY
)
318 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
319 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
325 /* Copy a shape array. */
328 gfc_copy_shape (mpz_t
*shape
, int rank
)
336 new_shape
= gfc_get_shape (rank
);
338 for (n
= 0; n
< rank
; n
++)
339 mpz_init_set (new_shape
[n
], shape
[n
]);
345 /* Copy a shape array excluding dimension N, where N is an integer
346 constant expression. Dimensions are numbered in fortran style --
349 So, if the original shape array contains R elements
350 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
351 the result contains R-1 elements:
352 { s1 ... sN-1 sN+1 ... sR-1}
354 If anything goes wrong -- N is not a constant, its value is out
355 of range -- or anything else, just returns NULL. */
358 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
360 mpz_t
*new_shape
, *s
;
366 || dim
->expr_type
!= EXPR_CONSTANT
367 || dim
->ts
.type
!= BT_INTEGER
)
370 n
= mpz_get_si (dim
->value
.integer
);
371 n
--; /* Convert to zero based index. */
372 if (n
< 0 || n
>= rank
)
375 s
= new_shape
= gfc_get_shape (rank
- 1);
377 for (i
= 0; i
< rank
; i
++)
381 mpz_init_set (*s
, shape
[i
]);
389 /* Given an expression pointer, return a copy of the expression. This
390 subroutine is recursive. */
393 gfc_copy_expr (gfc_expr
*p
)
404 switch (q
->expr_type
)
407 s
= gfc_getmem (p
->value
.character
.length
+ 1);
408 q
->value
.character
.string
= s
;
410 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
414 /* Copy target representation, if it exists. */
415 if (p
->representation
.string
)
417 s
= gfc_getmem (p
->representation
.length
+ 1);
418 q
->representation
.string
= s
;
420 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
423 /* Copy the values of any pointer components of p->value. */
427 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
431 gfc_set_model_kind (q
->ts
.kind
);
432 mpfr_init (q
->value
.real
);
433 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
437 gfc_set_model_kind (q
->ts
.kind
);
438 mpfr_init (q
->value
.complex.r
);
439 mpfr_init (q
->value
.complex.i
);
440 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
441 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
445 if (p
->representation
.string
)
446 q
->value
.character
.string
= q
->representation
.string
;
449 s
= gfc_getmem (p
->value
.character
.length
+ 1);
450 q
->value
.character
.string
= s
;
452 /* This is the case for the C_NULL_CHAR named constant. */
453 if (p
->value
.character
.length
== 0
454 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
457 /* Need to set the length to 1 to make sure the NUL
458 terminator is copied. */
459 q
->value
.character
.length
= 1;
462 memcpy (s
, p
->value
.character
.string
,
463 p
->value
.character
.length
+ 1);
470 break; /* Already done. */
474 /* Should never be reached. */
476 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
483 switch (q
->value
.op
.operator)
486 case INTRINSIC_PARENTHESES
:
487 case INTRINSIC_UPLUS
:
488 case INTRINSIC_UMINUS
:
489 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
492 default: /* Binary operators. */
493 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
494 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
501 q
->value
.function
.actual
=
502 gfc_copy_actual_arglist (p
->value
.function
.actual
);
507 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
515 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
517 q
->ref
= copy_ref (p
->ref
);
523 /* Return the maximum kind of two expressions. In general, higher
524 kind numbers mean more precision for numeric types. */
527 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
529 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
533 /* Returns nonzero if the type is numeric, zero otherwise. */
536 numeric_type (bt type
)
538 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
542 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
545 gfc_numeric_ts (gfc_typespec
*ts
)
547 return numeric_type (ts
->type
);
551 /* Returns an expression node that is an integer constant. */
560 p
->expr_type
= EXPR_CONSTANT
;
561 p
->ts
.type
= BT_INTEGER
;
562 p
->ts
.kind
= gfc_default_integer_kind
;
564 p
->where
= gfc_current_locus
;
565 mpz_init_set_si (p
->value
.integer
, i
);
571 /* Returns an expression node that is a logical constant. */
574 gfc_logical_expr (int i
, locus
*where
)
580 p
->expr_type
= EXPR_CONSTANT
;
581 p
->ts
.type
= BT_LOGICAL
;
582 p
->ts
.kind
= gfc_default_logical_kind
;
585 where
= &gfc_current_locus
;
587 p
->value
.logical
= i
;
593 /* Return an expression node with an optional argument list attached.
594 A variable number of gfc_expr pointers are strung together in an
595 argument list with a NULL pointer terminating the list. */
598 gfc_build_conversion (gfc_expr
*e
)
603 p
->expr_type
= EXPR_FUNCTION
;
605 p
->value
.function
.actual
= NULL
;
607 p
->value
.function
.actual
= gfc_get_actual_arglist ();
608 p
->value
.function
.actual
->expr
= e
;
614 /* Given an expression node with some sort of numeric binary
615 expression, insert type conversions required to make the operands
618 The exception is that the operands of an exponential don't have to
619 have the same type. If possible, the base is promoted to the type
620 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
621 1.0**2 stays as it is. */
624 gfc_type_convert_binary (gfc_expr
*e
)
628 op1
= e
->value
.op
.op1
;
629 op2
= e
->value
.op
.op2
;
631 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
633 gfc_clear_ts (&e
->ts
);
637 /* Kind conversions of same type. */
638 if (op1
->ts
.type
== op2
->ts
.type
)
640 if (op1
->ts
.kind
== op2
->ts
.kind
)
642 /* No type conversions. */
647 if (op1
->ts
.kind
> op2
->ts
.kind
)
648 gfc_convert_type (op2
, &op1
->ts
, 2);
650 gfc_convert_type (op1
, &op2
->ts
, 2);
656 /* Integer combined with real or complex. */
657 if (op2
->ts
.type
== BT_INTEGER
)
661 /* Special case for ** operator. */
662 if (e
->value
.op
.operator == INTRINSIC_POWER
)
665 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
669 if (op1
->ts
.type
== BT_INTEGER
)
672 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
676 /* Real combined with complex. */
677 e
->ts
.type
= BT_COMPLEX
;
678 if (op1
->ts
.kind
> op2
->ts
.kind
)
679 e
->ts
.kind
= op1
->ts
.kind
;
681 e
->ts
.kind
= op2
->ts
.kind
;
682 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
683 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
684 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
685 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
693 check_specification_function (gfc_expr
*e
)
700 sym
= e
->symtree
->n
.sym
;
702 /* F95, 7.1.6.2; F2003, 7.1.7 */
704 && sym
->attr
.function
706 && !sym
->attr
.intrinsic
707 && !sym
->attr
.recursive
708 && sym
->attr
.proc
!= PROC_INTERNAL
709 && sym
->attr
.proc
!= PROC_ST_FUNCTION
710 && sym
->attr
.proc
!= PROC_UNKNOWN
711 && sym
->formal
== NULL
)
717 /* Function to determine if an expression is constant or not. This
718 function expects that the expression has already been simplified. */
721 gfc_is_constant_expr (gfc_expr
*e
)
724 gfc_actual_arglist
*arg
;
730 switch (e
->expr_type
)
733 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
734 && (e
->value
.op
.op2
== NULL
735 || gfc_is_constant_expr (e
->value
.op
.op2
)));
743 /* Specification functions are constant. */
744 if (check_specification_function (e
) == MATCH_YES
)
750 /* Call to intrinsic with at least one argument. */
752 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
754 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
756 if (!gfc_is_constant_expr (arg
->expr
))
770 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
771 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
776 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
777 if (!gfc_is_constant_expr (c
->expr
))
785 rv
= gfc_constant_ac (e
);
789 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
796 /* Try to collapse intrinsic expressions. */
799 simplify_intrinsic_op (gfc_expr
*p
, int type
)
802 gfc_expr
*op1
, *op2
, *result
;
804 if (p
->value
.op
.operator == INTRINSIC_USER
)
807 op1
= p
->value
.op
.op1
;
808 op2
= p
->value
.op
.op2
;
809 op
= p
->value
.op
.operator;
811 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
813 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
816 if (!gfc_is_constant_expr (op1
)
817 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
821 p
->value
.op
.op1
= NULL
;
822 p
->value
.op
.op2
= NULL
;
826 case INTRINSIC_PARENTHESES
:
827 result
= gfc_parentheses (op1
);
830 case INTRINSIC_UPLUS
:
831 result
= gfc_uplus (op1
);
834 case INTRINSIC_UMINUS
:
835 result
= gfc_uminus (op1
);
839 result
= gfc_add (op1
, op2
);
842 case INTRINSIC_MINUS
:
843 result
= gfc_subtract (op1
, op2
);
846 case INTRINSIC_TIMES
:
847 result
= gfc_multiply (op1
, op2
);
850 case INTRINSIC_DIVIDE
:
851 result
= gfc_divide (op1
, op2
);
854 case INTRINSIC_POWER
:
855 result
= gfc_power (op1
, op2
);
858 case INTRINSIC_CONCAT
:
859 result
= gfc_concat (op1
, op2
);
863 case INTRINSIC_EQ_OS
:
864 result
= gfc_eq (op1
, op2
, op
);
868 case INTRINSIC_NE_OS
:
869 result
= gfc_ne (op1
, op2
, op
);
873 case INTRINSIC_GT_OS
:
874 result
= gfc_gt (op1
, op2
, op
);
878 case INTRINSIC_GE_OS
:
879 result
= gfc_ge (op1
, op2
, op
);
883 case INTRINSIC_LT_OS
:
884 result
= gfc_lt (op1
, op2
, op
);
888 case INTRINSIC_LE_OS
:
889 result
= gfc_le (op1
, op2
, op
);
893 result
= gfc_not (op1
);
897 result
= gfc_and (op1
, op2
);
901 result
= gfc_or (op1
, op2
);
905 result
= gfc_eqv (op1
, op2
);
909 result
= gfc_neqv (op1
, op2
);
913 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
923 result
->rank
= p
->rank
;
924 result
->where
= p
->where
;
925 gfc_replace_expr (p
, result
);
931 /* Subroutine to simplify constructor expressions. Mutually recursive
932 with gfc_simplify_expr(). */
935 simplify_constructor (gfc_constructor
*c
, int type
)
937 for (; c
; c
= c
->next
)
940 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
941 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
942 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
945 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
953 /* Pull a single array element out of an array constructor. */
956 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
957 gfc_constructor
**rval
)
959 unsigned long nelemen
;
971 mpz_init_set_ui (offset
, 0);
974 mpz_init_set_ui (span
, 1);
975 for (i
= 0; i
< ar
->dimen
; i
++)
977 e
= gfc_copy_expr (ar
->start
[i
]);
978 if (e
->expr_type
!= EXPR_CONSTANT
)
984 /* Check the bounds. */
986 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
987 || mpz_cmp (e
->value
.integer
,
988 ar
->as
->lower
[i
]->value
.integer
) < 0))
990 gfc_error ("index in dimension %d is out of bounds "
991 "at %L", i
+ 1, &ar
->c_where
[i
]);
997 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
998 mpz_mul (delta
, delta
, span
);
999 mpz_add (offset
, offset
, delta
);
1001 mpz_set_ui (tmp
, 1);
1002 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1003 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1004 mpz_mul (span
, span
, tmp
);
1009 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1032 /* Find a component of a structure constructor. */
1034 static gfc_constructor
*
1035 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1037 gfc_component
*comp
;
1038 gfc_component
*pick
;
1040 comp
= ref
->u
.c
.sym
->components
;
1041 pick
= ref
->u
.c
.component
;
1042 while (comp
!= pick
)
1052 /* Replace an expression with the contents of a constructor, removing
1053 the subobject reference in the process. */
1056 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1062 e
->ref
= p
->ref
->next
;
1063 p
->ref
->next
= NULL
;
1064 gfc_replace_expr (p
, e
);
1068 /* Pull an array section out of an array constructor. */
1071 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1077 long unsigned one
= 1;
1079 mpz_t start
[GFC_MAX_DIMENSIONS
];
1080 mpz_t end
[GFC_MAX_DIMENSIONS
];
1081 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1082 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1083 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1089 gfc_constructor
*cons
;
1090 gfc_constructor
*base
;
1096 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1101 base
= expr
->value
.constructor
;
1102 expr
->value
.constructor
= NULL
;
1104 rank
= ref
->u
.ar
.as
->rank
;
1106 if (expr
->shape
== NULL
)
1107 expr
->shape
= gfc_get_shape (rank
);
1109 mpz_init_set_ui (delta_mpz
, one
);
1110 mpz_init_set_ui (nelts
, one
);
1113 /* Do the initialization now, so that we can cleanup without
1114 keeping track of where we were. */
1115 for (d
= 0; d
< rank
; d
++)
1117 mpz_init (delta
[d
]);
1118 mpz_init (start
[d
]);
1121 mpz_init (stride
[d
]);
1125 /* Build the counters to clock through the array reference. */
1127 for (d
= 0; d
< rank
; d
++)
1129 /* Make this stretch of code easier on the eye! */
1130 begin
= ref
->u
.ar
.start
[d
];
1131 finish
= ref
->u
.ar
.end
[d
];
1132 step
= ref
->u
.ar
.stride
[d
];
1133 lower
= ref
->u
.ar
.as
->lower
[d
];
1134 upper
= ref
->u
.ar
.as
->upper
[d
];
1136 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1140 if (begin
->expr_type
!= EXPR_ARRAY
)
1146 gcc_assert (begin
->rank
== 1);
1147 gcc_assert (begin
->shape
);
1149 vecsub
[d
] = begin
->value
.constructor
;
1150 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1151 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1152 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1155 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1157 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1158 || mpz_cmp (c
->expr
->value
.integer
,
1159 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
]);
1170 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1171 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1172 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1178 /* Obtain the stride. */
1180 mpz_set (stride
[d
], step
->value
.integer
);
1182 mpz_set_ui (stride
[d
], one
);
1184 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1185 mpz_set_ui (stride
[d
], one
);
1187 /* Obtain the start value for the index. */
1189 mpz_set (start
[d
], begin
->value
.integer
);
1191 mpz_set (start
[d
], lower
->value
.integer
);
1193 mpz_set (ctr
[d
], start
[d
]);
1195 /* Obtain the end value for the index. */
1197 mpz_set (end
[d
], finish
->value
.integer
);
1199 mpz_set (end
[d
], upper
->value
.integer
);
1201 /* Separate 'if' because elements sometimes arrive with
1203 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1204 mpz_set (end
[d
], begin
->value
.integer
);
1206 /* Check the bounds. */
1207 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1208 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1209 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1210 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1212 gfc_error ("index in dimension %d is out of bounds "
1213 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1218 /* Calculate the number of elements and the shape. */
1219 mpz_set (tmp_mpz
, stride
[d
]);
1220 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1221 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1222 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1223 mpz_mul (nelts
, nelts
, tmp_mpz
);
1225 /* An element reference reduces the rank of the expression; don't
1226 add anything to the shape array. */
1227 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1228 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1231 /* Calculate the 'stride' (=delta) for conversion of the
1232 counter values into the index along the constructor. */
1233 mpz_set (delta
[d
], delta_mpz
);
1234 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1235 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1236 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1243 /* Now clock through the array reference, calculating the index in
1244 the source constructor and transferring the elements to the new
1246 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1248 if (ref
->u
.ar
.offset
)
1249 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1251 mpz_init_set_ui (ptr
, 0);
1254 for (d
= 0; d
< rank
; d
++)
1256 mpz_set (tmp_mpz
, ctr
[d
]);
1257 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1258 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1259 mpz_add (ptr
, ptr
, tmp_mpz
);
1261 if (!incr_ctr
) continue;
1263 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1265 gcc_assert(vecsub
[d
]);
1267 if (!vecsub
[d
]->next
)
1268 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1271 vecsub
[d
] = vecsub
[d
]->next
;
1274 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1278 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1280 if (mpz_cmp_ui (stride
[d
], 0) > 0
1281 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1282 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1283 mpz_set (ctr
[d
], start
[d
]);
1289 /* There must be a better way of dealing with negative strides
1290 than resetting the index and the constructor pointer! */
1291 if (mpz_cmp (ptr
, index
) < 0)
1293 mpz_set_ui (index
, 0);
1297 while (mpz_cmp (ptr
, index
) > 0)
1299 mpz_add_ui (index
, index
, one
);
1303 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1311 mpz_clear (delta_mpz
);
1312 mpz_clear (tmp_mpz
);
1314 for (d
= 0; d
< rank
; d
++)
1316 mpz_clear (delta
[d
]);
1317 mpz_clear (start
[d
]);
1320 mpz_clear (stride
[d
]);
1322 gfc_free_constructor (base
);
1326 /* Pull a substring out of an expression. */
1329 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1335 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1336 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1339 *newp
= gfc_copy_expr (p
);
1340 chr
= p
->value
.character
.string
;
1341 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1342 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1344 (*newp
)->value
.character
.length
= end
- start
+ 1;
1345 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1346 (*newp
)->value
.character
.length
);
1352 /* Simplify a subobject reference of a constructor. This occurs when
1353 parameter variable values are substituted. */
1356 simplify_const_ref (gfc_expr
*p
)
1358 gfc_constructor
*cons
;
1363 switch (p
->ref
->type
)
1366 switch (p
->ref
->u
.ar
.type
)
1369 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1376 remove_subobject_ref (p
, cons
);
1380 if (find_array_section (p
, p
->ref
) == FAILURE
)
1382 p
->ref
->u
.ar
.type
= AR_FULL
;
1387 if (p
->ref
->next
!= NULL
1388 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1390 cons
= p
->value
.constructor
;
1391 for (; cons
; cons
= cons
->next
)
1393 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1394 simplify_const_ref (cons
->expr
);
1397 gfc_free_ref_list (p
->ref
);
1408 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1409 remove_subobject_ref (p
, cons
);
1413 if (find_substring_ref (p
, &newp
) == FAILURE
)
1416 gfc_replace_expr (p
, newp
);
1417 gfc_free_ref_list (p
->ref
);
1427 /* Simplify a chain of references. */
1430 simplify_ref_chain (gfc_ref
*ref
, int type
)
1434 for (; ref
; ref
= ref
->next
)
1439 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1441 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1443 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1445 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1451 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1453 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1465 /* Try to substitute the value of a parameter variable. */
1468 simplify_parameter_variable (gfc_expr
*p
, int type
)
1473 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1479 /* Do not copy subobject refs for constant. */
1480 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1481 e
->ref
= copy_ref (p
->ref
);
1482 t
= gfc_simplify_expr (e
, type
);
1484 /* Only use the simplification if it eliminated all subobject references. */
1485 if (t
== SUCCESS
&& !e
->ref
)
1486 gfc_replace_expr (p
, e
);
1493 /* Given an expression, simplify it by collapsing constant
1494 expressions. Most simplification takes place when the expression
1495 tree is being constructed. If an intrinsic function is simplified
1496 at some point, we get called again to collapse the result against
1499 We work by recursively simplifying expression nodes, simplifying
1500 intrinsic functions where possible, which can lead to further
1501 constant collapsing. If an operator has constant operand(s), we
1502 rip the expression apart, and rebuild it, hoping that it becomes
1505 The expression type is defined for:
1506 0 Basic expression parsing
1507 1 Simplifying array constructors -- will substitute
1509 Returns FAILURE on error, SUCCESS otherwise.
1510 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1513 gfc_simplify_expr (gfc_expr
*p
, int type
)
1515 gfc_actual_arglist
*ap
;
1520 switch (p
->expr_type
)
1527 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1528 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1531 if (p
->value
.function
.isym
!= NULL
1532 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1537 case EXPR_SUBSTRING
:
1538 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1541 if (gfc_is_constant_expr (p
))
1546 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1547 start
--; /* Convert from one-based to zero-based. */
1548 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1549 s
= gfc_getmem (end
- start
+ 2);
1550 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1551 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1552 gfc_free (p
->value
.character
.string
);
1553 p
->value
.character
.string
= s
;
1554 p
->value
.character
.length
= end
- start
;
1555 p
->ts
.cl
= gfc_get_charlen ();
1556 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1557 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1558 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1559 gfc_free_ref_list (p
->ref
);
1561 p
->expr_type
= EXPR_CONSTANT
;
1566 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1571 /* Only substitute array parameter variables if we are in an
1572 initialization expression, or we want a subsection. */
1573 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1574 && (gfc_init_expr
|| p
->ref
1575 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1577 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1584 gfc_simplify_iterator_var (p
);
1587 /* Simplify subcomponent references. */
1588 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1593 case EXPR_STRUCTURE
:
1595 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1598 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1601 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1602 && p
->ref
->u
.ar
.type
== AR_FULL
)
1603 gfc_expand_constructor (p
);
1605 if (simplify_const_ref (p
) == FAILURE
)
1615 /* Returns the type of an expression with the exception that iterator
1616 variables are automatically integers no matter what else they may
1622 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1629 /* Check an intrinsic arithmetic operation to see if it is consistent
1630 with some type of expression. */
1632 static try check_init_expr (gfc_expr
*);
1635 /* Scalarize an expression for an elemental intrinsic call. */
1638 scalarize_intrinsic_call (gfc_expr
*e
)
1640 gfc_actual_arglist
*a
, *b
;
1641 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1642 gfc_expr
*expr
, *old
;
1645 old
= gfc_copy_expr (e
);
1647 /* Assume that the old expression carries the type information and
1648 that the first arg carries all the shape information. */
1649 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1650 gfc_free_constructor (expr
->value
.constructor
);
1651 expr
->value
.constructor
= NULL
;
1654 expr
->expr_type
= EXPR_ARRAY
;
1656 /* Copy the array argument constructors into an array, with nulls
1659 a
= old
->value
.function
.actual
;
1660 for (; a
; a
= a
->next
)
1662 /* Check that this is OK for an initialization expression. */
1663 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1667 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1669 rank
[n
] = a
->expr
->rank
;
1670 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1671 args
[n
] = gfc_copy_constructor (ctor
);
1673 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1676 rank
[n
] = a
->expr
->rank
;
1679 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1686 for (i
= 1; i
< n
; i
++)
1687 if (rank
[i
] && rank
[i
] != rank
[0])
1690 /* Using the first argument as the master, step through the array
1691 calling the function for each element and advancing the array
1692 constructors together. */
1695 for (; ctor
; ctor
= ctor
->next
)
1697 if (expr
->value
.constructor
== NULL
)
1698 expr
->value
.constructor
1699 = new_ctor
= gfc_get_constructor ();
1702 new_ctor
->next
= gfc_get_constructor ();
1703 new_ctor
= new_ctor
->next
;
1705 new_ctor
->expr
= gfc_copy_expr (old
);
1706 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1708 b
= old
->value
.function
.actual
;
1709 for (i
= 0; i
< n
; i
++)
1712 new_ctor
->expr
->value
.function
.actual
1713 = a
= gfc_get_actual_arglist ();
1716 a
->next
= gfc_get_actual_arglist ();
1720 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1722 a
->expr
= gfc_copy_expr (b
->expr
);
1727 /* Simplify the function calls. */
1728 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1731 for (i
= 0; i
< n
; i
++)
1733 args
[i
] = args
[i
]->next
;
1735 for (i
= 1; i
< n
; i
++)
1736 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1737 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1743 gfc_free_expr (old
);
1747 gfc_error_now ("elemental function arguments at %C are not compliant");
1750 gfc_free_expr (expr
);
1751 gfc_free_expr (old
);
1757 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1759 gfc_expr
*op1
= e
->value
.op
.op1
;
1760 gfc_expr
*op2
= e
->value
.op
.op2
;
1762 if ((*check_function
) (op1
) == FAILURE
)
1765 switch (e
->value
.op
.operator)
1767 case INTRINSIC_UPLUS
:
1768 case INTRINSIC_UMINUS
:
1769 if (!numeric_type (et0 (op1
)))
1774 case INTRINSIC_EQ_OS
:
1776 case INTRINSIC_NE_OS
:
1778 case INTRINSIC_GT_OS
:
1780 case INTRINSIC_GE_OS
:
1782 case INTRINSIC_LT_OS
:
1784 case INTRINSIC_LE_OS
:
1785 if ((*check_function
) (op2
) == FAILURE
)
1788 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1789 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1791 gfc_error ("Numeric or CHARACTER operands are required in "
1792 "expression at %L", &e
->where
);
1797 case INTRINSIC_PLUS
:
1798 case INTRINSIC_MINUS
:
1799 case INTRINSIC_TIMES
:
1800 case INTRINSIC_DIVIDE
:
1801 case INTRINSIC_POWER
:
1802 if ((*check_function
) (op2
) == FAILURE
)
1805 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1808 if (e
->value
.op
.operator == INTRINSIC_POWER
1809 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1811 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1812 "exponent in an initialization "
1813 "expression at %L", &op2
->where
)
1820 case INTRINSIC_CONCAT
:
1821 if ((*check_function
) (op2
) == FAILURE
)
1824 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1826 gfc_error ("Concatenation operator in expression at %L "
1827 "must have two CHARACTER operands", &op1
->where
);
1831 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1833 gfc_error ("Concat operator at %L must concatenate strings of the "
1834 "same kind", &e
->where
);
1841 if (et0 (op1
) != BT_LOGICAL
)
1843 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1844 "operand", &op1
->where
);
1853 case INTRINSIC_NEQV
:
1854 if ((*check_function
) (op2
) == FAILURE
)
1857 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1859 gfc_error ("LOGICAL operands are required in expression at %L",
1866 case INTRINSIC_PARENTHESES
:
1870 gfc_error ("Only intrinsic operators can be used in expression at %L",
1878 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1885 check_init_expr_arguments (gfc_expr
*e
)
1887 gfc_actual_arglist
*ap
;
1889 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1890 if (check_init_expr (ap
->expr
) == FAILURE
)
1896 /* F95, 7.1.6.1, Initialization expressions, (7)
1897 F2003, 7.1.7 Initialization expression, (8) */
1900 check_inquiry (gfc_expr
*e
, int not_restricted
)
1903 const char *const *functions
;
1905 static const char *const inquiry_func_f95
[] = {
1906 "lbound", "shape", "size", "ubound",
1907 "bit_size", "len", "kind",
1908 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1909 "precision", "radix", "range", "tiny",
1913 static const char *const inquiry_func_f2003
[] = {
1914 "lbound", "shape", "size", "ubound",
1915 "bit_size", "len", "kind",
1916 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1917 "precision", "radix", "range", "tiny",
1922 gfc_actual_arglist
*ap
;
1924 if (!e
->value
.function
.isym
1925 || !e
->value
.function
.isym
->inquiry
)
1928 /* An undeclared parameter will get us here (PR25018). */
1929 if (e
->symtree
== NULL
)
1932 name
= e
->symtree
->n
.sym
->name
;
1934 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1935 ? inquiry_func_f2003
: inquiry_func_f95
;
1937 for (i
= 0; functions
[i
]; i
++)
1938 if (strcmp (functions
[i
], name
) == 0)
1941 if (functions
[i
] == NULL
)
1943 gfc_error ("Inquiry function '%s' at %L is not permitted "
1944 "in an initialization expression", name
, &e
->where
);
1948 /* At this point we have an inquiry function with a variable argument. The
1949 type of the variable might be undefined, but we need it now, because the
1950 arguments of these functions are not allowed to be undefined. */
1952 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1957 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
1959 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1960 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
1964 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
1967 /* Assumed character length will not reduce to a constant expression
1968 with LEN, as required by the standard. */
1969 if (i
== 5 && not_restricted
1970 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1971 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1973 gfc_error ("assumed character length variable '%s' in constant "
1974 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
1977 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
1985 /* F95, 7.1.6.1, Initialization expressions, (5)
1986 F2003, 7.1.7 Initialization expression, (5) */
1989 check_transformational (gfc_expr
*e
)
1991 static const char * const trans_func_f95
[] = {
1992 "repeat", "reshape", "selected_int_kind",
1993 "selected_real_kind", "transfer", "trim", NULL
1999 if (!e
->value
.function
.isym
2000 || !e
->value
.function
.isym
->transformational
)
2003 name
= e
->symtree
->n
.sym
->name
;
2005 /* NULL() is dealt with below. */
2006 if (strcmp ("null", name
) == 0)
2009 for (i
= 0; trans_func_f95
[i
]; i
++)
2010 if (strcmp (trans_func_f95
[i
], name
) == 0)
2013 /* FIXME, F2003: implement translation of initialization
2014 expressions before enabling this check. For F95, error
2015 out if the transformational function is not in the list. */
2017 if (trans_func_f95
[i
] == NULL
2018 && gfc_notify_std (GFC_STD_F2003
,
2019 "transformational intrinsic '%s' at %L is not permitted "
2020 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2023 if (trans_func_f95
[i
] == NULL
)
2025 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2026 "in an initialization expression", name
, &e
->where
);
2031 return check_init_expr_arguments (e
);
2035 /* F95, 7.1.6.1, Initialization expressions, (6)
2036 F2003, 7.1.7 Initialization expression, (6) */
2039 check_null (gfc_expr
*e
)
2041 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2044 return check_init_expr_arguments (e
);
2049 check_elemental (gfc_expr
*e
)
2051 if (!e
->value
.function
.isym
2052 || !e
->value
.function
.isym
->elemental
)
2055 if ((e
->ts
.type
!= BT_INTEGER
|| e
->ts
.type
!= BT_CHARACTER
)
2056 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2057 "nonstandard initialization expression at %L",
2058 &e
->where
) == FAILURE
)
2061 return check_init_expr_arguments (e
);
2066 check_conversion (gfc_expr
*e
)
2068 if (!e
->value
.function
.isym
2069 || !e
->value
.function
.isym
->conversion
)
2072 return check_init_expr_arguments (e
);
2076 /* Verify that an expression is an initialization expression. A side
2077 effect is that the expression tree is reduced to a single constant
2078 node if all goes well. This would normally happen when the
2079 expression is constructed but function references are assumed to be
2080 intrinsics in the context of initialization expressions. If
2081 FAILURE is returned an error message has been generated. */
2084 check_init_expr (gfc_expr
*e
)
2088 gfc_intrinsic_sym
*isym
;
2093 switch (e
->expr_type
)
2096 t
= check_intrinsic_op (e
, check_init_expr
);
2098 t
= gfc_simplify_expr (e
, 0);
2105 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2107 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2109 gfc_error ("Function '%s' in initialization expression at %L "
2110 "must be an intrinsic or a specification function",
2111 e
->symtree
->n
.sym
->name
, &e
->where
);
2115 if ((m
= check_conversion (e
)) == MATCH_NO
2116 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2117 && (m
= check_null (e
)) == MATCH_NO
2118 && (m
= check_transformational (e
)) == MATCH_NO
2119 && (m
= check_elemental (e
)) == MATCH_NO
)
2121 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2122 "in an initialization expression",
2123 e
->symtree
->n
.sym
->name
, &e
->where
);
2127 /* Try to scalarize an elemental intrinsic function that has an
2129 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2130 if (isym
&& isym
->elemental
2131 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2133 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2139 t
= gfc_simplify_expr (e
, 0);
2146 if (gfc_check_iter_variable (e
) == SUCCESS
)
2149 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2151 t
= simplify_parameter_variable (e
, 0);
2155 if (gfc_in_match_data ())
2160 if (e
->symtree
->n
.sym
->as
)
2162 switch (e
->symtree
->n
.sym
->as
->type
)
2164 case AS_ASSUMED_SIZE
:
2165 gfc_error ("assumed size array '%s' at %L is not permitted "
2166 "in an initialization expression",
2167 e
->symtree
->n
.sym
->name
, &e
->where
);
2170 case AS_ASSUMED_SHAPE
:
2171 gfc_error ("assumed shape array '%s' at %L is not permitted "
2172 "in an initialization expression",
2173 e
->symtree
->n
.sym
->name
, &e
->where
);
2177 gfc_error ("deferred array '%s' at %L is not permitted "
2178 "in an initialization expression",
2179 e
->symtree
->n
.sym
->name
, &e
->where
);
2187 gfc_error ("Parameter '%s' at %L has not been declared or is "
2188 "a variable, which does not reduce to a constant "
2189 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2198 case EXPR_SUBSTRING
:
2199 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2203 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2205 t
= gfc_simplify_expr (e
, 0);
2209 case EXPR_STRUCTURE
:
2210 t
= gfc_check_constructor (e
, check_init_expr
);
2214 t
= gfc_check_constructor (e
, check_init_expr
);
2218 t
= gfc_expand_constructor (e
);
2222 t
= gfc_check_constructor_type (e
);
2226 gfc_internal_error ("check_init_expr(): Unknown expression type");
2233 /* Match an initialization expression. We work by first matching an
2234 expression, then reducing it to a constant. */
2237 gfc_match_init_expr (gfc_expr
**result
)
2243 m
= gfc_match_expr (&expr
);
2248 t
= gfc_resolve_expr (expr
);
2250 t
= check_init_expr (expr
);
2255 gfc_free_expr (expr
);
2259 if (expr
->expr_type
== EXPR_ARRAY
2260 && (gfc_check_constructor_type (expr
) == FAILURE
2261 || gfc_expand_constructor (expr
) == FAILURE
))
2263 gfc_free_expr (expr
);
2267 /* Not all inquiry functions are simplified to constant expressions
2268 so it is necessary to call check_inquiry again. */
2269 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2270 && !gfc_in_match_data ())
2272 gfc_error ("Initialization expression didn't reduce %C");
2282 static try check_restricted (gfc_expr
*);
2284 /* Given an actual argument list, test to see that each argument is a
2285 restricted expression and optionally if the expression type is
2286 integer or character. */
2289 restricted_args (gfc_actual_arglist
*a
)
2291 for (; a
; a
= a
->next
)
2293 if (check_restricted (a
->expr
) == FAILURE
)
2301 /************* Restricted/specification expressions *************/
2304 /* Make sure a non-intrinsic function is a specification function. */
2307 external_spec_function (gfc_expr
*e
)
2311 f
= e
->value
.function
.esym
;
2313 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2315 gfc_error ("Specification function '%s' at %L cannot be a statement "
2316 "function", f
->name
, &e
->where
);
2320 if (f
->attr
.proc
== PROC_INTERNAL
)
2322 gfc_error ("Specification function '%s' at %L cannot be an internal "
2323 "function", f
->name
, &e
->where
);
2327 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2329 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2334 if (f
->attr
.recursive
)
2336 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2337 f
->name
, &e
->where
);
2341 return restricted_args (e
->value
.function
.actual
);
2345 /* Check to see that a function reference to an intrinsic is a
2346 restricted expression. */
2349 restricted_intrinsic (gfc_expr
*e
)
2351 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2352 if (check_inquiry (e
, 0) == MATCH_YES
)
2355 return restricted_args (e
->value
.function
.actual
);
2359 /* Verify that an expression is a restricted expression. Like its
2360 cousin check_init_expr(), an error message is generated if we
2364 check_restricted (gfc_expr
*e
)
2372 switch (e
->expr_type
)
2375 t
= check_intrinsic_op (e
, check_restricted
);
2377 t
= gfc_simplify_expr (e
, 0);
2382 t
= e
->value
.function
.esym
? external_spec_function (e
)
2383 : restricted_intrinsic (e
);
2387 sym
= e
->symtree
->n
.sym
;
2390 if (sym
->attr
.optional
)
2392 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2393 sym
->name
, &e
->where
);
2397 if (sym
->attr
.intent
== INTENT_OUT
)
2399 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2400 sym
->name
, &e
->where
);
2404 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2405 processed in resolve.c(resolve_formal_arglist). This is done so
2406 that host associated dummy array indices are accepted (PR23446).
2407 This mechanism also does the same for the specification expressions
2408 of array-valued functions. */
2409 if (sym
->attr
.in_common
2410 || sym
->attr
.use_assoc
2412 || sym
->ns
!= gfc_current_ns
2413 || (sym
->ns
->proc_name
!= NULL
2414 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2415 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2421 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2422 sym
->name
, &e
->where
);
2431 case EXPR_SUBSTRING
:
2432 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2436 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2438 t
= gfc_simplify_expr (e
, 0);
2442 case EXPR_STRUCTURE
:
2443 t
= gfc_check_constructor (e
, check_restricted
);
2447 t
= gfc_check_constructor (e
, check_restricted
);
2451 gfc_internal_error ("check_restricted(): Unknown expression type");
2458 /* Check to see that an expression is a specification expression. If
2459 we return FAILURE, an error has been generated. */
2462 gfc_specification_expr (gfc_expr
*e
)
2468 if (e
->ts
.type
!= BT_INTEGER
)
2470 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2476 gfc_error ("Expression at %L must be scalar", &e
->where
);
2480 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2483 return check_restricted (e
);
2487 /************** Expression conformance checks. *************/
2489 /* Given two expressions, make sure that the arrays are conformable. */
2492 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2494 int op1_flag
, op2_flag
, d
;
2495 mpz_t op1_size
, op2_size
;
2498 if (op1
->rank
== 0 || op2
->rank
== 0)
2501 if (op1
->rank
!= op2
->rank
)
2503 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2510 for (d
= 0; d
< op1
->rank
; d
++)
2512 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2513 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2515 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2517 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2518 _(optype_msgid
), &op1
->where
, d
+ 1,
2519 (int) mpz_get_si (op1_size
),
2520 (int) mpz_get_si (op2_size
));
2526 mpz_clear (op1_size
);
2528 mpz_clear (op2_size
);
2538 /* Given an assignable expression and an arbitrary expression, make
2539 sure that the assignment can take place. */
2542 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2548 sym
= lvalue
->symtree
->n
.sym
;
2550 /* Check INTENT(IN), unless the object itself is the component or
2551 sub-component of a pointer. */
2552 has_pointer
= sym
->attr
.pointer
;
2554 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2555 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2561 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2563 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2564 sym
->name
, &lvalue
->where
);
2568 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2569 variable local to a function subprogram. Its existence begins when
2570 execution of the function is initiated and ends when execution of the
2571 function is terminated...
2572 Therefore, the left hand side is no longer a variable, when it is: */
2573 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2574 && !sym
->attr
.external
)
2579 /* (i) Use associated; */
2580 if (sym
->attr
.use_assoc
)
2583 /* (ii) The assignment is in the main program; or */
2584 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2587 /* (iii) A module or internal procedure... */
2588 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2589 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2590 && gfc_current_ns
->parent
2591 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2592 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2593 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2595 /* ... that is not a function... */
2596 if (!gfc_current_ns
->proc_name
->attr
.function
)
2599 /* ... or is not an entry and has a different name. */
2600 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2606 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2611 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2613 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2614 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2618 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2620 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2625 if (rvalue
->expr_type
== EXPR_NULL
)
2627 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2628 && lvalue
->symtree
->n
.sym
->attr
.data
)
2632 gfc_error ("NULL appears on right-hand side in assignment at %L",
2638 if (sym
->attr
.cray_pointee
2639 && lvalue
->ref
!= NULL
2640 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2641 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2643 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2644 "is illegal", &lvalue
->where
);
2648 /* This is possibly a typo: x = f() instead of x => f(). */
2649 if (gfc_option
.warn_surprising
2650 && rvalue
->expr_type
== EXPR_FUNCTION
2651 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2652 gfc_warning ("POINTER valued function appears on right-hand side of "
2653 "assignment at %L", &rvalue
->where
);
2655 /* Check size of array assignments. */
2656 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2657 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2660 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2665 /* Numeric can be converted to any other numeric. And Hollerith can be
2666 converted to any other type. */
2667 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2668 || rvalue
->ts
.type
== BT_HOLLERITH
)
2671 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2674 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2675 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2676 gfc_typename (&lvalue
->ts
));
2681 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2685 /* Check that a pointer assignment is OK. We first check lvalue, and
2686 we only check rvalue if it's not an assignment to NULL() or a
2687 NULLIFY statement. */
2690 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2692 symbol_attribute attr
;
2695 int pointer
, check_intent_in
;
2697 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2699 gfc_error ("Pointer assignment target is not a POINTER at %L",
2704 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2705 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2707 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2708 "l-value since it is a procedure",
2709 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2714 /* Check INTENT(IN), unless the object itself is the component or
2715 sub-component of a pointer. */
2716 check_intent_in
= 1;
2717 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2719 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2722 check_intent_in
= 0;
2724 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2728 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2730 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2731 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2737 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2741 is_pure
= gfc_pure (NULL
);
2743 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2745 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2749 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2750 kind, etc for lvalue and rvalue must match, and rvalue must be a
2751 pure variable if we're in a pure function. */
2752 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2755 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2757 gfc_error ("Different types in pointer assignment at %L",
2762 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2764 gfc_error ("Different kind type parameters in pointer "
2765 "assignment at %L", &lvalue
->where
);
2769 if (lvalue
->rank
!= rvalue
->rank
)
2771 gfc_error ("Different ranks in pointer assignment at %L",
2776 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2777 if (rvalue
->expr_type
== EXPR_NULL
)
2780 if (lvalue
->ts
.type
== BT_CHARACTER
2781 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2782 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2783 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2784 rvalue
->ts
.cl
->length
)) == 1)
2786 gfc_error ("Different character lengths in pointer "
2787 "assignment at %L", &lvalue
->where
);
2791 attr
= gfc_expr_attr (rvalue
);
2792 if (!attr
.target
&& !attr
.pointer
)
2794 gfc_error ("Pointer assignment target is neither TARGET "
2795 "nor POINTER at %L", &rvalue
->where
);
2799 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2801 gfc_error ("Bad target in pointer assignment in PURE "
2802 "procedure at %L", &rvalue
->where
);
2805 if (gfc_has_vector_index (rvalue
))
2807 gfc_error ("Pointer assignment with vector subscript "
2808 "on rhs at %L", &rvalue
->where
);
2812 if (attr
.protected && attr
.use_assoc
)
2814 gfc_error ("Pointer assigment target has PROTECTED "
2815 "attribute at %L", &rvalue
->where
);
2823 /* Relative of gfc_check_assign() except that the lvalue is a single
2824 symbol. Used for initialization assignments. */
2827 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2832 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2834 lvalue
.expr_type
= EXPR_VARIABLE
;
2835 lvalue
.ts
= sym
->ts
;
2837 lvalue
.rank
= sym
->as
->rank
;
2838 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2839 lvalue
.symtree
->n
.sym
= sym
;
2840 lvalue
.where
= sym
->declared_at
;
2842 if (sym
->attr
.pointer
)
2843 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2845 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2847 gfc_free (lvalue
.symtree
);
2853 /* Get an expression for a default initializer. */
2856 gfc_default_initializer (gfc_typespec
*ts
)
2858 gfc_constructor
*tail
;
2864 /* See if we have a default initializer. */
2865 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2867 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2868 init
= gfc_get_expr ();
2874 /* Build the constructor. */
2875 init
->expr_type
= EXPR_STRUCTURE
;
2877 init
->where
= ts
->derived
->declared_at
;
2879 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2882 init
->value
.constructor
= tail
= gfc_get_constructor ();
2885 tail
->next
= gfc_get_constructor ();
2890 tail
->expr
= gfc_copy_expr (c
->initializer
);
2894 tail
->expr
= gfc_get_expr ();
2895 tail
->expr
->expr_type
= EXPR_NULL
;
2896 tail
->expr
->ts
= c
->ts
;
2903 /* Given a symbol, create an expression node with that symbol as a
2904 variable. If the symbol is array valued, setup a reference of the
2908 gfc_get_variable_expr (gfc_symtree
*var
)
2912 e
= gfc_get_expr ();
2913 e
->expr_type
= EXPR_VARIABLE
;
2915 e
->ts
= var
->n
.sym
->ts
;
2917 if (var
->n
.sym
->as
!= NULL
)
2919 e
->rank
= var
->n
.sym
->as
->rank
;
2920 e
->ref
= gfc_get_ref ();
2921 e
->ref
->type
= REF_ARRAY
;
2922 e
->ref
->u
.ar
.type
= AR_FULL
;
2929 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2932 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2934 gfc_actual_arglist
*arg
;
2941 switch (expr
->expr_type
)
2944 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2945 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2949 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2950 gfc_expr_set_symbols_referenced (arg
->expr
);
2954 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2959 case EXPR_SUBSTRING
:
2962 case EXPR_STRUCTURE
:
2964 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2965 gfc_expr_set_symbols_referenced (c
->expr
);
2973 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2977 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2979 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2980 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2981 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2989 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2990 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);