1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
27 #include "target-memory.h" /* for gfc_convert_boz */
29 /* Get a new expr node. */
36 e
= gfc_getmem (sizeof (gfc_expr
));
37 gfc_clear_ts (&e
->ts
);
41 e
->con_by_offset
= NULL
;
46 /* Free an argument list and everything below it. */
49 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
51 gfc_actual_arglist
*a2
;
56 gfc_free_expr (a1
->expr
);
63 /* Copy an arglist structure and all of the arguments. */
66 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
68 gfc_actual_arglist
*head
, *tail
, *new;
72 for (; p
; p
= p
->next
)
74 new = gfc_get_actual_arglist ();
77 new->expr
= gfc_copy_expr (p
->expr
);
92 /* Free a list of reference structures. */
95 gfc_free_ref_list (gfc_ref
*p
)
107 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
109 gfc_free_expr (p
->u
.ar
.start
[i
]);
110 gfc_free_expr (p
->u
.ar
.end
[i
]);
111 gfc_free_expr (p
->u
.ar
.stride
[i
]);
117 gfc_free_expr (p
->u
.ss
.start
);
118 gfc_free_expr (p
->u
.ss
.end
);
130 /* Workhorse function for gfc_free_expr() that frees everything
131 beneath an expression node, but not the node itself. This is
132 useful when we want to simplify a node and replace it with
133 something else or the expression node belongs to another structure. */
136 free_expr0 (gfc_expr
*e
)
140 switch (e
->expr_type
)
143 /* Free any parts of the value that need freeing. */
147 mpz_clear (e
->value
.integer
);
151 mpfr_clear (e
->value
.real
);
155 gfc_free (e
->value
.character
.string
);
159 mpfr_clear (e
->value
.complex.r
);
160 mpfr_clear (e
->value
.complex.i
);
167 /* Free the representation, except in character constants where it
168 is the same as value.character.string and thus already freed. */
169 if (e
->representation
.string
&& e
->ts
.type
!= BT_CHARACTER
)
170 gfc_free (e
->representation
.string
);
175 if (e
->value
.op
.op1
!= NULL
)
176 gfc_free_expr (e
->value
.op
.op1
);
177 if (e
->value
.op
.op2
!= NULL
)
178 gfc_free_expr (e
->value
.op
.op2
);
182 gfc_free_actual_arglist (e
->value
.function
.actual
);
190 gfc_free_constructor (e
->value
.constructor
);
194 gfc_free (e
->value
.character
.string
);
201 gfc_internal_error ("free_expr0(): Bad expr type");
204 /* Free a shape array. */
205 if (e
->shape
!= NULL
)
207 for (n
= 0; n
< e
->rank
; n
++)
208 mpz_clear (e
->shape
[n
]);
213 gfc_free_ref_list (e
->ref
);
215 memset (e
, '\0', sizeof (gfc_expr
));
219 /* Free an expression node and everything beneath it. */
222 gfc_free_expr (gfc_expr
*e
)
226 if (e
->con_by_offset
)
227 splay_tree_delete (e
->con_by_offset
);
233 /* Graft the *src expression onto the *dest subexpression. */
236 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
244 /* Try to extract an integer constant from the passed expression node.
245 Returns an error message or NULL if the result is set. It is
246 tempting to generate an error and return SUCCESS or FAILURE, but
247 failure is OK for some callers. */
250 gfc_extract_int (gfc_expr
*expr
, int *result
)
252 if (expr
->expr_type
!= EXPR_CONSTANT
)
253 return _("Constant expression required at %C");
255 if (expr
->ts
.type
!= BT_INTEGER
)
256 return _("Integer expression required at %C");
258 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
259 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
261 return _("Integer value too large in expression at %C");
264 *result
= (int) mpz_get_si (expr
->value
.integer
);
270 /* Recursively copy a list of reference structures. */
273 copy_ref (gfc_ref
*src
)
281 dest
= gfc_get_ref ();
282 dest
->type
= src
->type
;
287 ar
= gfc_copy_array_ref (&src
->u
.ar
);
293 dest
->u
.c
= src
->u
.c
;
297 dest
->u
.ss
= src
->u
.ss
;
298 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
299 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
303 dest
->next
= copy_ref (src
->next
);
309 /* Detect whether an expression has any vector index array references. */
312 gfc_has_vector_index (gfc_expr
*e
)
316 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
317 if (ref
->type
== REF_ARRAY
)
318 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
319 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
325 /* Copy a shape array. */
328 gfc_copy_shape (mpz_t
*shape
, int rank
)
336 new_shape
= gfc_get_shape (rank
);
338 for (n
= 0; n
< rank
; n
++)
339 mpz_init_set (new_shape
[n
], shape
[n
]);
345 /* Copy a shape array excluding dimension N, where N is an integer
346 constant expression. Dimensions are numbered in fortran style --
349 So, if the original shape array contains R elements
350 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
351 the result contains R-1 elements:
352 { s1 ... sN-1 sN+1 ... sR-1}
354 If anything goes wrong -- N is not a constant, its value is out
355 of range -- or anything else, just returns NULL. */
358 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
360 mpz_t
*new_shape
, *s
;
366 || dim
->expr_type
!= EXPR_CONSTANT
367 || dim
->ts
.type
!= BT_INTEGER
)
370 n
= mpz_get_si (dim
->value
.integer
);
371 n
--; /* Convert to zero based index. */
372 if (n
< 0 || n
>= rank
)
375 s
= new_shape
= gfc_get_shape (rank
- 1);
377 for (i
= 0; i
< rank
; i
++)
381 mpz_init_set (*s
, shape
[i
]);
389 /* Given an expression pointer, return a copy of the expression. This
390 subroutine is recursive. */
393 gfc_copy_expr (gfc_expr
*p
)
404 switch (q
->expr_type
)
407 s
= gfc_getmem (p
->value
.character
.length
+ 1);
408 q
->value
.character
.string
= s
;
410 memcpy (s
, p
->value
.character
.string
, p
->value
.character
.length
+ 1);
414 /* Copy target representation, if it exists. */
415 if (p
->representation
.string
)
417 s
= gfc_getmem (p
->representation
.length
+ 1);
418 q
->representation
.string
= s
;
420 memcpy (s
, p
->representation
.string
, p
->representation
.length
+ 1);
423 /* Copy the values of any pointer components of p->value. */
427 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
431 gfc_set_model_kind (q
->ts
.kind
);
432 mpfr_init (q
->value
.real
);
433 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
437 gfc_set_model_kind (q
->ts
.kind
);
438 mpfr_init (q
->value
.complex.r
);
439 mpfr_init (q
->value
.complex.i
);
440 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
441 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
445 if (p
->representation
.string
)
446 q
->value
.character
.string
= q
->representation
.string
;
449 s
= gfc_getmem (p
->value
.character
.length
+ 1);
450 q
->value
.character
.string
= s
;
452 /* This is the case for the C_NULL_CHAR named constant. */
453 if (p
->value
.character
.length
== 0
454 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
457 /* Need to set the length to 1 to make sure the NUL
458 terminator is copied. */
459 q
->value
.character
.length
= 1;
462 memcpy (s
, p
->value
.character
.string
,
463 p
->value
.character
.length
+ 1);
470 break; /* Already done. */
474 /* Should never be reached. */
476 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
483 switch (q
->value
.op
.operator)
486 case INTRINSIC_PARENTHESES
:
487 case INTRINSIC_UPLUS
:
488 case INTRINSIC_UMINUS
:
489 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
492 default: /* Binary operators. */
493 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
494 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
501 q
->value
.function
.actual
=
502 gfc_copy_actual_arglist (p
->value
.function
.actual
);
507 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
515 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
517 q
->ref
= copy_ref (p
->ref
);
523 /* Return the maximum kind of two expressions. In general, higher
524 kind numbers mean more precision for numeric types. */
527 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
529 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
533 /* Returns nonzero if the type is numeric, zero otherwise. */
536 numeric_type (bt type
)
538 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
542 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
545 gfc_numeric_ts (gfc_typespec
*ts
)
547 return numeric_type (ts
->type
);
551 /* Returns an expression node that is an integer constant. */
560 p
->expr_type
= EXPR_CONSTANT
;
561 p
->ts
.type
= BT_INTEGER
;
562 p
->ts
.kind
= gfc_default_integer_kind
;
564 p
->where
= gfc_current_locus
;
565 mpz_init_set_si (p
->value
.integer
, i
);
571 /* Returns an expression node that is a logical constant. */
574 gfc_logical_expr (int i
, locus
*where
)
580 p
->expr_type
= EXPR_CONSTANT
;
581 p
->ts
.type
= BT_LOGICAL
;
582 p
->ts
.kind
= gfc_default_logical_kind
;
585 where
= &gfc_current_locus
;
587 p
->value
.logical
= i
;
593 /* Return an expression node with an optional argument list attached.
594 A variable number of gfc_expr pointers are strung together in an
595 argument list with a NULL pointer terminating the list. */
598 gfc_build_conversion (gfc_expr
*e
)
603 p
->expr_type
= EXPR_FUNCTION
;
605 p
->value
.function
.actual
= NULL
;
607 p
->value
.function
.actual
= gfc_get_actual_arglist ();
608 p
->value
.function
.actual
->expr
= e
;
614 /* Given an expression node with some sort of numeric binary
615 expression, insert type conversions required to make the operands
618 The exception is that the operands of an exponential don't have to
619 have the same type. If possible, the base is promoted to the type
620 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
621 1.0**2 stays as it is. */
624 gfc_type_convert_binary (gfc_expr
*e
)
628 op1
= e
->value
.op
.op1
;
629 op2
= e
->value
.op
.op2
;
631 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
633 gfc_clear_ts (&e
->ts
);
637 /* Kind conversions of same type. */
638 if (op1
->ts
.type
== op2
->ts
.type
)
640 if (op1
->ts
.kind
== op2
->ts
.kind
)
642 /* No type conversions. */
647 if (op1
->ts
.kind
> op2
->ts
.kind
)
648 gfc_convert_type (op2
, &op1
->ts
, 2);
650 gfc_convert_type (op1
, &op2
->ts
, 2);
656 /* Integer combined with real or complex. */
657 if (op2
->ts
.type
== BT_INTEGER
)
661 /* Special case for ** operator. */
662 if (e
->value
.op
.operator == INTRINSIC_POWER
)
665 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
669 if (op1
->ts
.type
== BT_INTEGER
)
672 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
676 /* Real combined with complex. */
677 e
->ts
.type
= BT_COMPLEX
;
678 if (op1
->ts
.kind
> op2
->ts
.kind
)
679 e
->ts
.kind
= op1
->ts
.kind
;
681 e
->ts
.kind
= op2
->ts
.kind
;
682 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
683 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
684 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
685 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
693 check_specification_function (gfc_expr
*e
)
700 sym
= e
->symtree
->n
.sym
;
702 /* F95, 7.1.6.2; F2003, 7.1.7 */
704 && sym
->attr
.function
706 && !sym
->attr
.intrinsic
707 && !sym
->attr
.recursive
708 && sym
->attr
.proc
!= PROC_INTERNAL
709 && sym
->attr
.proc
!= PROC_ST_FUNCTION
710 && sym
->attr
.proc
!= PROC_UNKNOWN
711 && sym
->formal
== NULL
)
717 /* Function to determine if an expression is constant or not. This
718 function expects that the expression has already been simplified. */
721 gfc_is_constant_expr (gfc_expr
*e
)
724 gfc_actual_arglist
*arg
;
730 switch (e
->expr_type
)
733 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
734 && (e
->value
.op
.op2
== NULL
735 || gfc_is_constant_expr (e
->value
.op
.op2
)));
743 /* Specification functions are constant. */
744 if (check_specification_function (e
) == MATCH_YES
)
750 /* Call to intrinsic with at least one argument. */
752 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
754 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
756 if (!gfc_is_constant_expr (arg
->expr
))
770 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
771 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
776 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
777 if (!gfc_is_constant_expr (c
->expr
))
785 rv
= gfc_constant_ac (e
);
789 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
796 /* Is true if an array reference is followed by a component or substring
799 is_subref_array (gfc_expr
* e
)
804 if (e
->expr_type
!= EXPR_VARIABLE
)
807 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
811 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
813 if (ref
->type
== REF_ARRAY
814 && ref
->u
.ar
.type
!= AR_ELEMENT
)
818 && ref
->type
!= REF_ARRAY
)
825 /* Try to collapse intrinsic expressions. */
828 simplify_intrinsic_op (gfc_expr
*p
, int type
)
831 gfc_expr
*op1
, *op2
, *result
;
833 if (p
->value
.op
.operator == INTRINSIC_USER
)
836 op1
= p
->value
.op
.op1
;
837 op2
= p
->value
.op
.op2
;
838 op
= p
->value
.op
.operator;
840 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
842 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
845 if (!gfc_is_constant_expr (op1
)
846 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
850 p
->value
.op
.op1
= NULL
;
851 p
->value
.op
.op2
= NULL
;
855 case INTRINSIC_PARENTHESES
:
856 result
= gfc_parentheses (op1
);
859 case INTRINSIC_UPLUS
:
860 result
= gfc_uplus (op1
);
863 case INTRINSIC_UMINUS
:
864 result
= gfc_uminus (op1
);
868 result
= gfc_add (op1
, op2
);
871 case INTRINSIC_MINUS
:
872 result
= gfc_subtract (op1
, op2
);
875 case INTRINSIC_TIMES
:
876 result
= gfc_multiply (op1
, op2
);
879 case INTRINSIC_DIVIDE
:
880 result
= gfc_divide (op1
, op2
);
883 case INTRINSIC_POWER
:
884 result
= gfc_power (op1
, op2
);
887 case INTRINSIC_CONCAT
:
888 result
= gfc_concat (op1
, op2
);
892 case INTRINSIC_EQ_OS
:
893 result
= gfc_eq (op1
, op2
, op
);
897 case INTRINSIC_NE_OS
:
898 result
= gfc_ne (op1
, op2
, op
);
902 case INTRINSIC_GT_OS
:
903 result
= gfc_gt (op1
, op2
, op
);
907 case INTRINSIC_GE_OS
:
908 result
= gfc_ge (op1
, op2
, op
);
912 case INTRINSIC_LT_OS
:
913 result
= gfc_lt (op1
, op2
, op
);
917 case INTRINSIC_LE_OS
:
918 result
= gfc_le (op1
, op2
, op
);
922 result
= gfc_not (op1
);
926 result
= gfc_and (op1
, op2
);
930 result
= gfc_or (op1
, op2
);
934 result
= gfc_eqv (op1
, op2
);
938 result
= gfc_neqv (op1
, op2
);
942 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
952 result
->rank
= p
->rank
;
953 result
->where
= p
->where
;
954 gfc_replace_expr (p
, result
);
960 /* Subroutine to simplify constructor expressions. Mutually recursive
961 with gfc_simplify_expr(). */
964 simplify_constructor (gfc_constructor
*c
, int type
)
968 for (; c
; c
= c
->next
)
971 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
972 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
973 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
978 /* Try and simplify a copy. Replace the original if successful
979 but keep going through the constructor at all costs. Not
980 doing so can make a dog's dinner of complicated things. */
981 p
= gfc_copy_expr (c
->expr
);
983 if (gfc_simplify_expr (p
, type
) == FAILURE
)
989 gfc_replace_expr (c
->expr
, p
);
997 /* Pull a single array element out of an array constructor. */
1000 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
1001 gfc_constructor
**rval
)
1003 unsigned long nelemen
;
1015 mpz_init_set_ui (offset
, 0);
1018 mpz_init_set_ui (span
, 1);
1019 for (i
= 0; i
< ar
->dimen
; i
++)
1021 e
= gfc_copy_expr (ar
->start
[i
]);
1022 if (e
->expr_type
!= EXPR_CONSTANT
)
1027 /* Check the bounds. */
1028 if ((ar
->as
->upper
[i
]
1029 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1030 && mpz_cmp (e
->value
.integer
,
1031 ar
->as
->upper
[i
]->value
.integer
) > 0)
1033 (ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1034 && mpz_cmp (e
->value
.integer
,
1035 ar
->as
->lower
[i
]->value
.integer
) < 0))
1037 gfc_error ("Index in dimension %d is out of bounds "
1038 "at %L", i
+ 1, &ar
->c_where
[i
]);
1044 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1045 mpz_mul (delta
, delta
, span
);
1046 mpz_add (offset
, offset
, delta
);
1048 mpz_set_ui (tmp
, 1);
1049 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1050 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1051 mpz_mul (span
, span
, tmp
);
1054 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1080 /* Find a component of a structure constructor. */
1082 static gfc_constructor
*
1083 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1085 gfc_component
*comp
;
1086 gfc_component
*pick
;
1088 comp
= ref
->u
.c
.sym
->components
;
1089 pick
= ref
->u
.c
.component
;
1090 while (comp
!= pick
)
1100 /* Replace an expression with the contents of a constructor, removing
1101 the subobject reference in the process. */
1104 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1110 e
->ref
= p
->ref
->next
;
1111 p
->ref
->next
= NULL
;
1112 gfc_replace_expr (p
, e
);
1116 /* Pull an array section out of an array constructor. */
1119 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1125 long unsigned one
= 1;
1127 mpz_t start
[GFC_MAX_DIMENSIONS
];
1128 mpz_t end
[GFC_MAX_DIMENSIONS
];
1129 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1130 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1131 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1137 gfc_constructor
*cons
;
1138 gfc_constructor
*base
;
1144 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1149 base
= expr
->value
.constructor
;
1150 expr
->value
.constructor
= NULL
;
1152 rank
= ref
->u
.ar
.as
->rank
;
1154 if (expr
->shape
== NULL
)
1155 expr
->shape
= gfc_get_shape (rank
);
1157 mpz_init_set_ui (delta_mpz
, one
);
1158 mpz_init_set_ui (nelts
, one
);
1161 /* Do the initialization now, so that we can cleanup without
1162 keeping track of where we were. */
1163 for (d
= 0; d
< rank
; d
++)
1165 mpz_init (delta
[d
]);
1166 mpz_init (start
[d
]);
1169 mpz_init (stride
[d
]);
1173 /* Build the counters to clock through the array reference. */
1175 for (d
= 0; d
< rank
; d
++)
1177 /* Make this stretch of code easier on the eye! */
1178 begin
= ref
->u
.ar
.start
[d
];
1179 finish
= ref
->u
.ar
.end
[d
];
1180 step
= ref
->u
.ar
.stride
[d
];
1181 lower
= ref
->u
.ar
.as
->lower
[d
];
1182 upper
= ref
->u
.ar
.as
->upper
[d
];
1184 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1188 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1194 gcc_assert (begin
->rank
== 1);
1195 gcc_assert (begin
->shape
);
1197 vecsub
[d
] = begin
->value
.constructor
;
1198 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1199 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1200 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1203 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1205 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1206 || mpz_cmp (c
->expr
->value
.integer
,
1207 lower
->value
.integer
) < 0)
1209 gfc_error ("index in dimension %d is out of bounds "
1210 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1218 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1219 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1220 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1226 /* Obtain the stride. */
1228 mpz_set (stride
[d
], step
->value
.integer
);
1230 mpz_set_ui (stride
[d
], one
);
1232 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1233 mpz_set_ui (stride
[d
], one
);
1235 /* Obtain the start value for the index. */
1237 mpz_set (start
[d
], begin
->value
.integer
);
1239 mpz_set (start
[d
], lower
->value
.integer
);
1241 mpz_set (ctr
[d
], start
[d
]);
1243 /* Obtain the end value for the index. */
1245 mpz_set (end
[d
], finish
->value
.integer
);
1247 mpz_set (end
[d
], upper
->value
.integer
);
1249 /* Separate 'if' because elements sometimes arrive with
1251 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1252 mpz_set (end
[d
], begin
->value
.integer
);
1254 /* Check the bounds. */
1255 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1256 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1257 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1258 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1260 gfc_error ("index in dimension %d is out of bounds "
1261 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1266 /* Calculate the number of elements and the shape. */
1267 mpz_set (tmp_mpz
, stride
[d
]);
1268 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1269 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1270 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1271 mpz_mul (nelts
, nelts
, tmp_mpz
);
1273 /* An element reference reduces the rank of the expression; don't
1274 add anything to the shape array. */
1275 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1276 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1279 /* Calculate the 'stride' (=delta) for conversion of the
1280 counter values into the index along the constructor. */
1281 mpz_set (delta
[d
], delta_mpz
);
1282 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1283 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1284 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1291 /* Now clock through the array reference, calculating the index in
1292 the source constructor and transferring the elements to the new
1294 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1296 if (ref
->u
.ar
.offset
)
1297 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1299 mpz_init_set_ui (ptr
, 0);
1302 for (d
= 0; d
< rank
; d
++)
1304 mpz_set (tmp_mpz
, ctr
[d
]);
1305 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1306 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1307 mpz_add (ptr
, ptr
, tmp_mpz
);
1309 if (!incr_ctr
) continue;
1311 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1313 gcc_assert(vecsub
[d
]);
1315 if (!vecsub
[d
]->next
)
1316 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1319 vecsub
[d
] = vecsub
[d
]->next
;
1322 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1326 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1328 if (mpz_cmp_ui (stride
[d
], 0) > 0
1329 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1330 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1331 mpz_set (ctr
[d
], start
[d
]);
1337 /* There must be a better way of dealing with negative strides
1338 than resetting the index and the constructor pointer! */
1339 if (mpz_cmp (ptr
, index
) < 0)
1341 mpz_set_ui (index
, 0);
1345 while (cons
&& cons
->next
&& mpz_cmp (ptr
, index
) > 0)
1347 mpz_add_ui (index
, index
, one
);
1351 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1359 mpz_clear (delta_mpz
);
1360 mpz_clear (tmp_mpz
);
1362 for (d
= 0; d
< rank
; d
++)
1364 mpz_clear (delta
[d
]);
1365 mpz_clear (start
[d
]);
1368 mpz_clear (stride
[d
]);
1370 gfc_free_constructor (base
);
1374 /* Pull a substring out of an expression. */
1377 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1384 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1385 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1388 *newp
= gfc_copy_expr (p
);
1389 gfc_free ((*newp
)->value
.character
.string
);
1391 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1392 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1393 length
= end
- start
+ 1;
1395 chr
= (*newp
)->value
.character
.string
= gfc_getmem (length
+ 1);
1396 (*newp
)->value
.character
.length
= length
;
1397 memcpy (chr
, &p
->value
.character
.string
[start
- 1], length
);
1404 /* Simplify a subobject reference of a constructor. This occurs when
1405 parameter variable values are substituted. */
1408 simplify_const_ref (gfc_expr
*p
)
1410 gfc_constructor
*cons
;
1415 switch (p
->ref
->type
)
1418 switch (p
->ref
->u
.ar
.type
)
1421 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1428 remove_subobject_ref (p
, cons
);
1432 if (find_array_section (p
, p
->ref
) == FAILURE
)
1434 p
->ref
->u
.ar
.type
= AR_FULL
;
1439 if (p
->ref
->next
!= NULL
1440 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1442 cons
= p
->value
.constructor
;
1443 for (; cons
; cons
= cons
->next
)
1445 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1446 simplify_const_ref (cons
->expr
);
1449 gfc_free_ref_list (p
->ref
);
1460 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1461 remove_subobject_ref (p
, cons
);
1465 if (find_substring_ref (p
, &newp
) == FAILURE
)
1468 gfc_replace_expr (p
, newp
);
1469 gfc_free_ref_list (p
->ref
);
1479 /* Simplify a chain of references. */
1482 simplify_ref_chain (gfc_ref
*ref
, int type
)
1486 for (; ref
; ref
= ref
->next
)
1491 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1493 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1495 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1497 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1503 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1505 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1517 /* Try to substitute the value of a parameter variable. */
1520 simplify_parameter_variable (gfc_expr
*p
, int type
)
1525 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1531 /* Do not copy subobject refs for constant. */
1532 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1533 e
->ref
= copy_ref (p
->ref
);
1534 t
= gfc_simplify_expr (e
, type
);
1536 /* Only use the simplification if it eliminated all subobject references. */
1537 if (t
== SUCCESS
&& !e
->ref
)
1538 gfc_replace_expr (p
, e
);
1545 /* Given an expression, simplify it by collapsing constant
1546 expressions. Most simplification takes place when the expression
1547 tree is being constructed. If an intrinsic function is simplified
1548 at some point, we get called again to collapse the result against
1551 We work by recursively simplifying expression nodes, simplifying
1552 intrinsic functions where possible, which can lead to further
1553 constant collapsing. If an operator has constant operand(s), we
1554 rip the expression apart, and rebuild it, hoping that it becomes
1557 The expression type is defined for:
1558 0 Basic expression parsing
1559 1 Simplifying array constructors -- will substitute
1561 Returns FAILURE on error, SUCCESS otherwise.
1562 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1565 gfc_simplify_expr (gfc_expr
*p
, int type
)
1567 gfc_actual_arglist
*ap
;
1572 switch (p
->expr_type
)
1579 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1580 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1583 if (p
->value
.function
.isym
!= NULL
1584 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1589 case EXPR_SUBSTRING
:
1590 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1593 if (gfc_is_constant_expr (p
))
1598 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1600 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1601 start
--; /* Convert from one-based to zero-based. */
1606 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1607 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1609 end
= p
->value
.character
.length
;
1611 s
= gfc_getmem (end
- start
+ 2);
1612 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1613 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1614 gfc_free (p
->value
.character
.string
);
1615 p
->value
.character
.string
= s
;
1616 p
->value
.character
.length
= end
- start
;
1617 p
->ts
.cl
= gfc_get_charlen ();
1618 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1619 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1620 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1621 gfc_free_ref_list (p
->ref
);
1623 p
->expr_type
= EXPR_CONSTANT
;
1628 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1633 /* Only substitute array parameter variables if we are in an
1634 initialization expression, or we want a subsection. */
1635 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1636 && (gfc_init_expr
|| p
->ref
1637 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1639 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1646 gfc_simplify_iterator_var (p
);
1649 /* Simplify subcomponent references. */
1650 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1655 case EXPR_STRUCTURE
:
1657 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1660 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1663 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1664 && p
->ref
->u
.ar
.type
== AR_FULL
)
1665 gfc_expand_constructor (p
);
1667 if (simplify_const_ref (p
) == FAILURE
)
1677 /* Returns the type of an expression with the exception that iterator
1678 variables are automatically integers no matter what else they may
1684 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1691 /* Check an intrinsic arithmetic operation to see if it is consistent
1692 with some type of expression. */
1694 static try check_init_expr (gfc_expr
*);
1697 /* Scalarize an expression for an elemental intrinsic call. */
1700 scalarize_intrinsic_call (gfc_expr
*e
)
1702 gfc_actual_arglist
*a
, *b
;
1703 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1704 gfc_expr
*expr
, *old
;
1707 old
= gfc_copy_expr (e
);
1709 /* Assume that the old expression carries the type information and
1710 that the first arg carries all the shape information. */
1711 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1712 gfc_free_constructor (expr
->value
.constructor
);
1713 expr
->value
.constructor
= NULL
;
1716 expr
->expr_type
= EXPR_ARRAY
;
1718 /* Copy the array argument constructors into an array, with nulls
1721 a
= old
->value
.function
.actual
;
1722 for (; a
; a
= a
->next
)
1724 /* Check that this is OK for an initialization expression. */
1725 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1729 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1731 rank
[n
] = a
->expr
->rank
;
1732 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1733 args
[n
] = gfc_copy_constructor (ctor
);
1735 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1738 rank
[n
] = a
->expr
->rank
;
1741 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1748 for (i
= 1; i
< n
; i
++)
1749 if (rank
[i
] && rank
[i
] != rank
[0])
1752 /* Using the first argument as the master, step through the array
1753 calling the function for each element and advancing the array
1754 constructors together. */
1757 for (; ctor
; ctor
= ctor
->next
)
1759 if (expr
->value
.constructor
== NULL
)
1760 expr
->value
.constructor
1761 = new_ctor
= gfc_get_constructor ();
1764 new_ctor
->next
= gfc_get_constructor ();
1765 new_ctor
= new_ctor
->next
;
1767 new_ctor
->expr
= gfc_copy_expr (old
);
1768 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1770 b
= old
->value
.function
.actual
;
1771 for (i
= 0; i
< n
; i
++)
1774 new_ctor
->expr
->value
.function
.actual
1775 = a
= gfc_get_actual_arglist ();
1778 a
->next
= gfc_get_actual_arglist ();
1782 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1784 a
->expr
= gfc_copy_expr (b
->expr
);
1789 /* Simplify the function calls. */
1790 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1793 for (i
= 0; i
< n
; i
++)
1795 args
[i
] = args
[i
]->next
;
1797 for (i
= 1; i
< n
; i
++)
1798 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1799 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1805 gfc_free_expr (old
);
1809 gfc_error_now ("elemental function arguments at %C are not compliant");
1812 gfc_free_expr (expr
);
1813 gfc_free_expr (old
);
1819 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1821 gfc_expr
*op1
= e
->value
.op
.op1
;
1822 gfc_expr
*op2
= e
->value
.op
.op2
;
1824 if ((*check_function
) (op1
) == FAILURE
)
1827 switch (e
->value
.op
.operator)
1829 case INTRINSIC_UPLUS
:
1830 case INTRINSIC_UMINUS
:
1831 if (!numeric_type (et0 (op1
)))
1836 case INTRINSIC_EQ_OS
:
1838 case INTRINSIC_NE_OS
:
1840 case INTRINSIC_GT_OS
:
1842 case INTRINSIC_GE_OS
:
1844 case INTRINSIC_LT_OS
:
1846 case INTRINSIC_LE_OS
:
1847 if ((*check_function
) (op2
) == FAILURE
)
1850 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1851 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1853 gfc_error ("Numeric or CHARACTER operands are required in "
1854 "expression at %L", &e
->where
);
1859 case INTRINSIC_PLUS
:
1860 case INTRINSIC_MINUS
:
1861 case INTRINSIC_TIMES
:
1862 case INTRINSIC_DIVIDE
:
1863 case INTRINSIC_POWER
:
1864 if ((*check_function
) (op2
) == FAILURE
)
1867 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1870 if (e
->value
.op
.operator == INTRINSIC_POWER
1871 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1873 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1874 "exponent in an initialization "
1875 "expression at %L", &op2
->where
)
1882 case INTRINSIC_CONCAT
:
1883 if ((*check_function
) (op2
) == FAILURE
)
1886 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1888 gfc_error ("Concatenation operator in expression at %L "
1889 "must have two CHARACTER operands", &op1
->where
);
1893 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1895 gfc_error ("Concat operator at %L must concatenate strings of the "
1896 "same kind", &e
->where
);
1903 if (et0 (op1
) != BT_LOGICAL
)
1905 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1906 "operand", &op1
->where
);
1915 case INTRINSIC_NEQV
:
1916 if ((*check_function
) (op2
) == FAILURE
)
1919 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1921 gfc_error ("LOGICAL operands are required in expression at %L",
1928 case INTRINSIC_PARENTHESES
:
1932 gfc_error ("Only intrinsic operators can be used in expression at %L",
1940 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1947 check_init_expr_arguments (gfc_expr
*e
)
1949 gfc_actual_arglist
*ap
;
1951 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1952 if (check_init_expr (ap
->expr
) == FAILURE
)
1958 /* F95, 7.1.6.1, Initialization expressions, (7)
1959 F2003, 7.1.7 Initialization expression, (8) */
1962 check_inquiry (gfc_expr
*e
, int not_restricted
)
1965 const char *const *functions
;
1967 static const char *const inquiry_func_f95
[] = {
1968 "lbound", "shape", "size", "ubound",
1969 "bit_size", "len", "kind",
1970 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1971 "precision", "radix", "range", "tiny",
1975 static const char *const inquiry_func_f2003
[] = {
1976 "lbound", "shape", "size", "ubound",
1977 "bit_size", "len", "kind",
1978 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1979 "precision", "radix", "range", "tiny",
1984 gfc_actual_arglist
*ap
;
1986 if (!e
->value
.function
.isym
1987 || !e
->value
.function
.isym
->inquiry
)
1990 /* An undeclared parameter will get us here (PR25018). */
1991 if (e
->symtree
== NULL
)
1994 name
= e
->symtree
->n
.sym
->name
;
1996 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1997 ? inquiry_func_f2003
: inquiry_func_f95
;
1999 for (i
= 0; functions
[i
]; i
++)
2000 if (strcmp (functions
[i
], name
) == 0)
2003 if (functions
[i
] == NULL
)
2006 /* At this point we have an inquiry function with a variable argument. The
2007 type of the variable might be undefined, but we need it now, because the
2008 arguments of these functions are not allowed to be undefined. */
2010 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2015 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2017 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2018 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2022 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2025 /* Assumed character length will not reduce to a constant expression
2026 with LEN, as required by the standard. */
2027 if (i
== 5 && not_restricted
2028 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2029 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2031 gfc_error ("Assumed character length variable '%s' in constant "
2032 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2035 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2043 /* F95, 7.1.6.1, Initialization expressions, (5)
2044 F2003, 7.1.7 Initialization expression, (5) */
2047 check_transformational (gfc_expr
*e
)
2049 static const char * const trans_func_f95
[] = {
2050 "repeat", "reshape", "selected_int_kind",
2051 "selected_real_kind", "transfer", "trim", NULL
2057 if (!e
->value
.function
.isym
2058 || !e
->value
.function
.isym
->transformational
)
2061 name
= e
->symtree
->n
.sym
->name
;
2063 /* NULL() is dealt with below. */
2064 if (strcmp ("null", name
) == 0)
2067 for (i
= 0; trans_func_f95
[i
]; i
++)
2068 if (strcmp (trans_func_f95
[i
], name
) == 0)
2071 /* FIXME, F2003: implement translation of initialization
2072 expressions before enabling this check. For F95, error
2073 out if the transformational function is not in the list. */
2075 if (trans_func_f95
[i
] == NULL
2076 && gfc_notify_std (GFC_STD_F2003
,
2077 "transformational intrinsic '%s' at %L is not permitted "
2078 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2081 if (trans_func_f95
[i
] == NULL
)
2083 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2084 "in an initialization expression", name
, &e
->where
);
2089 return check_init_expr_arguments (e
);
2093 /* F95, 7.1.6.1, Initialization expressions, (6)
2094 F2003, 7.1.7 Initialization expression, (6) */
2097 check_null (gfc_expr
*e
)
2099 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2102 return check_init_expr_arguments (e
);
2107 check_elemental (gfc_expr
*e
)
2109 if (!e
->value
.function
.isym
2110 || !e
->value
.function
.isym
->elemental
)
2113 if (e
->ts
.type
!= BT_INTEGER
2114 && e
->ts
.type
!= BT_CHARACTER
2115 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2116 "nonstandard initialization expression at %L",
2117 &e
->where
) == FAILURE
)
2120 return check_init_expr_arguments (e
);
2125 check_conversion (gfc_expr
*e
)
2127 if (!e
->value
.function
.isym
2128 || !e
->value
.function
.isym
->conversion
)
2131 return check_init_expr_arguments (e
);
2135 /* Verify that an expression is an initialization expression. A side
2136 effect is that the expression tree is reduced to a single constant
2137 node if all goes well. This would normally happen when the
2138 expression is constructed but function references are assumed to be
2139 intrinsics in the context of initialization expressions. If
2140 FAILURE is returned an error message has been generated. */
2143 check_init_expr (gfc_expr
*e
)
2147 gfc_intrinsic_sym
*isym
;
2152 switch (e
->expr_type
)
2155 t
= check_intrinsic_op (e
, check_init_expr
);
2157 t
= gfc_simplify_expr (e
, 0);
2164 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2166 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2168 gfc_error ("Function '%s' in initialization expression at %L "
2169 "must be an intrinsic or a specification function",
2170 e
->symtree
->n
.sym
->name
, &e
->where
);
2174 if ((m
= check_conversion (e
)) == MATCH_NO
2175 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2176 && (m
= check_null (e
)) == MATCH_NO
2177 && (m
= check_transformational (e
)) == MATCH_NO
2178 && (m
= check_elemental (e
)) == MATCH_NO
)
2180 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2181 "in an initialization expression",
2182 e
->symtree
->n
.sym
->name
, &e
->where
);
2186 /* Try to scalarize an elemental intrinsic function that has an
2188 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2189 if (isym
&& isym
->elemental
2190 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2192 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2198 t
= gfc_simplify_expr (e
, 0);
2205 if (gfc_check_iter_variable (e
) == SUCCESS
)
2208 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2210 /* A PARAMETER shall not be used to define itself, i.e.
2211 REAL, PARAMETER :: x = transfer(0, x)
2213 if (!e
->symtree
->n
.sym
->value
)
2215 gfc_error("PARAMETER '%s' is used at %L before its definition "
2216 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2220 t
= simplify_parameter_variable (e
, 0);
2225 if (gfc_in_match_data ())
2230 if (e
->symtree
->n
.sym
->as
)
2232 switch (e
->symtree
->n
.sym
->as
->type
)
2234 case AS_ASSUMED_SIZE
:
2235 gfc_error ("Assumed size array '%s' at %L is not permitted "
2236 "in an initialization expression",
2237 e
->symtree
->n
.sym
->name
, &e
->where
);
2240 case AS_ASSUMED_SHAPE
:
2241 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2242 "in an initialization expression",
2243 e
->symtree
->n
.sym
->name
, &e
->where
);
2247 gfc_error ("Deferred array '%s' at %L is not permitted "
2248 "in an initialization expression",
2249 e
->symtree
->n
.sym
->name
, &e
->where
);
2253 gfc_error ("Array '%s' at %L is a variable, which does "
2254 "not reduce to a constant expression",
2255 e
->symtree
->n
.sym
->name
, &e
->where
);
2263 gfc_error ("Parameter '%s' at %L has not been declared or is "
2264 "a variable, which does not reduce to a constant "
2265 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2274 case EXPR_SUBSTRING
:
2275 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2279 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2281 t
= gfc_simplify_expr (e
, 0);
2285 case EXPR_STRUCTURE
:
2289 t
= gfc_check_constructor (e
, check_init_expr
);
2293 t
= gfc_check_constructor (e
, check_init_expr
);
2297 t
= gfc_expand_constructor (e
);
2301 t
= gfc_check_constructor_type (e
);
2305 gfc_internal_error ("check_init_expr(): Unknown expression type");
2312 /* Match an initialization expression. We work by first matching an
2313 expression, then reducing it to a constant. */
2316 gfc_match_init_expr (gfc_expr
**result
)
2322 m
= gfc_match_expr (&expr
);
2327 t
= gfc_resolve_expr (expr
);
2329 t
= check_init_expr (expr
);
2334 gfc_free_expr (expr
);
2338 if (expr
->expr_type
== EXPR_ARRAY
2339 && (gfc_check_constructor_type (expr
) == FAILURE
2340 || gfc_expand_constructor (expr
) == FAILURE
))
2342 gfc_free_expr (expr
);
2346 /* Not all inquiry functions are simplified to constant expressions
2347 so it is necessary to call check_inquiry again. */
2348 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2349 && !gfc_in_match_data ())
2351 gfc_error ("Initialization expression didn't reduce %C");
2361 static try check_restricted (gfc_expr
*);
2363 /* Given an actual argument list, test to see that each argument is a
2364 restricted expression and optionally if the expression type is
2365 integer or character. */
2368 restricted_args (gfc_actual_arglist
*a
)
2370 for (; a
; a
= a
->next
)
2372 if (check_restricted (a
->expr
) == FAILURE
)
2380 /************* Restricted/specification expressions *************/
2383 /* Make sure a non-intrinsic function is a specification function. */
2386 external_spec_function (gfc_expr
*e
)
2390 f
= e
->value
.function
.esym
;
2392 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2394 gfc_error ("Specification function '%s' at %L cannot be a statement "
2395 "function", f
->name
, &e
->where
);
2399 if (f
->attr
.proc
== PROC_INTERNAL
)
2401 gfc_error ("Specification function '%s' at %L cannot be an internal "
2402 "function", f
->name
, &e
->where
);
2406 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2408 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2413 if (f
->attr
.recursive
)
2415 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2416 f
->name
, &e
->where
);
2420 return restricted_args (e
->value
.function
.actual
);
2424 /* Check to see that a function reference to an intrinsic is a
2425 restricted expression. */
2428 restricted_intrinsic (gfc_expr
*e
)
2430 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2431 if (check_inquiry (e
, 0) == MATCH_YES
)
2434 return restricted_args (e
->value
.function
.actual
);
2438 /* Verify that an expression is a restricted expression. Like its
2439 cousin check_init_expr(), an error message is generated if we
2443 check_restricted (gfc_expr
*e
)
2451 switch (e
->expr_type
)
2454 t
= check_intrinsic_op (e
, check_restricted
);
2456 t
= gfc_simplify_expr (e
, 0);
2461 t
= e
->value
.function
.esym
? external_spec_function (e
)
2462 : restricted_intrinsic (e
);
2466 sym
= e
->symtree
->n
.sym
;
2469 /* If a dummy argument appears in a context that is valid for a
2470 restricted expression in an elemental procedure, it will have
2471 already been simplified away once we get here. Therefore we
2472 don't need to jump through hoops to distinguish valid from
2474 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2475 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2477 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2478 sym
->name
, &e
->where
);
2482 if (sym
->attr
.optional
)
2484 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2485 sym
->name
, &e
->where
);
2489 if (sym
->attr
.intent
== INTENT_OUT
)
2491 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2492 sym
->name
, &e
->where
);
2496 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2497 processed in resolve.c(resolve_formal_arglist). This is done so
2498 that host associated dummy array indices are accepted (PR23446).
2499 This mechanism also does the same for the specification expressions
2500 of array-valued functions. */
2501 if (sym
->attr
.in_common
2502 || sym
->attr
.use_assoc
2504 || sym
->attr
.implied_index
2505 || sym
->ns
!= gfc_current_ns
2506 || (sym
->ns
->proc_name
!= NULL
2507 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2508 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2514 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2515 sym
->name
, &e
->where
);
2524 case EXPR_SUBSTRING
:
2525 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2529 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2531 t
= gfc_simplify_expr (e
, 0);
2535 case EXPR_STRUCTURE
:
2536 t
= gfc_check_constructor (e
, check_restricted
);
2540 t
= gfc_check_constructor (e
, check_restricted
);
2544 gfc_internal_error ("check_restricted(): Unknown expression type");
2551 /* Check to see that an expression is a specification expression. If
2552 we return FAILURE, an error has been generated. */
2555 gfc_specification_expr (gfc_expr
*e
)
2561 if (e
->ts
.type
!= BT_INTEGER
)
2563 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2567 if (e
->expr_type
== EXPR_FUNCTION
2568 && !e
->value
.function
.isym
2569 && !e
->value
.function
.esym
2570 && !gfc_pure (e
->symtree
->n
.sym
))
2572 gfc_error ("Function '%s' at %L must be PURE",
2573 e
->symtree
->n
.sym
->name
, &e
->where
);
2574 /* Prevent repeat error messages. */
2575 e
->symtree
->n
.sym
->attr
.pure
= 1;
2581 gfc_error ("Expression at %L must be scalar", &e
->where
);
2585 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2588 return check_restricted (e
);
2592 /************** Expression conformance checks. *************/
2594 /* Given two expressions, make sure that the arrays are conformable. */
2597 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2599 int op1_flag
, op2_flag
, d
;
2600 mpz_t op1_size
, op2_size
;
2603 if (op1
->rank
== 0 || op2
->rank
== 0)
2606 if (op1
->rank
!= op2
->rank
)
2608 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2609 op1
->rank
, op2
->rank
, &op1
->where
);
2615 for (d
= 0; d
< op1
->rank
; d
++)
2617 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2618 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2620 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2622 gfc_error ("Different shape for %s at %L on dimension %d "
2623 "(%d and %d)", _(optype_msgid
), &op1
->where
, d
+ 1,
2624 (int) mpz_get_si (op1_size
),
2625 (int) mpz_get_si (op2_size
));
2631 mpz_clear (op1_size
);
2633 mpz_clear (op2_size
);
2643 /* Given an assignable expression and an arbitrary expression, make
2644 sure that the assignment can take place. */
2647 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2653 sym
= lvalue
->symtree
->n
.sym
;
2655 /* Check INTENT(IN), unless the object itself is the component or
2656 sub-component of a pointer. */
2657 has_pointer
= sym
->attr
.pointer
;
2659 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2660 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2666 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2668 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2669 sym
->name
, &lvalue
->where
);
2673 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2674 variable local to a function subprogram. Its existence begins when
2675 execution of the function is initiated and ends when execution of the
2676 function is terminated...
2677 Therefore, the left hand side is no longer a variable, when it is: */
2678 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2679 && !sym
->attr
.external
)
2684 /* (i) Use associated; */
2685 if (sym
->attr
.use_assoc
)
2688 /* (ii) The assignment is in the main program; or */
2689 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2692 /* (iii) A module or internal procedure... */
2693 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2694 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2695 && gfc_current_ns
->parent
2696 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2697 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2698 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2700 /* ... that is not a function... */
2701 if (!gfc_current_ns
->proc_name
->attr
.function
)
2704 /* ... or is not an entry and has a different name. */
2705 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2709 /* (iv) Host associated and not the function symbol or the
2710 parent result. This picks up sibling references, which
2711 cannot be entries. */
2712 if (!sym
->attr
.entry
2713 && sym
->ns
== gfc_current_ns
->parent
2714 && sym
!= gfc_current_ns
->proc_name
2715 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
2720 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2725 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2727 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2728 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2732 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2734 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2739 if (rvalue
->expr_type
== EXPR_NULL
)
2741 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2742 && lvalue
->symtree
->n
.sym
->attr
.data
)
2746 gfc_error ("NULL appears on right-hand side in assignment at %L",
2752 if (sym
->attr
.cray_pointee
2753 && lvalue
->ref
!= NULL
2754 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2755 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2757 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2758 "is illegal", &lvalue
->where
);
2762 /* This is possibly a typo: x = f() instead of x => f(). */
2763 if (gfc_option
.warn_surprising
2764 && rvalue
->expr_type
== EXPR_FUNCTION
2765 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2766 gfc_warning ("POINTER valued function appears on right-hand side of "
2767 "assignment at %L", &rvalue
->where
);
2769 /* Check size of array assignments. */
2770 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2771 && gfc_check_conformance ("array assignment", lvalue
, rvalue
) != SUCCESS
)
2774 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
2775 && lvalue
->symtree
->n
.sym
->attr
.data
2776 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
2777 "initialize non-integer variable '%s'",
2778 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
2781 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
2782 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
2783 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2784 &rvalue
->where
) == FAILURE
)
2787 /* Handle the case of a BOZ literal on the RHS. */
2788 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
2791 if (gfc_option
.warn_surprising
)
2792 gfc_warning ("BOZ literal at %L is bitwise transferred "
2793 "non-integer symbol '%s'", &rvalue
->where
,
2794 lvalue
->symtree
->n
.sym
->name
);
2795 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
2797 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
2799 if (rc
== ARITH_UNDERFLOW
)
2800 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2801 ". This check can be disabled with the option "
2802 "-fno-range-check", &rvalue
->where
);
2803 else if (rc
== ARITH_OVERFLOW
)
2804 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2805 ". This check can be disabled with the option "
2806 "-fno-range-check", &rvalue
->where
);
2807 else if (rc
== ARITH_NAN
)
2808 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2809 ". This check can be disabled with the option "
2810 "-fno-range-check", &rvalue
->where
);
2815 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2820 /* Numeric can be converted to any other numeric. And Hollerith can be
2821 converted to any other type. */
2822 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2823 || rvalue
->ts
.type
== BT_HOLLERITH
)
2826 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2829 gfc_error ("Incompatible types in assignment at %L; attempted assignment "
2830 "of %s to %s", &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2831 gfc_typename (&lvalue
->ts
));
2836 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2840 /* Check that a pointer assignment is OK. We first check lvalue, and
2841 we only check rvalue if it's not an assignment to NULL() or a
2842 NULLIFY statement. */
2845 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2847 symbol_attribute attr
;
2850 int pointer
, check_intent_in
;
2852 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2854 gfc_error ("Pointer assignment target is not a POINTER at %L",
2859 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2860 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2862 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2863 "l-value since it is a procedure",
2864 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2869 /* Check INTENT(IN), unless the object itself is the component or
2870 sub-component of a pointer. */
2871 check_intent_in
= 1;
2872 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2874 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2877 check_intent_in
= 0;
2879 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2883 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2885 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2886 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2892 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2896 is_pure
= gfc_pure (NULL
);
2898 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
2899 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
2901 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2905 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2906 kind, etc for lvalue and rvalue must match, and rvalue must be a
2907 pure variable if we're in a pure function. */
2908 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2911 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2913 gfc_error ("Different types in pointer assignment at %L; attempted "
2914 "assignment of %s to %s", &lvalue
->where
,
2915 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
2919 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2921 gfc_error ("Different kind type parameters in pointer "
2922 "assignment at %L", &lvalue
->where
);
2926 if (lvalue
->rank
!= rvalue
->rank
)
2928 gfc_error ("Different ranks in pointer assignment at %L",
2933 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2934 if (rvalue
->expr_type
== EXPR_NULL
)
2937 if (lvalue
->ts
.type
== BT_CHARACTER
2938 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2939 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2940 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2941 rvalue
->ts
.cl
->length
)) == 1)
2943 gfc_error ("Different character lengths in pointer "
2944 "assignment at %L", &lvalue
->where
);
2948 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
2949 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
2951 attr
= gfc_expr_attr (rvalue
);
2952 if (!attr
.target
&& !attr
.pointer
)
2954 gfc_error ("Pointer assignment target is neither TARGET "
2955 "nor POINTER at %L", &rvalue
->where
);
2959 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2961 gfc_error ("Bad target in pointer assignment in PURE "
2962 "procedure at %L", &rvalue
->where
);
2965 if (gfc_has_vector_index (rvalue
))
2967 gfc_error ("Pointer assignment with vector subscript "
2968 "on rhs at %L", &rvalue
->where
);
2972 if (attr
.protected && attr
.use_assoc
)
2974 gfc_error ("Pointer assigment target has PROTECTED "
2975 "attribute at %L", &rvalue
->where
);
2983 /* Relative of gfc_check_assign() except that the lvalue is a single
2984 symbol. Used for initialization assignments. */
2987 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2992 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2994 lvalue
.expr_type
= EXPR_VARIABLE
;
2995 lvalue
.ts
= sym
->ts
;
2997 lvalue
.rank
= sym
->as
->rank
;
2998 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2999 lvalue
.symtree
->n
.sym
= sym
;
3000 lvalue
.where
= sym
->declared_at
;
3002 if (sym
->attr
.pointer
)
3003 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3005 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3007 gfc_free (lvalue
.symtree
);
3013 /* Get an expression for a default initializer. */
3016 gfc_default_initializer (gfc_typespec
*ts
)
3018 gfc_constructor
*tail
;
3022 /* See if we have a default initializer. */
3023 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3024 if (c
->initializer
|| c
->allocatable
)
3030 /* Build the constructor. */
3031 init
= gfc_get_expr ();
3032 init
->expr_type
= EXPR_STRUCTURE
;
3034 init
->where
= ts
->derived
->declared_at
;
3037 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3040 init
->value
.constructor
= tail
= gfc_get_constructor ();
3043 tail
->next
= gfc_get_constructor ();
3048 tail
->expr
= gfc_copy_expr (c
->initializer
);
3052 tail
->expr
= gfc_get_expr ();
3053 tail
->expr
->expr_type
= EXPR_NULL
;
3054 tail
->expr
->ts
= c
->ts
;
3061 /* Given a symbol, create an expression node with that symbol as a
3062 variable. If the symbol is array valued, setup a reference of the
3066 gfc_get_variable_expr (gfc_symtree
*var
)
3070 e
= gfc_get_expr ();
3071 e
->expr_type
= EXPR_VARIABLE
;
3073 e
->ts
= var
->n
.sym
->ts
;
3075 if (var
->n
.sym
->as
!= NULL
)
3077 e
->rank
= var
->n
.sym
->as
->rank
;
3078 e
->ref
= gfc_get_ref ();
3079 e
->ref
->type
= REF_ARRAY
;
3080 e
->ref
->u
.ar
.type
= AR_FULL
;
3087 /* General expression traversal function. */
3090 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3091 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3096 gfc_actual_arglist
*args
;
3103 if ((*func
) (expr
, sym
, &f
))
3106 if (expr
->ts
.type
== BT_CHARACTER
3108 && expr
->ts
.cl
->length
3109 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3110 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3113 switch (expr
->expr_type
)
3116 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3118 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3126 case EXPR_SUBSTRING
:
3129 case EXPR_STRUCTURE
:
3131 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3133 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3137 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3139 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3141 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3143 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3150 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3152 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3168 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3170 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3172 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3174 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3180 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3182 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3187 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3188 && ref
->u
.c
.component
->ts
.cl
3189 && ref
->u
.c
.component
->ts
.cl
->length
3190 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3192 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3196 if (ref
->u
.c
.component
->as
)
3197 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3199 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3202 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3216 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3219 expr_set_symbols_referenced (gfc_expr
*expr
,
3220 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3221 int *f ATTRIBUTE_UNUSED
)
3223 if (expr
->expr_type
!= EXPR_VARIABLE
)
3225 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3230 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3232 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);