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 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
);
1056 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1079 /* Find a component of a structure constructor. */
1081 static gfc_constructor
*
1082 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1084 gfc_component
*comp
;
1085 gfc_component
*pick
;
1087 comp
= ref
->u
.c
.sym
->components
;
1088 pick
= ref
->u
.c
.component
;
1089 while (comp
!= pick
)
1099 /* Replace an expression with the contents of a constructor, removing
1100 the subobject reference in the process. */
1103 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1109 e
->ref
= p
->ref
->next
;
1110 p
->ref
->next
= NULL
;
1111 gfc_replace_expr (p
, e
);
1115 /* Pull an array section out of an array constructor. */
1118 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1124 long unsigned one
= 1;
1126 mpz_t start
[GFC_MAX_DIMENSIONS
];
1127 mpz_t end
[GFC_MAX_DIMENSIONS
];
1128 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1129 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1130 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1136 gfc_constructor
*cons
;
1137 gfc_constructor
*base
;
1143 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1148 base
= expr
->value
.constructor
;
1149 expr
->value
.constructor
= NULL
;
1151 rank
= ref
->u
.ar
.as
->rank
;
1153 if (expr
->shape
== NULL
)
1154 expr
->shape
= gfc_get_shape (rank
);
1156 mpz_init_set_ui (delta_mpz
, one
);
1157 mpz_init_set_ui (nelts
, one
);
1160 /* Do the initialization now, so that we can cleanup without
1161 keeping track of where we were. */
1162 for (d
= 0; d
< rank
; d
++)
1164 mpz_init (delta
[d
]);
1165 mpz_init (start
[d
]);
1168 mpz_init (stride
[d
]);
1172 /* Build the counters to clock through the array reference. */
1174 for (d
= 0; d
< rank
; d
++)
1176 /* Make this stretch of code easier on the eye! */
1177 begin
= ref
->u
.ar
.start
[d
];
1178 finish
= ref
->u
.ar
.end
[d
];
1179 step
= ref
->u
.ar
.stride
[d
];
1180 lower
= ref
->u
.ar
.as
->lower
[d
];
1181 upper
= ref
->u
.ar
.as
->upper
[d
];
1183 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1187 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1193 gcc_assert (begin
->rank
== 1);
1194 gcc_assert (begin
->shape
);
1196 vecsub
[d
] = begin
->value
.constructor
;
1197 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1198 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1199 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1202 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1204 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1205 || mpz_cmp (c
->expr
->value
.integer
,
1206 lower
->value
.integer
) < 0)
1208 gfc_error ("index in dimension %d is out of bounds "
1209 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1217 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1218 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1219 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1225 /* Obtain the stride. */
1227 mpz_set (stride
[d
], step
->value
.integer
);
1229 mpz_set_ui (stride
[d
], one
);
1231 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1232 mpz_set_ui (stride
[d
], one
);
1234 /* Obtain the start value for the index. */
1236 mpz_set (start
[d
], begin
->value
.integer
);
1238 mpz_set (start
[d
], lower
->value
.integer
);
1240 mpz_set (ctr
[d
], start
[d
]);
1242 /* Obtain the end value for the index. */
1244 mpz_set (end
[d
], finish
->value
.integer
);
1246 mpz_set (end
[d
], upper
->value
.integer
);
1248 /* Separate 'if' because elements sometimes arrive with
1250 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1251 mpz_set (end
[d
], begin
->value
.integer
);
1253 /* Check the bounds. */
1254 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1255 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1256 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1257 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1259 gfc_error ("index in dimension %d is out of bounds "
1260 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1265 /* Calculate the number of elements and the shape. */
1266 mpz_set (tmp_mpz
, stride
[d
]);
1267 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1268 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1269 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1270 mpz_mul (nelts
, nelts
, tmp_mpz
);
1272 /* An element reference reduces the rank of the expression; don't
1273 add anything to the shape array. */
1274 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1275 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1278 /* Calculate the 'stride' (=delta) for conversion of the
1279 counter values into the index along the constructor. */
1280 mpz_set (delta
[d
], delta_mpz
);
1281 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1282 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1283 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1290 /* Now clock through the array reference, calculating the index in
1291 the source constructor and transferring the elements to the new
1293 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1295 if (ref
->u
.ar
.offset
)
1296 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1298 mpz_init_set_ui (ptr
, 0);
1301 for (d
= 0; d
< rank
; d
++)
1303 mpz_set (tmp_mpz
, ctr
[d
]);
1304 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1305 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1306 mpz_add (ptr
, ptr
, tmp_mpz
);
1308 if (!incr_ctr
) continue;
1310 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1312 gcc_assert(vecsub
[d
]);
1314 if (!vecsub
[d
]->next
)
1315 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1318 vecsub
[d
] = vecsub
[d
]->next
;
1321 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1325 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1327 if (mpz_cmp_ui (stride
[d
], 0) > 0
1328 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1329 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1330 mpz_set (ctr
[d
], start
[d
]);
1336 /* There must be a better way of dealing with negative strides
1337 than resetting the index and the constructor pointer! */
1338 if (mpz_cmp (ptr
, index
) < 0)
1340 mpz_set_ui (index
, 0);
1344 while (mpz_cmp (ptr
, index
) > 0)
1346 mpz_add_ui (index
, index
, one
);
1350 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1358 mpz_clear (delta_mpz
);
1359 mpz_clear (tmp_mpz
);
1361 for (d
= 0; d
< rank
; d
++)
1363 mpz_clear (delta
[d
]);
1364 mpz_clear (start
[d
]);
1367 mpz_clear (stride
[d
]);
1369 gfc_free_constructor (base
);
1373 /* Pull a substring out of an expression. */
1376 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1383 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1384 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1387 *newp
= gfc_copy_expr (p
);
1388 gfc_free ((*newp
)->value
.character
.string
);
1390 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1391 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1392 length
= end
- start
+ 1;
1394 chr
= (*newp
)->value
.character
.string
= gfc_getmem (length
+ 1);
1395 (*newp
)->value
.character
.length
= length
;
1396 memcpy (chr
, &p
->value
.character
.string
[start
- 1], length
);
1403 /* Simplify a subobject reference of a constructor. This occurs when
1404 parameter variable values are substituted. */
1407 simplify_const_ref (gfc_expr
*p
)
1409 gfc_constructor
*cons
;
1414 switch (p
->ref
->type
)
1417 switch (p
->ref
->u
.ar
.type
)
1420 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1427 remove_subobject_ref (p
, cons
);
1431 if (find_array_section (p
, p
->ref
) == FAILURE
)
1433 p
->ref
->u
.ar
.type
= AR_FULL
;
1438 if (p
->ref
->next
!= NULL
1439 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1441 cons
= p
->value
.constructor
;
1442 for (; cons
; cons
= cons
->next
)
1444 cons
->expr
->ref
= copy_ref (p
->ref
->next
);
1445 simplify_const_ref (cons
->expr
);
1448 gfc_free_ref_list (p
->ref
);
1459 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1460 remove_subobject_ref (p
, cons
);
1464 if (find_substring_ref (p
, &newp
) == FAILURE
)
1467 gfc_replace_expr (p
, newp
);
1468 gfc_free_ref_list (p
->ref
);
1478 /* Simplify a chain of references. */
1481 simplify_ref_chain (gfc_ref
*ref
, int type
)
1485 for (; ref
; ref
= ref
->next
)
1490 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1492 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1494 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1496 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1502 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1504 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1516 /* Try to substitute the value of a parameter variable. */
1519 simplify_parameter_variable (gfc_expr
*p
, int type
)
1524 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1530 /* Do not copy subobject refs for constant. */
1531 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1532 e
->ref
= copy_ref (p
->ref
);
1533 t
= gfc_simplify_expr (e
, type
);
1535 /* Only use the simplification if it eliminated all subobject references. */
1536 if (t
== SUCCESS
&& !e
->ref
)
1537 gfc_replace_expr (p
, e
);
1544 /* Given an expression, simplify it by collapsing constant
1545 expressions. Most simplification takes place when the expression
1546 tree is being constructed. If an intrinsic function is simplified
1547 at some point, we get called again to collapse the result against
1550 We work by recursively simplifying expression nodes, simplifying
1551 intrinsic functions where possible, which can lead to further
1552 constant collapsing. If an operator has constant operand(s), we
1553 rip the expression apart, and rebuild it, hoping that it becomes
1556 The expression type is defined for:
1557 0 Basic expression parsing
1558 1 Simplifying array constructors -- will substitute
1560 Returns FAILURE on error, SUCCESS otherwise.
1561 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1564 gfc_simplify_expr (gfc_expr
*p
, int type
)
1566 gfc_actual_arglist
*ap
;
1571 switch (p
->expr_type
)
1578 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1579 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1582 if (p
->value
.function
.isym
!= NULL
1583 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1588 case EXPR_SUBSTRING
:
1589 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1592 if (gfc_is_constant_expr (p
))
1597 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1599 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1600 start
--; /* Convert from one-based to zero-based. */
1605 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1606 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1608 end
= p
->value
.character
.length
;
1610 s
= gfc_getmem (end
- start
+ 2);
1611 memcpy (s
, p
->value
.character
.string
+ start
, end
- start
);
1612 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1613 gfc_free (p
->value
.character
.string
);
1614 p
->value
.character
.string
= s
;
1615 p
->value
.character
.length
= end
- start
;
1616 p
->ts
.cl
= gfc_get_charlen ();
1617 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1618 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1619 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1620 gfc_free_ref_list (p
->ref
);
1622 p
->expr_type
= EXPR_CONSTANT
;
1627 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1632 /* Only substitute array parameter variables if we are in an
1633 initialization expression, or we want a subsection. */
1634 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1635 && (gfc_init_expr
|| p
->ref
1636 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1638 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1645 gfc_simplify_iterator_var (p
);
1648 /* Simplify subcomponent references. */
1649 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1654 case EXPR_STRUCTURE
:
1656 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1659 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1662 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1663 && p
->ref
->u
.ar
.type
== AR_FULL
)
1664 gfc_expand_constructor (p
);
1666 if (simplify_const_ref (p
) == FAILURE
)
1676 /* Returns the type of an expression with the exception that iterator
1677 variables are automatically integers no matter what else they may
1683 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1690 /* Check an intrinsic arithmetic operation to see if it is consistent
1691 with some type of expression. */
1693 static try check_init_expr (gfc_expr
*);
1696 /* Scalarize an expression for an elemental intrinsic call. */
1699 scalarize_intrinsic_call (gfc_expr
*e
)
1701 gfc_actual_arglist
*a
, *b
;
1702 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1703 gfc_expr
*expr
, *old
;
1706 old
= gfc_copy_expr (e
);
1708 /* Assume that the old expression carries the type information and
1709 that the first arg carries all the shape information. */
1710 expr
= gfc_copy_expr (old
->value
.function
.actual
->expr
);
1711 gfc_free_constructor (expr
->value
.constructor
);
1712 expr
->value
.constructor
= NULL
;
1715 expr
->expr_type
= EXPR_ARRAY
;
1717 /* Copy the array argument constructors into an array, with nulls
1720 a
= old
->value
.function
.actual
;
1721 for (; a
; a
= a
->next
)
1723 /* Check that this is OK for an initialization expression. */
1724 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1728 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1730 rank
[n
] = a
->expr
->rank
;
1731 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1732 args
[n
] = gfc_copy_constructor (ctor
);
1734 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1737 rank
[n
] = a
->expr
->rank
;
1740 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1747 for (i
= 1; i
< n
; i
++)
1748 if (rank
[i
] && rank
[i
] != rank
[0])
1751 /* Using the first argument as the master, step through the array
1752 calling the function for each element and advancing the array
1753 constructors together. */
1756 for (; ctor
; ctor
= ctor
->next
)
1758 if (expr
->value
.constructor
== NULL
)
1759 expr
->value
.constructor
1760 = new_ctor
= gfc_get_constructor ();
1763 new_ctor
->next
= gfc_get_constructor ();
1764 new_ctor
= new_ctor
->next
;
1766 new_ctor
->expr
= gfc_copy_expr (old
);
1767 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1769 b
= old
->value
.function
.actual
;
1770 for (i
= 0; i
< n
; i
++)
1773 new_ctor
->expr
->value
.function
.actual
1774 = a
= gfc_get_actual_arglist ();
1777 a
->next
= gfc_get_actual_arglist ();
1781 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1783 a
->expr
= gfc_copy_expr (b
->expr
);
1788 /* Simplify the function calls. */
1789 if (gfc_simplify_expr (new_ctor
->expr
, 0) == FAILURE
)
1792 for (i
= 0; i
< n
; i
++)
1794 args
[i
] = args
[i
]->next
;
1796 for (i
= 1; i
< n
; i
++)
1797 if (rank
[i
] && ((args
[i
] != NULL
&& args
[0] == NULL
)
1798 || (args
[i
] == NULL
&& args
[0] != NULL
)))
1804 gfc_free_expr (old
);
1808 gfc_error_now ("elemental function arguments at %C are not compliant");
1811 gfc_free_expr (expr
);
1812 gfc_free_expr (old
);
1818 check_intrinsic_op (gfc_expr
*e
, try (*check_function
) (gfc_expr
*))
1820 gfc_expr
*op1
= e
->value
.op
.op1
;
1821 gfc_expr
*op2
= e
->value
.op
.op2
;
1823 if ((*check_function
) (op1
) == FAILURE
)
1826 switch (e
->value
.op
.operator)
1828 case INTRINSIC_UPLUS
:
1829 case INTRINSIC_UMINUS
:
1830 if (!numeric_type (et0 (op1
)))
1835 case INTRINSIC_EQ_OS
:
1837 case INTRINSIC_NE_OS
:
1839 case INTRINSIC_GT_OS
:
1841 case INTRINSIC_GE_OS
:
1843 case INTRINSIC_LT_OS
:
1845 case INTRINSIC_LE_OS
:
1846 if ((*check_function
) (op2
) == FAILURE
)
1849 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1850 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1852 gfc_error ("Numeric or CHARACTER operands are required in "
1853 "expression at %L", &e
->where
);
1858 case INTRINSIC_PLUS
:
1859 case INTRINSIC_MINUS
:
1860 case INTRINSIC_TIMES
:
1861 case INTRINSIC_DIVIDE
:
1862 case INTRINSIC_POWER
:
1863 if ((*check_function
) (op2
) == FAILURE
)
1866 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1869 if (e
->value
.op
.operator == INTRINSIC_POWER
1870 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1872 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1873 "exponent in an initialization "
1874 "expression at %L", &op2
->where
)
1881 case INTRINSIC_CONCAT
:
1882 if ((*check_function
) (op2
) == FAILURE
)
1885 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1887 gfc_error ("Concatenation operator in expression at %L "
1888 "must have two CHARACTER operands", &op1
->where
);
1892 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1894 gfc_error ("Concat operator at %L must concatenate strings of the "
1895 "same kind", &e
->where
);
1902 if (et0 (op1
) != BT_LOGICAL
)
1904 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1905 "operand", &op1
->where
);
1914 case INTRINSIC_NEQV
:
1915 if ((*check_function
) (op2
) == FAILURE
)
1918 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1920 gfc_error ("LOGICAL operands are required in expression at %L",
1927 case INTRINSIC_PARENTHESES
:
1931 gfc_error ("Only intrinsic operators can be used in expression at %L",
1939 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
1946 check_init_expr_arguments (gfc_expr
*e
)
1948 gfc_actual_arglist
*ap
;
1950 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
1951 if (check_init_expr (ap
->expr
) == FAILURE
)
1957 /* F95, 7.1.6.1, Initialization expressions, (7)
1958 F2003, 7.1.7 Initialization expression, (8) */
1961 check_inquiry (gfc_expr
*e
, int not_restricted
)
1964 const char *const *functions
;
1966 static const char *const inquiry_func_f95
[] = {
1967 "lbound", "shape", "size", "ubound",
1968 "bit_size", "len", "kind",
1969 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1970 "precision", "radix", "range", "tiny",
1974 static const char *const inquiry_func_f2003
[] = {
1975 "lbound", "shape", "size", "ubound",
1976 "bit_size", "len", "kind",
1977 "digits", "epsilon", "huge", "maxexponent", "minexponent",
1978 "precision", "radix", "range", "tiny",
1983 gfc_actual_arglist
*ap
;
1985 if (!e
->value
.function
.isym
1986 || !e
->value
.function
.isym
->inquiry
)
1989 /* An undeclared parameter will get us here (PR25018). */
1990 if (e
->symtree
== NULL
)
1993 name
= e
->symtree
->n
.sym
->name
;
1995 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
1996 ? inquiry_func_f2003
: inquiry_func_f95
;
1998 for (i
= 0; functions
[i
]; i
++)
1999 if (strcmp (functions
[i
], name
) == 0)
2002 if (functions
[i
] == NULL
)
2005 /* At this point we have an inquiry function with a variable argument. The
2006 type of the variable might be undefined, but we need it now, because the
2007 arguments of these functions are not allowed to be undefined. */
2009 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2014 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2016 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2017 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2021 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2024 /* Assumed character length will not reduce to a constant expression
2025 with LEN, as required by the standard. */
2026 if (i
== 5 && not_restricted
2027 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2028 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2030 gfc_error ("Assumed character length variable '%s' in constant "
2031 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2034 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2042 /* F95, 7.1.6.1, Initialization expressions, (5)
2043 F2003, 7.1.7 Initialization expression, (5) */
2046 check_transformational (gfc_expr
*e
)
2048 static const char * const trans_func_f95
[] = {
2049 "repeat", "reshape", "selected_int_kind",
2050 "selected_real_kind", "transfer", "trim", NULL
2056 if (!e
->value
.function
.isym
2057 || !e
->value
.function
.isym
->transformational
)
2060 name
= e
->symtree
->n
.sym
->name
;
2062 /* NULL() is dealt with below. */
2063 if (strcmp ("null", name
) == 0)
2066 for (i
= 0; trans_func_f95
[i
]; i
++)
2067 if (strcmp (trans_func_f95
[i
], name
) == 0)
2070 /* FIXME, F2003: implement translation of initialization
2071 expressions before enabling this check. For F95, error
2072 out if the transformational function is not in the list. */
2074 if (trans_func_f95
[i
] == NULL
2075 && gfc_notify_std (GFC_STD_F2003
,
2076 "transformational intrinsic '%s' at %L is not permitted "
2077 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2080 if (trans_func_f95
[i
] == NULL
)
2082 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2083 "in an initialization expression", name
, &e
->where
);
2088 return check_init_expr_arguments (e
);
2092 /* F95, 7.1.6.1, Initialization expressions, (6)
2093 F2003, 7.1.7 Initialization expression, (6) */
2096 check_null (gfc_expr
*e
)
2098 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2101 return check_init_expr_arguments (e
);
2106 check_elemental (gfc_expr
*e
)
2108 if (!e
->value
.function
.isym
2109 || !e
->value
.function
.isym
->elemental
)
2112 if (e
->ts
.type
!= BT_INTEGER
2113 && e
->ts
.type
!= BT_CHARACTER
2114 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2115 "nonstandard initialization expression at %L",
2116 &e
->where
) == FAILURE
)
2119 return check_init_expr_arguments (e
);
2124 check_conversion (gfc_expr
*e
)
2126 if (!e
->value
.function
.isym
2127 || !e
->value
.function
.isym
->conversion
)
2130 return check_init_expr_arguments (e
);
2134 /* Verify that an expression is an initialization expression. A side
2135 effect is that the expression tree is reduced to a single constant
2136 node if all goes well. This would normally happen when the
2137 expression is constructed but function references are assumed to be
2138 intrinsics in the context of initialization expressions. If
2139 FAILURE is returned an error message has been generated. */
2142 check_init_expr (gfc_expr
*e
)
2146 gfc_intrinsic_sym
*isym
;
2151 switch (e
->expr_type
)
2154 t
= check_intrinsic_op (e
, check_init_expr
);
2156 t
= gfc_simplify_expr (e
, 0);
2163 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2165 if ((m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2167 gfc_error ("Function '%s' in initialization expression at %L "
2168 "must be an intrinsic or a specification function",
2169 e
->symtree
->n
.sym
->name
, &e
->where
);
2173 if ((m
= check_conversion (e
)) == MATCH_NO
2174 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2175 && (m
= check_null (e
)) == MATCH_NO
2176 && (m
= check_transformational (e
)) == MATCH_NO
2177 && (m
= check_elemental (e
)) == MATCH_NO
)
2179 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2180 "in an initialization expression",
2181 e
->symtree
->n
.sym
->name
, &e
->where
);
2185 /* Try to scalarize an elemental intrinsic function that has an
2187 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2188 if (isym
&& isym
->elemental
2189 && e
->value
.function
.actual
->expr
->expr_type
== EXPR_ARRAY
)
2191 if ((t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2197 t
= gfc_simplify_expr (e
, 0);
2204 if (gfc_check_iter_variable (e
) == SUCCESS
)
2207 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2209 /* A PARAMETER shall not be used to define itself, i.e.
2210 REAL, PARAMETER :: x = transfer(0, x)
2212 if (!e
->symtree
->n
.sym
->value
)
2214 gfc_error("PARAMETER '%s' is used at %L before its definition "
2215 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2219 t
= simplify_parameter_variable (e
, 0);
2224 if (gfc_in_match_data ())
2229 if (e
->symtree
->n
.sym
->as
)
2231 switch (e
->symtree
->n
.sym
->as
->type
)
2233 case AS_ASSUMED_SIZE
:
2234 gfc_error ("Assumed size array '%s' at %L is not permitted "
2235 "in an initialization expression",
2236 e
->symtree
->n
.sym
->name
, &e
->where
);
2239 case AS_ASSUMED_SHAPE
:
2240 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2241 "in an initialization expression",
2242 e
->symtree
->n
.sym
->name
, &e
->where
);
2246 gfc_error ("Deferred array '%s' at %L is not permitted "
2247 "in an initialization expression",
2248 e
->symtree
->n
.sym
->name
, &e
->where
);
2252 gfc_error ("Array '%s' at %L is a variable, which does "
2253 "not reduce to a constant expression",
2254 e
->symtree
->n
.sym
->name
, &e
->where
);
2262 gfc_error ("Parameter '%s' at %L has not been declared or is "
2263 "a variable, which does not reduce to a constant "
2264 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2273 case EXPR_SUBSTRING
:
2274 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2278 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2280 t
= gfc_simplify_expr (e
, 0);
2284 case EXPR_STRUCTURE
:
2288 t
= gfc_check_constructor (e
, check_init_expr
);
2292 t
= gfc_check_constructor (e
, check_init_expr
);
2296 t
= gfc_expand_constructor (e
);
2300 t
= gfc_check_constructor_type (e
);
2304 gfc_internal_error ("check_init_expr(): Unknown expression type");
2311 /* Match an initialization expression. We work by first matching an
2312 expression, then reducing it to a constant. */
2315 gfc_match_init_expr (gfc_expr
**result
)
2321 m
= gfc_match_expr (&expr
);
2326 t
= gfc_resolve_expr (expr
);
2328 t
= check_init_expr (expr
);
2333 gfc_free_expr (expr
);
2337 if (expr
->expr_type
== EXPR_ARRAY
2338 && (gfc_check_constructor_type (expr
) == FAILURE
2339 || gfc_expand_constructor (expr
) == FAILURE
))
2341 gfc_free_expr (expr
);
2345 /* Not all inquiry functions are simplified to constant expressions
2346 so it is necessary to call check_inquiry again. */
2347 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2348 && !gfc_in_match_data ())
2350 gfc_error ("Initialization expression didn't reduce %C");
2360 static try check_restricted (gfc_expr
*);
2362 /* Given an actual argument list, test to see that each argument is a
2363 restricted expression and optionally if the expression type is
2364 integer or character. */
2367 restricted_args (gfc_actual_arglist
*a
)
2369 for (; a
; a
= a
->next
)
2371 if (check_restricted (a
->expr
) == FAILURE
)
2379 /************* Restricted/specification expressions *************/
2382 /* Make sure a non-intrinsic function is a specification function. */
2385 external_spec_function (gfc_expr
*e
)
2389 f
= e
->value
.function
.esym
;
2391 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2393 gfc_error ("Specification function '%s' at %L cannot be a statement "
2394 "function", f
->name
, &e
->where
);
2398 if (f
->attr
.proc
== PROC_INTERNAL
)
2400 gfc_error ("Specification function '%s' at %L cannot be an internal "
2401 "function", f
->name
, &e
->where
);
2405 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2407 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2412 if (f
->attr
.recursive
)
2414 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2415 f
->name
, &e
->where
);
2419 return restricted_args (e
->value
.function
.actual
);
2423 /* Check to see that a function reference to an intrinsic is a
2424 restricted expression. */
2427 restricted_intrinsic (gfc_expr
*e
)
2429 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2430 if (check_inquiry (e
, 0) == MATCH_YES
)
2433 return restricted_args (e
->value
.function
.actual
);
2437 /* Verify that an expression is a restricted expression. Like its
2438 cousin check_init_expr(), an error message is generated if we
2442 check_restricted (gfc_expr
*e
)
2450 switch (e
->expr_type
)
2453 t
= check_intrinsic_op (e
, check_restricted
);
2455 t
= gfc_simplify_expr (e
, 0);
2460 t
= e
->value
.function
.esym
? external_spec_function (e
)
2461 : restricted_intrinsic (e
);
2465 sym
= e
->symtree
->n
.sym
;
2468 /* If a dummy argument appears in a context that is valid for a
2469 restricted expression in an elemental procedure, it will have
2470 already been simplified away once we get here. Therefore we
2471 don't need to jump through hoops to distinguish valid from
2473 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2474 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2476 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2477 sym
->name
, &e
->where
);
2481 if (sym
->attr
.optional
)
2483 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2484 sym
->name
, &e
->where
);
2488 if (sym
->attr
.intent
== INTENT_OUT
)
2490 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2491 sym
->name
, &e
->where
);
2495 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2496 processed in resolve.c(resolve_formal_arglist). This is done so
2497 that host associated dummy array indices are accepted (PR23446).
2498 This mechanism also does the same for the specification expressions
2499 of array-valued functions. */
2500 if (sym
->attr
.in_common
2501 || sym
->attr
.use_assoc
2503 || sym
->attr
.implied_index
2504 || sym
->ns
!= gfc_current_ns
2505 || (sym
->ns
->proc_name
!= NULL
2506 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2507 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2513 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2514 sym
->name
, &e
->where
);
2523 case EXPR_SUBSTRING
:
2524 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2528 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2530 t
= gfc_simplify_expr (e
, 0);
2534 case EXPR_STRUCTURE
:
2535 t
= gfc_check_constructor (e
, check_restricted
);
2539 t
= gfc_check_constructor (e
, check_restricted
);
2543 gfc_internal_error ("check_restricted(): Unknown expression type");
2550 /* Check to see that an expression is a specification expression. If
2551 we return FAILURE, an error has been generated. */
2554 gfc_specification_expr (gfc_expr
*e
)
2560 if (e
->ts
.type
!= BT_INTEGER
)
2562 gfc_error ("Expression at %L must be of INTEGER type", &e
->where
);
2566 if (e
->expr_type
== EXPR_FUNCTION
2567 && !e
->value
.function
.isym
2568 && !e
->value
.function
.esym
2569 && !gfc_pure (e
->symtree
->n
.sym
))
2571 gfc_error ("Function '%s' at %L must be PURE",
2572 e
->symtree
->n
.sym
->name
, &e
->where
);
2573 /* Prevent repeat error messages. */
2574 e
->symtree
->n
.sym
->attr
.pure
= 1;
2580 gfc_error ("Expression at %L must be scalar", &e
->where
);
2584 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2587 return check_restricted (e
);
2591 /************** Expression conformance checks. *************/
2593 /* Given two expressions, make sure that the arrays are conformable. */
2596 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2598 int op1_flag
, op2_flag
, d
;
2599 mpz_t op1_size
, op2_size
;
2602 if (op1
->rank
== 0 || op2
->rank
== 0)
2605 if (op1
->rank
!= op2
->rank
)
2607 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2608 op1
->rank
, op2
->rank
, &op1
->where
);
2614 for (d
= 0; d
< op1
->rank
; d
++)
2616 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2617 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2619 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2621 gfc_error ("Different shape for %s at %L on dimension %d "
2622 "(%d and %d)", _(optype_msgid
), &op1
->where
, d
+ 1,
2623 (int) mpz_get_si (op1_size
),
2624 (int) mpz_get_si (op2_size
));
2630 mpz_clear (op1_size
);
2632 mpz_clear (op2_size
);
2642 /* Given an assignable expression and an arbitrary expression, make
2643 sure that the assignment can take place. */
2646 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2652 sym
= lvalue
->symtree
->n
.sym
;
2654 /* Check INTENT(IN), unless the object itself is the component or
2655 sub-component of a pointer. */
2656 has_pointer
= sym
->attr
.pointer
;
2658 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2659 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2665 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2667 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2668 sym
->name
, &lvalue
->where
);
2672 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2673 variable local to a function subprogram. Its existence begins when
2674 execution of the function is initiated and ends when execution of the
2675 function is terminated...
2676 Therefore, the left hand side is no longer a variable, when it is: */
2677 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2678 && !sym
->attr
.external
)
2683 /* (i) Use associated; */
2684 if (sym
->attr
.use_assoc
)
2687 /* (ii) The assignment is in the main program; or */
2688 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2691 /* (iii) A module or internal procedure... */
2692 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2693 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2694 && gfc_current_ns
->parent
2695 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2696 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2697 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2699 /* ... that is not a function... */
2700 if (!gfc_current_ns
->proc_name
->attr
.function
)
2703 /* ... or is not an entry and has a different name. */
2704 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2708 /* (iv) Host associated and not the function symbol or the
2709 parent result. This picks up sibling references, which
2710 cannot be entries. */
2711 if (!sym
->attr
.entry
2712 && sym
->ns
== gfc_current_ns
->parent
2713 && sym
!= gfc_current_ns
->proc_name
2714 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
2719 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2724 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2726 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2727 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2731 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2733 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2738 if (rvalue
->expr_type
== EXPR_NULL
)
2740 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2741 && lvalue
->symtree
->n
.sym
->attr
.data
)
2745 gfc_error ("NULL appears on right-hand side in assignment at %L",
2751 if (sym
->attr
.cray_pointee
2752 && lvalue
->ref
!= NULL
2753 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2754 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2756 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2757 "is illegal", &lvalue
->where
);
2761 /* This is possibly a typo: x = f() instead of x => f(). */
2762 if (gfc_option
.warn_surprising
2763 && rvalue
->expr_type
== EXPR_FUNCTION
2764 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2765 gfc_warning ("POINTER valued function appears on right-hand side of "
2766 "assignment at %L", &rvalue
->where
);
2768 /* Check size of array assignments. */
2769 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2770 && gfc_check_conformance ("array assignment", lvalue
, rvalue
) != SUCCESS
)
2773 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
2774 && lvalue
->symtree
->n
.sym
->attr
.data
2775 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
2776 "initialize non-integer variable '%s'",
2777 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
2780 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
2781 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
2782 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2783 &rvalue
->where
) == FAILURE
)
2786 /* Handle the case of a BOZ literal on the RHS. */
2787 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
2790 if (gfc_option
.warn_surprising
)
2791 gfc_warning ("BOZ literal at %L is bitwise transferred "
2792 "non-integer symbol '%s'", &rvalue
->where
,
2793 lvalue
->symtree
->n
.sym
->name
);
2794 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
2796 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
2798 if (rc
== ARITH_UNDERFLOW
)
2799 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2800 ". This check can be disabled with the option "
2801 "-fno-range-check", &rvalue
->where
);
2802 else if (rc
== ARITH_OVERFLOW
)
2803 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2804 ". This check can be disabled with the option "
2805 "-fno-range-check", &rvalue
->where
);
2806 else if (rc
== ARITH_NAN
)
2807 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2808 ". This check can be disabled with the option "
2809 "-fno-range-check", &rvalue
->where
);
2814 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2819 /* Numeric can be converted to any other numeric. And Hollerith can be
2820 converted to any other type. */
2821 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2822 || rvalue
->ts
.type
== BT_HOLLERITH
)
2825 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2828 gfc_error ("Incompatible types in assignment at %L, %s to %s",
2829 &rvalue
->where
, gfc_typename (&rvalue
->ts
),
2830 gfc_typename (&lvalue
->ts
));
2835 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2839 /* Check that a pointer assignment is OK. We first check lvalue, and
2840 we only check rvalue if it's not an assignment to NULL() or a
2841 NULLIFY statement. */
2844 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2846 symbol_attribute attr
;
2849 int pointer
, check_intent_in
;
2851 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2853 gfc_error ("Pointer assignment target is not a POINTER at %L",
2858 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2859 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2861 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2862 "l-value since it is a procedure",
2863 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2868 /* Check INTENT(IN), unless the object itself is the component or
2869 sub-component of a pointer. */
2870 check_intent_in
= 1;
2871 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
;
2873 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2876 check_intent_in
= 0;
2878 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
2882 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2884 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2885 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2891 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2895 is_pure
= gfc_pure (NULL
);
2897 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
2898 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
2900 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
2904 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2905 kind, etc for lvalue and rvalue must match, and rvalue must be a
2906 pure variable if we're in a pure function. */
2907 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
2910 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2912 gfc_error ("Different types in pointer assignment at %L",
2917 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2919 gfc_error ("Different kind type parameters in pointer "
2920 "assignment at %L", &lvalue
->where
);
2924 if (lvalue
->rank
!= rvalue
->rank
)
2926 gfc_error ("Different ranks in pointer assignment at %L",
2931 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2932 if (rvalue
->expr_type
== EXPR_NULL
)
2935 if (lvalue
->ts
.type
== BT_CHARACTER
2936 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
2937 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
2938 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
2939 rvalue
->ts
.cl
->length
)) == 1)
2941 gfc_error ("Different character lengths in pointer "
2942 "assignment at %L", &lvalue
->where
);
2946 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
2947 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
2949 attr
= gfc_expr_attr (rvalue
);
2950 if (!attr
.target
&& !attr
.pointer
)
2952 gfc_error ("Pointer assignment target is neither TARGET "
2953 "nor POINTER at %L", &rvalue
->where
);
2957 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
2959 gfc_error ("Bad target in pointer assignment in PURE "
2960 "procedure at %L", &rvalue
->where
);
2963 if (gfc_has_vector_index (rvalue
))
2965 gfc_error ("Pointer assignment with vector subscript "
2966 "on rhs at %L", &rvalue
->where
);
2970 if (attr
.protected && attr
.use_assoc
)
2972 gfc_error ("Pointer assigment target has PROTECTED "
2973 "attribute at %L", &rvalue
->where
);
2981 /* Relative of gfc_check_assign() except that the lvalue is a single
2982 symbol. Used for initialization assignments. */
2985 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
2990 memset (&lvalue
, '\0', sizeof (gfc_expr
));
2992 lvalue
.expr_type
= EXPR_VARIABLE
;
2993 lvalue
.ts
= sym
->ts
;
2995 lvalue
.rank
= sym
->as
->rank
;
2996 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
2997 lvalue
.symtree
->n
.sym
= sym
;
2998 lvalue
.where
= sym
->declared_at
;
3000 if (sym
->attr
.pointer
)
3001 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3003 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3005 gfc_free (lvalue
.symtree
);
3011 /* Get an expression for a default initializer. */
3014 gfc_default_initializer (gfc_typespec
*ts
)
3016 gfc_constructor
*tail
;
3020 /* See if we have a default initializer. */
3021 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3022 if (c
->initializer
|| c
->allocatable
)
3028 /* Build the constructor. */
3029 init
= gfc_get_expr ();
3030 init
->expr_type
= EXPR_STRUCTURE
;
3032 init
->where
= ts
->derived
->declared_at
;
3035 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3038 init
->value
.constructor
= tail
= gfc_get_constructor ();
3041 tail
->next
= gfc_get_constructor ();
3046 tail
->expr
= gfc_copy_expr (c
->initializer
);
3050 tail
->expr
= gfc_get_expr ();
3051 tail
->expr
->expr_type
= EXPR_NULL
;
3052 tail
->expr
->ts
= c
->ts
;
3059 /* Given a symbol, create an expression node with that symbol as a
3060 variable. If the symbol is array valued, setup a reference of the
3064 gfc_get_variable_expr (gfc_symtree
*var
)
3068 e
= gfc_get_expr ();
3069 e
->expr_type
= EXPR_VARIABLE
;
3071 e
->ts
= var
->n
.sym
->ts
;
3073 if (var
->n
.sym
->as
!= NULL
)
3075 e
->rank
= var
->n
.sym
->as
->rank
;
3076 e
->ref
= gfc_get_ref ();
3077 e
->ref
->type
= REF_ARRAY
;
3078 e
->ref
->u
.ar
.type
= AR_FULL
;
3085 /* General expression traversal function. */
3088 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3089 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3094 gfc_actual_arglist
*args
;
3101 if ((*func
) (expr
, sym
, &f
))
3104 if (expr
->ts
.type
== BT_CHARACTER
3106 && expr
->ts
.cl
->length
3107 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3108 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3111 switch (expr
->expr_type
)
3114 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3116 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3124 case EXPR_SUBSTRING
:
3127 case EXPR_STRUCTURE
:
3129 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3131 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3135 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3137 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3139 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3141 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3148 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3150 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3166 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3168 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3170 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3172 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3178 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3180 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3185 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3186 && ref
->u
.c
.component
->ts
.cl
3187 && ref
->u
.c
.component
->ts
.cl
->length
3188 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3190 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3194 if (ref
->u
.c
.component
->as
)
3195 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3197 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3200 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3214 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3217 expr_set_symbols_referenced (gfc_expr
*expr
,
3218 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3219 int *f ATTRIBUTE_UNUSED
)
3221 if (expr
->expr_type
!= EXPR_VARIABLE
)
3223 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3228 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3230 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);