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
)
145 gfc_free (e
->value
.character
.string
);
152 mpz_clear (e
->value
.integer
);
156 mpfr_clear (e
->value
.real
);
161 gfc_free (e
->value
.character
.string
);
165 mpfr_clear (e
->value
.complex.r
);
166 mpfr_clear (e
->value
.complex.i
);
176 if (e
->value
.op
.op1
!= NULL
)
177 gfc_free_expr (e
->value
.op
.op1
);
178 if (e
->value
.op
.op2
!= NULL
)
179 gfc_free_expr (e
->value
.op
.op2
);
183 gfc_free_actual_arglist (e
->value
.function
.actual
);
191 gfc_free_constructor (e
->value
.constructor
);
195 gfc_free (e
->value
.character
.string
);
202 gfc_internal_error ("free_expr0(): Bad expr type");
205 /* Free a shape array. */
206 if (e
->shape
!= NULL
)
208 for (n
= 0; n
< e
->rank
; n
++)
209 mpz_clear (e
->shape
[n
]);
214 gfc_free_ref_list (e
->ref
);
216 memset (e
, '\0', sizeof (gfc_expr
));
220 /* Free an expression node and everything beneath it. */
223 gfc_free_expr (gfc_expr
*e
)
227 if (e
->con_by_offset
)
228 splay_tree_delete (e
->con_by_offset
);
234 /* Graft the *src expression onto the *dest subexpression. */
237 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
245 /* Try to extract an integer constant from the passed expression node.
246 Returns an error message or NULL if the result is set. It is
247 tempting to generate an error and return SUCCESS or FAILURE, but
248 failure is OK for some callers. */
251 gfc_extract_int (gfc_expr
*expr
, int *result
)
253 if (expr
->expr_type
!= EXPR_CONSTANT
)
254 return _("Constant expression required at %C");
256 if (expr
->ts
.type
!= BT_INTEGER
)
257 return _("Integer expression required at %C");
259 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
260 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
262 return _("Integer value too large in expression at %C");
265 *result
= (int) mpz_get_si (expr
->value
.integer
);
271 /* Recursively copy a list of reference structures. */
274 copy_ref (gfc_ref
*src
)
282 dest
= gfc_get_ref ();
283 dest
->type
= src
->type
;
288 ar
= gfc_copy_array_ref (&src
->u
.ar
);
294 dest
->u
.c
= src
->u
.c
;
298 dest
->u
.ss
= src
->u
.ss
;
299 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
300 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
304 dest
->next
= copy_ref (src
->next
);
310 /* Detect whether an expression has any vector index array references. */
313 gfc_has_vector_index (gfc_expr
*e
)
317 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
318 if (ref
->type
== REF_ARRAY
)
319 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
320 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
326 /* Copy a shape array. */
329 gfc_copy_shape (mpz_t
*shape
, int rank
)
337 new_shape
= gfc_get_shape (rank
);
339 for (n
= 0; n
< rank
; n
++)
340 mpz_init_set (new_shape
[n
], shape
[n
]);
346 /* Copy a shape array excluding dimension N, where N is an integer
347 constant expression. Dimensions are numbered in fortran style --
350 So, if the original shape array contains R elements
351 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
352 the result contains R-1 elements:
353 { s1 ... sN-1 sN+1 ... sR-1}
355 If anything goes wrong -- N is not a constant, its value is out
356 of range -- or anything else, just returns NULL.
360 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
362 mpz_t
*new_shape
, *s
;
368 || dim
->expr_type
!= EXPR_CONSTANT
369 || dim
->ts
.type
!= BT_INTEGER
)
372 n
= mpz_get_si (dim
->value
.integer
);
373 n
--; /* Convert to zero based index */
374 if (n
< 0 || n
>= rank
)
377 s
= new_shape
= gfc_get_shape (rank
- 1);
379 for (i
= 0; i
< rank
; i
++)
383 mpz_init_set (*s
, shape
[i
]);
391 /* Given an expression pointer, return a copy of the expression. This
392 subroutine is recursive. */
395 gfc_copy_expr (gfc_expr
*p
)
406 switch (q
->expr_type
)
409 s
= gfc_getmem (p
->value
.character
.length
+ 1);
410 q
->value
.character
.string
= s
;
412 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
418 s
= gfc_getmem (p
->value
.character
.length
+ 1);
419 q
->value
.character
.string
= s
;
421 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
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
);
446 s
= gfc_getmem (p
->value
.character
.length
+ 1);
447 q
->value
.character
.string
= s
;
449 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
454 break; /* Already done */
458 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
465 switch (q
->value
.op
.operator)
468 case INTRINSIC_PARENTHESES
:
469 case INTRINSIC_UPLUS
:
470 case INTRINSIC_UMINUS
:
471 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
474 default: /* Binary operators */
475 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
476 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
483 q
->value
.function
.actual
=
484 gfc_copy_actual_arglist (p
->value
.function
.actual
);
489 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
497 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
499 q
->ref
= copy_ref (p
->ref
);
505 /* Return the maximum kind of two expressions. In general, higher
506 kind numbers mean more precision for numeric types. */
509 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
511 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
515 /* Returns nonzero if the type is numeric, zero otherwise. */
518 numeric_type (bt type
)
520 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
524 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
527 gfc_numeric_ts (gfc_typespec
*ts
)
529 return numeric_type (ts
->type
);
533 /* Returns an expression node that is an integer constant. */
542 p
->expr_type
= EXPR_CONSTANT
;
543 p
->ts
.type
= BT_INTEGER
;
544 p
->ts
.kind
= gfc_default_integer_kind
;
546 p
->where
= gfc_current_locus
;
547 mpz_init_set_si (p
->value
.integer
, i
);
553 /* Returns an expression node that is a logical constant. */
556 gfc_logical_expr (int i
, locus
*where
)
562 p
->expr_type
= EXPR_CONSTANT
;
563 p
->ts
.type
= BT_LOGICAL
;
564 p
->ts
.kind
= gfc_default_logical_kind
;
567 where
= &gfc_current_locus
;
569 p
->value
.logical
= i
;
575 /* Return an expression node with an optional argument list attached.
576 A variable number of gfc_expr pointers are strung together in an
577 argument list with a NULL pointer terminating the list. */
580 gfc_build_conversion (gfc_expr
*e
)
585 p
->expr_type
= EXPR_FUNCTION
;
587 p
->value
.function
.actual
= NULL
;
589 p
->value
.function
.actual
= gfc_get_actual_arglist ();
590 p
->value
.function
.actual
->expr
= e
;
596 /* Given an expression node with some sort of numeric binary
597 expression, insert type conversions required to make the operands
600 The exception is that the operands of an exponential don't have to
601 have the same type. If possible, the base is promoted to the type
602 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
603 1.0**2 stays as it is. */
606 gfc_type_convert_binary (gfc_expr
*e
)
610 op1
= e
->value
.op
.op1
;
611 op2
= e
->value
.op
.op2
;
613 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
615 gfc_clear_ts (&e
->ts
);
619 /* Kind conversions of same type. */
620 if (op1
->ts
.type
== op2
->ts
.type
)
622 if (op1
->ts
.kind
== op2
->ts
.kind
)
624 /* No type conversions. */
629 if (op1
->ts
.kind
> op2
->ts
.kind
)
630 gfc_convert_type (op2
, &op1
->ts
, 2);
632 gfc_convert_type (op1
, &op2
->ts
, 2);
638 /* Integer combined with real or complex. */
639 if (op2
->ts
.type
== BT_INTEGER
)
643 /* Special case for ** operator. */
644 if (e
->value
.op
.operator == INTRINSIC_POWER
)
647 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
651 if (op1
->ts
.type
== BT_INTEGER
)
654 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
658 /* Real combined with complex. */
659 e
->ts
.type
= BT_COMPLEX
;
660 if (op1
->ts
.kind
> op2
->ts
.kind
)
661 e
->ts
.kind
= op1
->ts
.kind
;
663 e
->ts
.kind
= op2
->ts
.kind
;
664 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
665 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
666 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
667 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
674 /* Function to determine if an expression is constant or not. This
675 function expects that the expression has already been simplified. */
678 gfc_is_constant_expr (gfc_expr
*e
)
681 gfc_actual_arglist
*arg
;
687 switch (e
->expr_type
)
690 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
691 && (e
->value
.op
.op2
== NULL
692 || gfc_is_constant_expr (e
->value
.op
.op2
)));
701 /* Call to intrinsic with at least one argument. */
703 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
705 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
707 if (!gfc_is_constant_expr (arg
->expr
))
721 rv
= (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
722 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
727 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
728 if (!gfc_is_constant_expr (c
->expr
))
736 rv
= gfc_constant_ac (e
);
740 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
747 /* Try to collapse intrinsic expressions. */
750 simplify_intrinsic_op (gfc_expr
*p
, int type
)
752 gfc_expr
*op1
, *op2
, *result
;
754 if (p
->value
.op
.operator == INTRINSIC_USER
)
757 op1
= p
->value
.op
.op1
;
758 op2
= p
->value
.op
.op2
;
760 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
762 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
765 if (!gfc_is_constant_expr (op1
)
766 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
770 p
->value
.op
.op1
= NULL
;
771 p
->value
.op
.op2
= NULL
;
773 switch (p
->value
.op
.operator)
775 case INTRINSIC_PARENTHESES
:
776 result
= gfc_parentheses (op1
);
779 case INTRINSIC_UPLUS
:
780 result
= gfc_uplus (op1
);
783 case INTRINSIC_UMINUS
:
784 result
= gfc_uminus (op1
);
788 result
= gfc_add (op1
, op2
);
791 case INTRINSIC_MINUS
:
792 result
= gfc_subtract (op1
, op2
);
795 case INTRINSIC_TIMES
:
796 result
= gfc_multiply (op1
, op2
);
799 case INTRINSIC_DIVIDE
:
800 result
= gfc_divide (op1
, op2
);
803 case INTRINSIC_POWER
:
804 result
= gfc_power (op1
, op2
);
807 case INTRINSIC_CONCAT
:
808 result
= gfc_concat (op1
, op2
);
812 result
= gfc_eq (op1
, op2
);
816 result
= gfc_ne (op1
, op2
);
820 result
= gfc_gt (op1
, op2
);
824 result
= gfc_ge (op1
, op2
);
828 result
= gfc_lt (op1
, op2
);
832 result
= gfc_le (op1
, op2
);
836 result
= gfc_not (op1
);
840 result
= gfc_and (op1
, op2
);
844 result
= gfc_or (op1
, op2
);
848 result
= gfc_eqv (op1
, op2
);
852 result
= gfc_neqv (op1
, op2
);
856 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
866 result
->rank
= p
->rank
;
867 result
->where
= p
->where
;
868 gfc_replace_expr (p
, result
);
874 /* Subroutine to simplify constructor expressions. Mutually recursive
875 with gfc_simplify_expr(). */
878 simplify_constructor (gfc_constructor
*c
, int type
)
880 for (; c
; c
= c
->next
)
883 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
884 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
885 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
888 if (c
->expr
&& gfc_simplify_expr (c
->expr
, type
) == FAILURE
)
896 /* Pull a single array element out of an array constructor. */
899 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
900 gfc_constructor
**rval
)
902 unsigned long nelemen
;
914 mpz_init_set_ui (offset
, 0);
917 mpz_init_set_ui (span
, 1);
918 for (i
= 0; i
< ar
->dimen
; i
++)
920 e
= gfc_copy_expr (ar
->start
[i
]);
921 if (e
->expr_type
!= EXPR_CONSTANT
)
927 /* Check the bounds. */
929 && (mpz_cmp (e
->value
.integer
, ar
->as
->upper
[i
]->value
.integer
) > 0
930 || mpz_cmp (e
->value
.integer
,
931 ar
->as
->lower
[i
]->value
.integer
) < 0))
933 gfc_error ("index in dimension %d is out of bounds "
934 "at %L", i
+ 1, &ar
->c_where
[i
]);
940 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
941 mpz_mul (delta
, delta
, span
);
942 mpz_add (offset
, offset
, delta
);
945 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
946 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
947 mpz_mul (span
, span
, tmp
);
952 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
975 /* Find a component of a structure constructor. */
977 static gfc_constructor
*
978 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
983 comp
= ref
->u
.c
.sym
->components
;
984 pick
= ref
->u
.c
.component
;
995 /* Replace an expression with the contents of a constructor, removing
996 the subobject reference in the process. */
999 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1005 e
->ref
= p
->ref
->next
;
1006 p
->ref
->next
= NULL
;
1007 gfc_replace_expr (p
, e
);
1011 /* Pull an array section out of an array constructor. */
1014 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1020 long unsigned one
= 1;
1022 mpz_t start
[GFC_MAX_DIMENSIONS
];
1023 mpz_t end
[GFC_MAX_DIMENSIONS
];
1024 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1025 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1026 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1032 gfc_constructor
*cons
;
1033 gfc_constructor
*base
;
1039 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1044 base
= expr
->value
.constructor
;
1045 expr
->value
.constructor
= NULL
;
1047 rank
= ref
->u
.ar
.as
->rank
;
1049 if (expr
->shape
== NULL
)
1050 expr
->shape
= gfc_get_shape (rank
);
1052 mpz_init_set_ui (delta_mpz
, one
);
1053 mpz_init_set_ui (nelts
, one
);
1056 /* Do the initialization now, so that we can cleanup without
1057 keeping track of where we were. */
1058 for (d
= 0; d
< rank
; d
++)
1060 mpz_init (delta
[d
]);
1061 mpz_init (start
[d
]);
1064 mpz_init (stride
[d
]);
1068 /* Build the counters to clock through the array reference. */
1070 for (d
= 0; d
< rank
; d
++)
1072 /* Make this stretch of code easier on the eye! */
1073 begin
= ref
->u
.ar
.start
[d
];
1074 finish
= ref
->u
.ar
.end
[d
];
1075 step
= ref
->u
.ar
.stride
[d
];
1076 lower
= ref
->u
.ar
.as
->lower
[d
];
1077 upper
= ref
->u
.ar
.as
->upper
[d
];
1079 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1083 if (begin
->expr_type
!= EXPR_ARRAY
)
1089 gcc_assert (begin
->rank
== 1);
1090 gcc_assert (begin
->shape
);
1092 vecsub
[d
] = begin
->value
.constructor
;
1093 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1094 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1095 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1098 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1100 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1101 || mpz_cmp (c
->expr
->value
.integer
,
1102 lower
->value
.integer
) < 0)
1104 gfc_error ("index in dimension %d is out of bounds "
1105 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1113 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1114 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1115 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1121 /* Obtain the stride. */
1123 mpz_set (stride
[d
], step
->value
.integer
);
1125 mpz_set_ui (stride
[d
], one
);
1127 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1128 mpz_set_ui (stride
[d
], one
);
1130 /* Obtain the start value for the index. */
1132 mpz_set (start
[d
], begin
->value
.integer
);
1134 mpz_set (start
[d
], lower
->value
.integer
);
1136 mpz_set (ctr
[d
], start
[d
]);
1138 /* Obtain the end value for the index. */
1140 mpz_set (end
[d
], finish
->value
.integer
);
1142 mpz_set (end
[d
], upper
->value
.integer
);
1144 /* Separate 'if' because elements sometimes arrive with
1146 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1147 mpz_set (end
[d
], begin
->value
.integer
);
1149 /* Check the bounds. */
1150 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1151 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1152 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1153 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1155 gfc_error ("index in dimension %d is out of bounds "
1156 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1161 /* Calculate the number of elements and the shape. */
1162 mpz_set (tmp_mpz
, stride
[d
]);
1163 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1164 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1165 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1166 mpz_mul (nelts
, nelts
, tmp_mpz
);
1168 /* An element reference reduces the rank of the expression; don't
1169 add anything to the shape array. */
1170 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1171 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1174 /* Calculate the 'stride' (=delta) for conversion of the
1175 counter values into the index along the constructor. */
1176 mpz_set (delta
[d
], delta_mpz
);
1177 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1178 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1179 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1186 /* Now clock through the array reference, calculating the index in
1187 the source constructor and transferring the elements to the new
1189 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1191 if (ref
->u
.ar
.offset
)
1192 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1194 mpz_init_set_ui (ptr
, 0);
1197 for (d
= 0; d
< rank
; d
++)
1199 mpz_set (tmp_mpz
, ctr
[d
]);
1200 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1201 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1202 mpz_add (ptr
, ptr
, tmp_mpz
);
1204 if (!incr_ctr
) continue;
1206 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1208 gcc_assert(vecsub
[d
]);
1210 if (!vecsub
[d
]->next
)
1211 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1214 vecsub
[d
] = vecsub
[d
]->next
;
1217 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1221 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1223 if (mpz_cmp_ui (stride
[d
], 0) > 0
1224 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1225 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1226 mpz_set (ctr
[d
], start
[d
]);
1232 /* There must be a better way of dealing with negative strides
1233 than resetting the index and the constructor pointer! */
1234 if (mpz_cmp (ptr
, index
) < 0)
1236 mpz_set_ui (index
, 0);
1240 while (mpz_cmp (ptr
, index
) > 0)
1242 mpz_add_ui (index
, index
, one
);
1246 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1254 mpz_clear (delta_mpz
);
1255 mpz_clear (tmp_mpz
);
1257 for (d
= 0; d
< rank
; d
++)
1259 mpz_clear (delta
[d
]);
1260 mpz_clear (start
[d
]);
1263 mpz_clear (stride
[d
]);
1265 gfc_free_constructor (base
);
1269 /* Pull a substring out of an expression. */
1272 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1278 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1279 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1282 *newp
= gfc_copy_expr (p
);
1283 chr
= p
->value
.character
.string
;
1284 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1285 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1287 (*newp
)->value
.character
.length
= end
- start
+ 1;
1288 strncpy ((*newp
)->value
.character
.string
, &chr
[start
- 1],
1289 (*newp
)->value
.character
.length
);
1295 /* Simplify a subobject reference of a constructor. This occurs when
1296 parameter variable values are substituted. */
1299 simplify_const_ref (gfc_expr
*p
)
1301 gfc_constructor
*cons
;
1306 switch (p
->ref
->type
)
1309 switch (p
->ref
->u
.ar
.type
)
1312 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1319 remove_subobject_ref (p
, cons
);
1323 if (find_array_section (p
, p
->ref
) == FAILURE
)
1325 p
->ref
->u
.ar
.type
= AR_FULL
;
1330 if (p
->ref
->next
!= NULL
1331 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1333 cons
= p
->value
.constructor
;
1334 for (; cons
; cons
= cons
->next
)
1336 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1337 simplify_const_ref (cons
->expr
);
1340 gfc_free_ref_list (p
->ref
);
1351 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1352 remove_subobject_ref (p
, cons
);
1356 if (find_substring_ref (p
, &newp
) == FAILURE
)
1359 gfc_replace_expr (p
, newp
);
1360 gfc_free_ref_list (p
->ref
);
1370 /* Simplify a chain of references. */
1373 simplify_ref_chain (gfc_ref
*ref
, int type
)
1377 for (; ref
; ref
= ref
->next
)
1382 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1384 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1386 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1388 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1394 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1396 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1408 /* Try to substitute the value of a parameter variable. */
1410 simplify_parameter_variable (gfc_expr
*p
, int type
)
1415 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1421 /* Do not copy subobject refs for constant. */
1422 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1423 e
->ref
= copy_ref (p
->ref
);
1424 t
= gfc_simplify_expr (e
, type
);
1426 /* Only use the simplification if it eliminated all subobject
1428 if (t
== SUCCESS
&& !e
->ref
)
1429 gfc_replace_expr (p
, e
);
1436 /* Given an expression, simplify it by collapsing constant
1437 expressions. Most simplification takes place when the expression
1438 tree is being constructed. If an intrinsic function is simplified
1439 at some point, we get called again to collapse the result against
1442 We work by recursively simplifying expression nodes, simplifying
1443 intrinsic functions where possible, which can lead to further
1444 constant collapsing. If an operator has constant operand(s), we
1445 rip the expression apart, and rebuild it, hoping that it becomes
1448 The expression type is defined for:
1449 0 Basic expression parsing
1450 1 Simplifying array constructors -- will substitute
1452 Returns FAILURE on error, SUCCESS otherwise.
1453 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1456 gfc_simplify_expr (gfc_expr
*p
, int type
)
1458 gfc_actual_arglist
*ap
;
1463 switch (p
->expr_type
)
1470 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1471 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1474 if (p
->value
.function
.isym
!= NULL
1475 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1480 case EXPR_SUBSTRING
:
1481 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1484 if (gfc_is_constant_expr (p
))
1489 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1490 start
--; /* Convert from one-based to zero-based. */
1491 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1492 s
= gfc_getmem (end
- start
+ 2);
1493 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1494 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1495 gfc_free (p
->value
.character
.string
);
1496 p
->value
.character
.string
= s
;
1497 p
->value
.character
.length
= end
- start
;
1498 p
->ts
.cl
= gfc_get_charlen ();
1499 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1500 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1501 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1502 gfc_free_ref_list (p
->ref
);
1504 p
->expr_type
= EXPR_CONSTANT
;
1509 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1514 /* Only substitute array parameter variables if we are in an
1515 initialization expression, or we want a subsection. */
1516 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1517 && (gfc_init_expr
|| p
->ref
1518 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1520 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1527 gfc_simplify_iterator_var (p
);
1530 /* Simplify subcomponent references. */
1531 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1536 case EXPR_STRUCTURE
:
1538 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1541 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1544 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1545 && p
->ref
->u
.ar
.type
== AR_FULL
)
1546 gfc_expand_constructor (p
);
1548 if (simplify_const_ref (p
) == FAILURE
)
1558 /* Returns the type of an expression with the exception that iterator
1559 variables are automatically integers no matter what else they may
1565 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1572 /* Check an intrinsic arithmetic operation to see if it is consistent
1573 with some type of expression. */
1575 static try check_init_expr (gfc_expr
*);
1578 /* Scalarize an expression for an elemental intrinsic call. */
1581 scalarize_intrinsic_call (gfc_expr
*e
)
1583 gfc_actual_arglist
*a
, *b
;
1584 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1585 gfc_expr
*expr
, *old
;
1588 old
= gfc_copy_expr (e
);
1590 /* Assume that the old expression carries the type information and
1591 that the first arg carries all the shape information. */
1592 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1593 gfc_free_constructor (expr
->value
.constructor
);
1594 expr
->value
.constructor
= NULL
;
1597 expr
->expr_type
= EXPR_ARRAY
;
1599 /* Copy the array argument constructors into an array, with nulls
1602 a
= old
->value
.function
.actual
;
1603 for (; a
; a
= a
->next
)
1605 /* Check that this is OK for an initialization expression. */
1606 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1610 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1612 rank
[n
] = a
->expr
->rank
;
1613 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1614 args
[n
] = gfc_copy_constructor (ctor
);
1616 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1619 rank
[n
] = a
->expr
->rank
;
1622 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1629 for (i
= 1; i
< n
; i
++)
1630 if (rank
[i
] && rank
[i
] != rank
[0])
1633 /* Using the first argument as the master, step through the array
1634 calling the function for each element and advancing the array
1635 constructors together. */
1638 for (; ctor
; ctor
= ctor
->next
)
1640 if (expr
->value
.constructor
== NULL
)
1641 expr
->value
.constructor
1642 = new_ctor
= gfc_get_constructor ();
1645 new_ctor
->next
= gfc_get_constructor ();
1646 new_ctor
= new_ctor
->next
;
1648 new_ctor
->expr
= gfc_copy_expr (old
);
1649 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1651 b
= old
->value
.function
.actual
;
1652 for (i
= 0; i
< n
; i
++)
1655 new_ctor
->expr
->value
.function
.actual
1656 = a
= gfc_get_actual_arglist ();
1659 a
->next
= gfc_get_actual_arglist ();
1663 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1665 a
->expr
= gfc_copy_expr (b
->expr
);
1670 /* Simplify the function calls. */
1671 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1674 for (i
= 0; i
< n
; i
++)
1676 args
[i
] = args
[i
]->next
;
1678 for (i
= 1; i
< n
; i
++)
1679 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1680 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1686 gfc_free_expr (old
);
1690 gfc_error_now ("elemental function arguments at %C are not compliant");
1693 gfc_free_expr (expr
);
1694 gfc_free_expr (old
);
1700 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1702 gfc_expr
*op1
= e
->value
.op
.op1
;
1703 gfc_expr
*op2
= e
->value
.op
.op2
;
1705 if ((*check_function
) (op1
) == FAILURE
)
1708 switch (e
->value
.op
.operator)
1710 case INTRINSIC_UPLUS
:
1711 case INTRINSIC_UMINUS
:
1712 if (!numeric_type (et0 (op1
)))
1722 if ((*check_function
) (op2
) == FAILURE
)
1725 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1726 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1728 gfc_error ("Numeric or CHARACTER operands are required in "
1729 "expression at %L", &e
->where
);
1734 case INTRINSIC_PLUS
:
1735 case INTRINSIC_MINUS
:
1736 case INTRINSIC_TIMES
:
1737 case INTRINSIC_DIVIDE
:
1738 case INTRINSIC_POWER
:
1739 if ((*check_function
) (op2
) == FAILURE
)
1742 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1745 if (e
->value
.op
.operator == INTRINSIC_POWER
1746 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1748 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1749 "exponent in an initialization "
1750 "expression at %L", &op2
->where
)
1757 case INTRINSIC_CONCAT
:
1758 if ((*check_function
) (op2
) == FAILURE
)
1761 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1763 gfc_error ("Concatenation operator in expression at %L "
1764 "must have two CHARACTER operands", &op1
->where
);
1768 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1770 gfc_error ("Concat operator at %L must concatenate strings of the "
1771 "same kind", &e
->where
);
1778 if (et0 (op1
) != BT_LOGICAL
)
1780 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1781 "operand", &op1
->where
);
1790 case INTRINSIC_NEQV
:
1791 if ((*check_function
) (op2
) == FAILURE
)
1794 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1796 gfc_error ("LOGICAL operands are required in expression at %L",
1803 case INTRINSIC_PARENTHESES
:
1807 gfc_error ("Only intrinsic operators can be used in expression at %L",
1815 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1822 /* Certain inquiry functions are specifically allowed to have variable
1823 arguments, which is an exception to the normal requirement that an
1824 initialization function have initialization arguments. We head off
1825 this problem here. */
1828 check_inquiry (gfc_expr
*e
, int not_restricted
)
1832 /* FIXME: This should be moved into the intrinsic definitions,
1833 to eliminate this ugly hack. */
1834 static const char * const inquiry_function
[] = {
1835 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1836 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1837 "lbound", "ubound", NULL
1842 /* An undeclared parameter will get us here (PR25018). */
1843 if (e
->symtree
== NULL
)
1846 name
= e
->symtree
->n
.sym
->name
;
1848 for (i
= 0; inquiry_function
[i
]; i
++)
1849 if (strcmp (inquiry_function
[i
], name
) == 0)
1852 if (inquiry_function
[i
] == NULL
)
1855 e
= e
->value
.function
.actual
->expr
;
1857 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1860 /* At this point we have an inquiry function with a variable argument. The
1861 type of the variable might be undefined, but we need it now, because the
1862 arguments of these functions are allowed to be undefined. */
1864 if (e
->ts
.type
== BT_UNKNOWN
)
1866 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1867 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1871 e
->ts
= e
->symtree
->n
.sym
->ts
;
1874 /* Assumed character length will not reduce to a constant expression
1875 with LEN, as required by the standard. */
1876 if (i
== 4 && not_restricted
1877 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1878 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1879 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1880 "variable '%s' in constant expression at %L",
1881 e
->symtree
->n
.sym
->name
, &e
->where
);
1887 /* Verify that an expression is an initialization expression. A side
1888 effect is that the expression tree is reduced to a single constant
1889 node if all goes well. This would normally happen when the
1890 expression is constructed but function references are assumed to be
1891 intrinsics in the context of initialization expressions. If
1892 FAILURE is returned an error message has been generated. */
1895 check_init_expr (gfc_expr
*e
)
1897 gfc_actual_arglist
*ap
;
1900 gfc_intrinsic_sym
*isym
;
1905 switch (e
->expr_type
)
1908 t
= check_intrinsic_op (e
, check_init_expr
);
1910 t
= gfc_simplify_expr (e
, 0);
1917 if (check_inquiry (e
, 1) != SUCCESS
)
1920 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1921 if (check_init_expr (ap
->expr
) == FAILURE
)
1928 /* Try to scalarize an elemental intrinsic function that has an
1930 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
1931 if (isym
&& isym
->elemental
1932 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
1934 if (scalarize_intrinsic_call (e
) == SUCCESS
)
1940 m
= gfc_intrinsic_func_interface (e
, 0);
1943 gfc_error ("Function '%s' in initialization expression at %L "
1944 "must be an intrinsic function",
1945 e
->symtree
->n
.sym
->name
, &e
->where
);
1956 if (gfc_check_iter_variable (e
) == SUCCESS
)
1959 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1961 t
= simplify_parameter_variable (e
, 0);
1965 if (gfc_in_match_data ())
1968 gfc_error ("Parameter '%s' at %L has not been declared or is "
1969 "a variable, which does not reduce to a constant "
1970 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1979 case EXPR_SUBSTRING
:
1980 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1984 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1986 t
= gfc_simplify_expr (e
, 0);
1990 case EXPR_STRUCTURE
:
1991 t
= gfc_check_constructor (e
, check_init_expr
);
1995 t
= gfc_check_constructor (e
, check_init_expr
);
1999 t
= gfc_expand_constructor (e
);
2003 t
= gfc_check_constructor_type (e
);
2007 gfc_internal_error ("check_init_expr(): Unknown expression type");
2014 /* Match an initialization expression. We work by first matching an
2015 expression, then reducing it to a constant. */
2018 gfc_match_init_expr (gfc_expr
**result
)
2024 m
= gfc_match_expr (&expr
);
2029 t
= gfc_resolve_expr (expr
);
2031 t
= check_init_expr (expr
);
2036 gfc_free_expr (expr
);
2040 if (expr
->expr_type
== EXPR_ARRAY
2041 && (gfc_check_constructor_type (expr
) == FAILURE
2042 || gfc_expand_constructor (expr
) == FAILURE
))
2044 gfc_free_expr (expr
);
2048 /* Not all inquiry functions are simplified to constant expressions
2049 so it is necessary to call check_inquiry again. */
2050 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) == FAILURE
2051 && !gfc_in_match_data ())
2053 gfc_error ("Initialization expression didn't reduce %C");
2063 static try check_restricted (gfc_expr
*);
2065 /* Given an actual argument list, test to see that each argument is a
2066 restricted expression and optionally if the expression type is
2067 integer or character. */
2070 restricted_args (gfc_actual_arglist
*a
)
2072 for (; a
; a
= a
->next
)
2074 if (check_restricted (a
->expr
) == FAILURE
)
2082 /************* Restricted/specification expressions *************/
2085 /* Make sure a non-intrinsic function is a specification function. */
2088 external_spec_function (gfc_expr
*e
)
2092 f
= e
->value
.function
.esym
;
2094 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2096 gfc_error ("Specification function '%s' at %L cannot be a statement "
2097 "function", f
->name
, &e
->where
);
2101 if (f
->attr
.proc
== PROC_INTERNAL
)
2103 gfc_error ("Specification function '%s' at %L cannot be an internal "
2104 "function", f
->name
, &e
->where
);
2108 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2110 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2115 if (f
->attr
.recursive
)
2117 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2118 f
->name
, &e
->where
);
2122 return restricted_args (e
->value
.function
.actual
);
2126 /* Check to see that a function reference to an intrinsic is a
2127 restricted expression. */
2130 restricted_intrinsic (gfc_expr
*e
)
2132 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2133 if (check_inquiry (e
, 0) == SUCCESS
)
2136 return restricted_args (e
->value
.function
.actual
);
2140 /* Verify that an expression is a restricted expression. Like its
2141 cousin check_init_expr(), an error message is generated if we
2145 check_restricted (gfc_expr
*e
)
2153 switch (e
->expr_type
)
2156 t
= check_intrinsic_op (e
, check_restricted
);
2158 t
= gfc_simplify_expr (e
, 0);
2163 t
= e
->value
.function
.esym
? external_spec_function (e
)
2164 : restricted_intrinsic (e
);
2169 sym
= e
->symtree
->n
.sym
;
2172 if (sym
->attr
.optional
)
2174 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2175 sym
->name
, &e
->where
);
2179 if (sym
->attr
.intent
== INTENT_OUT
)
2181 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2182 sym
->name
, &e
->where
);
2186 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2187 processed in resolve.c(resolve_formal_arglist). This is done so
2188 that host associated dummy array indices are accepted (PR23446).
2189 This mechanism also does the same for the specification expressions
2190 of array-valued functions. */
2191 if (sym
->attr
.in_common
2192 || sym
->attr
.use_assoc
2194 || sym
->ns
!= gfc_current_ns
2195 || (sym
->ns
->proc_name
!= NULL
2196 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2197 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2203 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2204 sym
->name
, &e
->where
);
2213 case EXPR_SUBSTRING
:
2214 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2218 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2220 t
= gfc_simplify_expr (e
, 0);
2224 case EXPR_STRUCTURE
:
2225 t
= gfc_check_constructor (e
, check_restricted
);
2229 t
= gfc_check_constructor (e
, check_restricted
);
2233 gfc_internal_error ("check_restricted(): Unknown expression type");
2240 /* Check to see that an expression is a specification expression. If
2241 we return FAILURE, an error has been generated. */
2244 gfc_specification_expr (gfc_expr
*e
)
2249 if (e
->ts
.type
!= BT_INTEGER
)
2251 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2257 gfc_error ("Expression at %L must be scalar", &e
->where
);
2261 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2264 return check_restricted (e
);
2268 /************** Expression conformance checks. *************/
2270 /* Given two expressions, make sure that the arrays are conformable. */
2273 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2275 int op1_flag
, op2_flag
, d
;
2276 mpz_t op1_size
, op2_size
;
2279 if (op1
->rank
== 0 || op2
->rank
== 0)
2282 if (op1
->rank
!= op2
->rank
)
2284 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2291 for (d
= 0; d
< op1
->rank
; d
++)
2293 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2294 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2296 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2298 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2299 _(optype_msgid
), &op1
->where
, d
+ 1,
2300 (int) mpz_get_si (op1_size
),
2301 (int) mpz_get_si (op2_size
));
2307 mpz_clear (op1_size
);
2309 mpz_clear (op2_size
);
2319 /* Given an assignable expression and an arbitrary expression, make
2320 sure that the assignment can take place. */
2323 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2329 sym
= lvalue
->symtree
->n
.sym
;
2331 /* Check INTENT(IN), unless the object itself is the component or
2332 sub-component of a pointer. */
2333 has_pointer
= sym
->attr
.pointer
;
2335 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2336 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2342 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2344 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2345 sym
->name
, &lvalue
->where
);
2349 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2350 variable local to a function subprogram. Its existence begins when
2351 execution of the function is initiated and ends when execution of the
2352 function is terminated.....
2353 Therefore, the left hand side is no longer a varaiable, when it is: */
2354 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2355 && !sym
->attr
.external
)
2360 /* (i) Use associated; */
2361 if (sym
->attr
.use_assoc
)
2364 /* (ii) The assignment is in the main program; or */
2365 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2368 /* (iii) A module or internal procedure.... */
2369 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2370 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2371 && gfc_current_ns
->parent
2372 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2373 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2374 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2376 /* .... that is not a function.... */
2377 if (!gfc_current_ns
->proc_name
->attr
.function
)
2380 /* .... or is not an entry and has a different name. */
2381 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2387 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2392 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2394 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2395 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2399 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2401 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2406 if (rvalue
->expr_type
== EXPR_NULL
)
2408 gfc_error ("NULL appears on right-hand side in assignment at %L",
2413 if (sym
->attr
.cray_pointee
2414 && lvalue
->ref
!= NULL
2415 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2416 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2418 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2419 "is illegal", &lvalue
->where
);
2423 /* This is possibly a typo: x = f() instead of x => f() */
2424 if (gfc_option
.warn_surprising
2425 && rvalue
->expr_type
== EXPR_FUNCTION
2426 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2427 gfc_warning ("POINTER valued function appears on right-hand side of "
2428 "assignment at %L", &rvalue
->where
);
2430 /* Check size of array assignments. */
2431 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2432 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2435 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2440 /* Numeric can be converted to any other numeric. And Hollerith can be
2441 converted to any other type. */
2442 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2443 || rvalue
->ts
.type
== BT_HOLLERITH
)
2446 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2449 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2450 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2451 gfc_typename (&lvalue
->ts
));
2456 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2460 /* Check that a pointer assignment is OK. We first check lvalue, and
2461 we only check rvalue if it's not an assignment to NULL() or a
2462 NULLIFY statement. */
2465 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2467 symbol_attribute attr
;
2470 int pointer
, check_intent_in
;
2472 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2474 gfc_error ("Pointer assignment target is not a POINTER at %L",
2479 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2480 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2482 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2483 "l-value since it is a procedure",
2484 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2489 /* Check INTENT(IN), unless the object itself is the component or
2490 sub-component of a pointer. */
2491 check_intent_in
= 1;
2492 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2494 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2497 check_intent_in
= 0;
2499 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2503 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2505 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2506 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2512 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2516 is_pure
= gfc_pure (NULL
);
2518 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2520 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2524 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2525 kind, etc for lvalue and rvalue must match, and rvalue must be a
2526 pure variable if we're in a pure function. */
2527 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2530 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2532 gfc_error ("Different types in pointer assignment at %L",
2537 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2539 gfc_error ("Different kind type parameters in pointer "
2540 "assignment at %L", &lvalue
->where
);
2544 if (lvalue
->rank
!= rvalue
->rank
)
2546 gfc_error ("Different ranks in pointer assignment at %L",
2551 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2552 if (rvalue
->expr_type
== EXPR_NULL
)
2555 if (lvalue
->ts
.type
== BT_CHARACTER
2556 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2557 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2558 rvalue
->ts
.cl
->length
)) == 1)
2560 gfc_error ("Different character lengths in pointer "
2561 "assignment at %L", &lvalue
->where
);
2565 attr
= gfc_expr_attr (rvalue
);
2566 if (!attr
.target
&& !attr
.pointer
)
2568 gfc_error ("Pointer assignment target is neither TARGET "
2569 "nor POINTER at %L", &rvalue
->where
);
2573 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2575 gfc_error ("Bad target in pointer assignment in PURE "
2576 "procedure at %L", &rvalue
->where
);
2579 if (gfc_has_vector_index (rvalue
))
2581 gfc_error ("Pointer assignment with vector subscript "
2582 "on rhs at %L", &rvalue
->where
);
2586 if (attr
.protected && attr
.use_assoc
)
2588 gfc_error ("Pointer assigment target has PROTECTED "
2589 "attribute at %L", &rvalue
->where
);
2597 /* Relative of gfc_check_assign() except that the lvalue is a single
2598 symbol. Used for initialization assignments. */
2601 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2606 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2608 lvalue
.expr_type
= EXPR_VARIABLE
;
2609 lvalue
.ts
= sym
->ts
;
2611 lvalue
.rank
= sym
->as
->rank
;
2612 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2613 lvalue
.symtree
->n
.sym
= sym
;
2614 lvalue
.where
= sym
->declared_at
;
2616 if (sym
->attr
.pointer
)
2617 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2619 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2621 gfc_free (lvalue
.symtree
);
2627 /* Get an expression for a default initializer. */
2630 gfc_default_initializer (gfc_typespec
*ts
)
2632 gfc_constructor
*tail
;
2638 /* See if we have a default initializer. */
2639 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2641 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2642 init
= gfc_get_expr ();
2648 /* Build the constructor. */
2649 init
->expr_type
= EXPR_STRUCTURE
;
2651 init
->where
= ts
->derived
->declared_at
;
2653 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2656 init
->value
.constructor
= tail
= gfc_get_constructor ();
2659 tail
->next
= gfc_get_constructor ();
2664 tail
->expr
= gfc_copy_expr (c
->initializer
);
2668 tail
->expr
= gfc_get_expr ();
2669 tail
->expr
->expr_type
= EXPR_NULL
;
2670 tail
->expr
->ts
= c
->ts
;
2677 /* Given a symbol, create an expression node with that symbol as a
2678 variable. If the symbol is array valued, setup a reference of the
2682 gfc_get_variable_expr (gfc_symtree
*var
)
2686 e
= gfc_get_expr ();
2687 e
->expr_type
= EXPR_VARIABLE
;
2689 e
->ts
= var
->n
.sym
->ts
;
2691 if (var
->n
.sym
->as
!= NULL
)
2693 e
->rank
= var
->n
.sym
->as
->rank
;
2694 e
->ref
= gfc_get_ref ();
2695 e
->ref
->type
= REF_ARRAY
;
2696 e
->ref
->u
.ar
.type
= AR_FULL
;
2703 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2706 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2708 gfc_actual_arglist
*arg
;
2715 switch (expr
->expr_type
)
2718 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2719 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2723 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2724 gfc_expr_set_symbols_referenced (arg
->expr
);
2728 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2733 case EXPR_SUBSTRING
:
2736 case EXPR_STRUCTURE
:
2738 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2739 gfc_expr_set_symbols_referenced (c
->expr
);
2747 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2751 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2753 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2754 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2755 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2763 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2764 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);