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 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1580 gfc_expr
*op1
= e
->value
.op
.op1
;
1581 gfc_expr
*op2
= e
->value
.op
.op2
;
1583 if ((*check_function
) (op1
) == FAILURE
)
1586 switch (e
->value
.op
.operator)
1588 case INTRINSIC_UPLUS
:
1589 case INTRINSIC_UMINUS
:
1590 if (!numeric_type (et0 (op1
)))
1600 if ((*check_function
) (op2
) == FAILURE
)
1603 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1604 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1606 gfc_error ("Numeric or CHARACTER operands are required in "
1607 "expression at %L", &e
->where
);
1612 case INTRINSIC_PLUS
:
1613 case INTRINSIC_MINUS
:
1614 case INTRINSIC_TIMES
:
1615 case INTRINSIC_DIVIDE
:
1616 case INTRINSIC_POWER
:
1617 if ((*check_function
) (op2
) == FAILURE
)
1620 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1623 if (e
->value
.op
.operator == INTRINSIC_POWER
1624 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1626 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1627 "exponent in an initialization "
1628 "expression at %L", &op2
->where
)
1635 case INTRINSIC_CONCAT
:
1636 if ((*check_function
) (op2
) == FAILURE
)
1639 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1641 gfc_error ("Concatenation operator in expression at %L "
1642 "must have two CHARACTER operands", &op1
->where
);
1646 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1648 gfc_error ("Concat operator at %L must concatenate strings of the "
1649 "same kind", &e
->where
);
1656 if (et0 (op1
) != BT_LOGICAL
)
1658 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1659 "operand", &op1
->where
);
1668 case INTRINSIC_NEQV
:
1669 if ((*check_function
) (op2
) == FAILURE
)
1672 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1674 gfc_error ("LOGICAL operands are required in expression at %L",
1681 case INTRINSIC_PARENTHESES
:
1685 gfc_error ("Only intrinsic operators can be used in expression at %L",
1693 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1700 /* Certain inquiry functions are specifically allowed to have variable
1701 arguments, which is an exception to the normal requirement that an
1702 initialization function have initialization arguments. We head off
1703 this problem here. */
1706 check_inquiry (gfc_expr
*e
, int not_restricted
)
1710 /* FIXME: This should be moved into the intrinsic definitions,
1711 to eliminate this ugly hack. */
1712 static const char * const inquiry_function
[] = {
1713 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1714 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1715 "lbound", "ubound", NULL
1720 /* An undeclared parameter will get us here (PR25018). */
1721 if (e
->symtree
== NULL
)
1724 name
= e
->symtree
->n
.sym
->name
;
1726 for (i
= 0; inquiry_function
[i
]; i
++)
1727 if (strcmp (inquiry_function
[i
], name
) == 0)
1730 if (inquiry_function
[i
] == NULL
)
1733 e
= e
->value
.function
.actual
->expr
;
1735 if (e
== NULL
|| e
->expr_type
!= EXPR_VARIABLE
)
1738 /* At this point we have an inquiry function with a variable argument. The
1739 type of the variable might be undefined, but we need it now, because the
1740 arguments of these functions are allowed to be undefined. */
1742 if (e
->ts
.type
== BT_UNKNOWN
)
1744 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
1745 && gfc_set_default_type (e
->symtree
->n
.sym
, 0, gfc_current_ns
)
1749 e
->ts
= e
->symtree
->n
.sym
->ts
;
1752 /* Assumed character length will not reduce to a constant expression
1753 with LEN, as required by the standard. */
1754 if (i
== 4 && not_restricted
1755 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
1756 && e
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
1757 gfc_notify_std (GFC_STD_GNU
, "assumed character length "
1758 "variable '%s' in constant expression at %L",
1759 e
->symtree
->n
.sym
->name
, &e
->where
);
1765 /* Verify that an expression is an initialization expression. A side
1766 effect is that the expression tree is reduced to a single constant
1767 node if all goes well. This would normally happen when the
1768 expression is constructed but function references are assumed to be
1769 intrinsics in the context of initialization expressions. If
1770 FAILURE is returned an error message has been generated. */
1773 check_init_expr (gfc_expr
*e
)
1775 gfc_actual_arglist
*ap
;
1782 switch (e
->expr_type
)
1785 t
= check_intrinsic_op (e
, check_init_expr
);
1787 t
= gfc_simplify_expr (e
, 0);
1794 if (check_inquiry (e
, 1) != SUCCESS
)
1797 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1798 if (check_init_expr (ap
->expr
) == FAILURE
)
1807 m
= gfc_intrinsic_func_interface (e
, 0);
1810 gfc_error ("Function '%s' in initialization expression at %L "
1811 "must be an intrinsic function",
1812 e
->symtree
->n
.sym
->name
, &e
->where
);
1823 if (gfc_check_iter_variable (e
) == SUCCESS
)
1826 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1828 t
= simplify_parameter_variable (e
, 0);
1832 if (gfc_in_match_data ())
1835 gfc_error ("Parameter '%s' at %L has not been declared or is "
1836 "a variable, which does not reduce to a constant "
1837 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
1846 case EXPR_SUBSTRING
:
1847 t
= check_init_expr (e
->ref
->u
.ss
.start
);
1851 t
= check_init_expr (e
->ref
->u
.ss
.end
);
1853 t
= gfc_simplify_expr (e
, 0);
1857 case EXPR_STRUCTURE
:
1858 t
= gfc_check_constructor (e
, check_init_expr
);
1862 t
= gfc_check_constructor (e
, check_init_expr
);
1866 t
= gfc_expand_constructor (e
);
1870 t
= gfc_check_constructor_type (e
);
1874 gfc_internal_error ("check_init_expr(): Unknown expression type");
1881 /* Match an initialization expression. We work by first matching an
1882 expression, then reducing it to a constant. */
1885 gfc_match_init_expr (gfc_expr
**result
)
1891 m
= gfc_match_expr (&expr
);
1896 t
= gfc_resolve_expr (expr
);
1898 t
= check_init_expr (expr
);
1903 gfc_free_expr (expr
);
1907 if (expr
->expr_type
== EXPR_ARRAY
1908 && (gfc_check_constructor_type (expr
) == FAILURE
1909 || gfc_expand_constructor (expr
) == FAILURE
))
1911 gfc_free_expr (expr
);
1915 /* Not all inquiry functions are simplified to constant expressions
1916 so it is necessary to call check_inquiry again. */
1917 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) == FAILURE
1918 && !gfc_in_match_data ())
1920 gfc_error ("Initialization expression didn't reduce %C");
1930 static try check_restricted (gfc_expr
*);
1932 /* Given an actual argument list, test to see that each argument is a
1933 restricted expression and optionally if the expression type is
1934 integer or character. */
1937 restricted_args (gfc_actual_arglist
*a
)
1939 for (; a
; a
= a
->next
)
1941 if (check_restricted (a
->expr
) == FAILURE
)
1949 /************* Restricted/specification expressions *************/
1952 /* Make sure a non-intrinsic function is a specification function. */
1955 external_spec_function (gfc_expr
*e
)
1959 f
= e
->value
.function
.esym
;
1961 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
1963 gfc_error ("Specification function '%s' at %L cannot be a statement "
1964 "function", f
->name
, &e
->where
);
1968 if (f
->attr
.proc
== PROC_INTERNAL
)
1970 gfc_error ("Specification function '%s' at %L cannot be an internal "
1971 "function", f
->name
, &e
->where
);
1975 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
1977 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
1982 if (f
->attr
.recursive
)
1984 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1985 f
->name
, &e
->where
);
1989 return restricted_args (e
->value
.function
.actual
);
1993 /* Check to see that a function reference to an intrinsic is a
1994 restricted expression. */
1997 restricted_intrinsic (gfc_expr
*e
)
1999 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2000 if (check_inquiry (e
, 0) == SUCCESS
)
2003 return restricted_args (e
->value
.function
.actual
);
2007 /* Verify that an expression is a restricted expression. Like its
2008 cousin check_init_expr(), an error message is generated if we
2012 check_restricted (gfc_expr
*e
)
2020 switch (e
->expr_type
)
2023 t
= check_intrinsic_op (e
, check_restricted
);
2025 t
= gfc_simplify_expr (e
, 0);
2030 t
= e
->value
.function
.esym
? external_spec_function (e
)
2031 : restricted_intrinsic (e
);
2036 sym
= e
->symtree
->n
.sym
;
2039 if (sym
->attr
.optional
)
2041 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2042 sym
->name
, &e
->where
);
2046 if (sym
->attr
.intent
== INTENT_OUT
)
2048 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2049 sym
->name
, &e
->where
);
2053 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2054 processed in resolve.c(resolve_formal_arglist). This is done so
2055 that host associated dummy array indices are accepted (PR23446).
2056 This mechanism also does the same for the specification expressions
2057 of array-valued functions. */
2058 if (sym
->attr
.in_common
2059 || sym
->attr
.use_assoc
2061 || sym
->ns
!= gfc_current_ns
2062 || (sym
->ns
->proc_name
!= NULL
2063 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2064 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2070 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2071 sym
->name
, &e
->where
);
2080 case EXPR_SUBSTRING
:
2081 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2085 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2087 t
= gfc_simplify_expr (e
, 0);
2091 case EXPR_STRUCTURE
:
2092 t
= gfc_check_constructor (e
, check_restricted
);
2096 t
= gfc_check_constructor (e
, check_restricted
);
2100 gfc_internal_error ("check_restricted(): Unknown expression type");
2107 /* Check to see that an expression is a specification expression. If
2108 we return FAILURE, an error has been generated. */
2111 gfc_specification_expr (gfc_expr
*e
)
2116 if (e
->ts
.type
!= BT_INTEGER
)
2118 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2124 gfc_error ("Expression at %L must be scalar", &e
->where
);
2128 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2131 return check_restricted (e
);
2135 /************** Expression conformance checks. *************/
2137 /* Given two expressions, make sure that the arrays are conformable. */
2140 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2142 int op1_flag
, op2_flag
, d
;
2143 mpz_t op1_size
, op2_size
;
2146 if (op1
->rank
== 0 || op2
->rank
== 0)
2149 if (op1
->rank
!= op2
->rank
)
2151 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid
),
2158 for (d
= 0; d
< op1
->rank
; d
++)
2160 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2161 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2163 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2165 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2166 _(optype_msgid
), &op1
->where
, d
+ 1,
2167 (int) mpz_get_si (op1_size
),
2168 (int) mpz_get_si (op2_size
));
2174 mpz_clear (op1_size
);
2176 mpz_clear (op2_size
);
2186 /* Given an assignable expression and an arbitrary expression, make
2187 sure that the assignment can take place. */
2190 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2196 sym
= lvalue
->symtree
->n
.sym
;
2198 /* Check INTENT(IN), unless the object itself is the component or
2199 sub-component of a pointer. */
2200 has_pointer
= sym
->attr
.pointer
;
2202 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2203 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2209 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2211 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2212 sym
->name
, &lvalue
->where
);
2216 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2217 variable local to a function subprogram. Its existence begins when
2218 execution of the function is initiated and ends when execution of the
2219 function is terminated.....
2220 Therefore, the left hand side is no longer a varaiable, when it is: */
2221 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2222 && !sym
->attr
.external
)
2227 /* (i) Use associated; */
2228 if (sym
->attr
.use_assoc
)
2231 /* (ii) The assignment is in the main program; or */
2232 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2235 /* (iii) A module or internal procedure.... */
2236 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2237 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2238 && gfc_current_ns
->parent
2239 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2240 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2241 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2243 /* .... that is not a function.... */
2244 if (!gfc_current_ns
->proc_name
->attr
.function
)
2247 /* .... or is not an entry and has a different name. */
2248 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2254 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2259 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2261 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2262 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2266 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2268 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2273 if (rvalue
->expr_type
== EXPR_NULL
)
2275 gfc_error ("NULL appears on right-hand side in assignment at %L",
2280 if (sym
->attr
.cray_pointee
2281 && lvalue
->ref
!= NULL
2282 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2283 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2285 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2286 "is illegal", &lvalue
->where
);
2290 /* This is possibly a typo: x = f() instead of x => f() */
2291 if (gfc_option
.warn_surprising
2292 && rvalue
->expr_type
== EXPR_FUNCTION
2293 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2294 gfc_warning ("POINTER valued function appears on right-hand side of "
2295 "assignment at %L", &rvalue
->where
);
2297 /* Check size of array assignments. */
2298 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2299 && gfc_check_conformance ("Array assignment", lvalue
, rvalue
) != SUCCESS
)
2302 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2307 /* Numeric can be converted to any other numeric. And Hollerith can be
2308 converted to any other type. */
2309 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2310 || rvalue
->ts
.type
== BT_HOLLERITH
)
2313 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2316 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2317 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2318 gfc_typename (&lvalue
->ts
));
2323 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2327 /* Check that a pointer assignment is OK. We first check lvalue, and
2328 we only check rvalue if it's not an assignment to NULL() or a
2329 NULLIFY statement. */
2332 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2334 symbol_attribute attr
;
2337 int pointer
, check_intent_in
;
2339 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2341 gfc_error ("Pointer assignment target is not a POINTER at %L",
2346 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2347 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2349 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2350 "l-value since it is a procedure",
2351 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2356 /* Check INTENT(IN), unless the object itself is the component or
2357 sub-component of a pointer. */
2358 check_intent_in
= 1;
2359 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2361 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2364 check_intent_in
= 0;
2366 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2370 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2372 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2373 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2379 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2383 is_pure
= gfc_pure (NULL
);
2385 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
))
2387 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2391 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2392 kind, etc for lvalue and rvalue must match, and rvalue must be a
2393 pure variable if we're in a pure function. */
2394 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2397 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2399 gfc_error ("Different types in pointer assignment at %L",
2404 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2406 gfc_error ("Different kind type parameters in pointer "
2407 "assignment at %L", &lvalue
->where
);
2411 if (lvalue
->rank
!= rvalue
->rank
)
2413 gfc_error ("Different ranks in pointer assignment at %L",
2418 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2419 if (rvalue
->expr_type
== EXPR_NULL
)
2422 if (lvalue
->ts
.type
== BT_CHARACTER
2423 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2424 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2425 rvalue
->ts
.cl
->length
)) == 1)
2427 gfc_error ("Different character lengths in pointer "
2428 "assignment at %L", &lvalue
->where
);
2432 attr
= gfc_expr_attr (rvalue
);
2433 if (!attr
.target
&& !attr
.pointer
)
2435 gfc_error ("Pointer assignment target is neither TARGET "
2436 "nor POINTER at %L", &rvalue
->where
);
2440 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2442 gfc_error ("Bad target in pointer assignment in PURE "
2443 "procedure at %L", &rvalue
->where
);
2446 if (gfc_has_vector_index (rvalue
))
2448 gfc_error ("Pointer assignment with vector subscript "
2449 "on rhs at %L", &rvalue
->where
);
2453 if (attr
.protected && attr
.use_assoc
)
2455 gfc_error ("Pointer assigment target has PROTECTED "
2456 "attribute at %L", &rvalue
->where
);
2464 /* Relative of gfc_check_assign() except that the lvalue is a single
2465 symbol. Used for initialization assignments. */
2468 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2473 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2475 lvalue
.expr_type
= EXPR_VARIABLE
;
2476 lvalue
.ts
= sym
->ts
;
2478 lvalue
.rank
= sym
->as
->rank
;
2479 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2480 lvalue
.symtree
->n
.sym
= sym
;
2481 lvalue
.where
= sym
->declared_at
;
2483 if (sym
->attr
.pointer
)
2484 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
2486 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
2488 gfc_free (lvalue
.symtree
);
2494 /* Get an expression for a default initializer. */
2497 gfc_default_initializer (gfc_typespec
*ts
)
2499 gfc_constructor
*tail
;
2505 /* See if we have a default initializer. */
2506 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2508 if ((c
->initializer
|| c
->allocatable
) && init
== NULL
)
2509 init
= gfc_get_expr ();
2515 /* Build the constructor. */
2516 init
->expr_type
= EXPR_STRUCTURE
;
2518 init
->where
= ts
->derived
->declared_at
;
2520 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
2523 init
->value
.constructor
= tail
= gfc_get_constructor ();
2526 tail
->next
= gfc_get_constructor ();
2531 tail
->expr
= gfc_copy_expr (c
->initializer
);
2535 tail
->expr
= gfc_get_expr ();
2536 tail
->expr
->expr_type
= EXPR_NULL
;
2537 tail
->expr
->ts
= c
->ts
;
2544 /* Given a symbol, create an expression node with that symbol as a
2545 variable. If the symbol is array valued, setup a reference of the
2549 gfc_get_variable_expr (gfc_symtree
*var
)
2553 e
= gfc_get_expr ();
2554 e
->expr_type
= EXPR_VARIABLE
;
2556 e
->ts
= var
->n
.sym
->ts
;
2558 if (var
->n
.sym
->as
!= NULL
)
2560 e
->rank
= var
->n
.sym
->as
->rank
;
2561 e
->ref
= gfc_get_ref ();
2562 e
->ref
->type
= REF_ARRAY
;
2563 e
->ref
->u
.ar
.type
= AR_FULL
;
2570 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2573 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
2575 gfc_actual_arglist
*arg
;
2582 switch (expr
->expr_type
)
2585 gfc_expr_set_symbols_referenced (expr
->value
.op
.op1
);
2586 gfc_expr_set_symbols_referenced (expr
->value
.op
.op2
);
2590 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2591 gfc_expr_set_symbols_referenced (arg
->expr
);
2595 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
2600 case EXPR_SUBSTRING
:
2603 case EXPR_STRUCTURE
:
2605 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
2606 gfc_expr_set_symbols_referenced (c
->expr
);
2614 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2618 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2620 gfc_expr_set_symbols_referenced (ref
->u
.ar
.start
[i
]);
2621 gfc_expr_set_symbols_referenced (ref
->u
.ar
.end
[i
]);
2622 gfc_expr_set_symbols_referenced (ref
->u
.ar
.stride
[i
]);
2630 gfc_expr_set_symbols_referenced (ref
->u
.ss
.start
);
2631 gfc_expr_set_symbols_referenced (ref
->u
.ss
.end
);