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. */
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_arg
;
72 for (; p
; p
= p
->next
)
74 new_arg
= gfc_get_actual_arglist ();
77 new_arg
->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. */
168 if (e
->representation
.string
)
169 gfc_free (e
->representation
.string
);
174 if (e
->value
.op
.op1
!= NULL
)
175 gfc_free_expr (e
->value
.op
.op1
);
176 if (e
->value
.op
.op2
!= NULL
)
177 gfc_free_expr (e
->value
.op
.op2
);
181 gfc_free_actual_arglist (e
->value
.function
.actual
);
185 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
193 gfc_free_constructor (e
->value
.constructor
);
197 gfc_free (e
->value
.character
.string
);
204 gfc_internal_error ("free_expr0(): Bad expr type");
207 /* Free a shape array. */
208 if (e
->shape
!= NULL
)
210 for (n
= 0; n
< e
->rank
; n
++)
211 mpz_clear (e
->shape
[n
]);
216 gfc_free_ref_list (e
->ref
);
218 memset (e
, '\0', sizeof (gfc_expr
));
222 /* Free an expression node and everything beneath it. */
225 gfc_free_expr (gfc_expr
*e
)
229 if (e
->con_by_offset
)
230 splay_tree_delete (e
->con_by_offset
);
236 /* Graft the *src expression onto the *dest subexpression. */
239 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
247 /* Try to extract an integer constant from the passed expression node.
248 Returns an error message or NULL if the result is set. It is
249 tempting to generate an error and return SUCCESS or FAILURE, but
250 failure is OK for some callers. */
253 gfc_extract_int (gfc_expr
*expr
, int *result
)
255 if (expr
->expr_type
!= EXPR_CONSTANT
)
256 return _("Constant expression required at %C");
258 if (expr
->ts
.type
!= BT_INTEGER
)
259 return _("Integer expression required at %C");
261 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
262 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
264 return _("Integer value too large in expression at %C");
267 *result
= (int) mpz_get_si (expr
->value
.integer
);
273 /* Recursively copy a list of reference structures. */
276 gfc_copy_ref (gfc_ref
*src
)
284 dest
= gfc_get_ref ();
285 dest
->type
= src
->type
;
290 ar
= gfc_copy_array_ref (&src
->u
.ar
);
296 dest
->u
.c
= src
->u
.c
;
300 dest
->u
.ss
= src
->u
.ss
;
301 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
302 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
306 dest
->next
= gfc_copy_ref (src
->next
);
312 /* Detect whether an expression has any vector index array references. */
315 gfc_has_vector_index (gfc_expr
*e
)
319 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
320 if (ref
->type
== REF_ARRAY
)
321 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
322 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
328 /* Copy a shape array. */
331 gfc_copy_shape (mpz_t
*shape
, int rank
)
339 new_shape
= gfc_get_shape (rank
);
341 for (n
= 0; n
< rank
; n
++)
342 mpz_init_set (new_shape
[n
], shape
[n
]);
348 /* Copy a shape array excluding dimension N, where N is an integer
349 constant expression. Dimensions are numbered in fortran style --
352 So, if the original shape array contains R elements
353 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
354 the result contains R-1 elements:
355 { s1 ... sN-1 sN+1 ... sR-1}
357 If anything goes wrong -- N is not a constant, its value is out
358 of range -- or anything else, just returns NULL. */
361 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
363 mpz_t
*new_shape
, *s
;
369 || dim
->expr_type
!= EXPR_CONSTANT
370 || dim
->ts
.type
!= BT_INTEGER
)
373 n
= mpz_get_si (dim
->value
.integer
);
374 n
--; /* Convert to zero based index. */
375 if (n
< 0 || n
>= rank
)
378 s
= new_shape
= gfc_get_shape (rank
- 1);
380 for (i
= 0; i
< rank
; i
++)
384 mpz_init_set (*s
, shape
[i
]);
392 /* Given an expression pointer, return a copy of the expression. This
393 subroutine is recursive. */
396 gfc_copy_expr (gfc_expr
*p
)
408 switch (q
->expr_type
)
411 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
412 q
->value
.character
.string
= s
;
413 memcpy (s
, p
->value
.character
.string
,
414 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
418 /* Copy target representation, if it exists. */
419 if (p
->representation
.string
)
421 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
422 q
->representation
.string
= c
;
423 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
426 /* Copy the values of any pointer components of p->value. */
430 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
434 gfc_set_model_kind (q
->ts
.kind
);
435 mpfr_init (q
->value
.real
);
436 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
440 gfc_set_model_kind (q
->ts
.kind
);
441 mpfr_init (q
->value
.complex.r
);
442 mpfr_init (q
->value
.complex.i
);
443 mpfr_set (q
->value
.complex.r
, p
->value
.complex.r
, GFC_RND_MODE
);
444 mpfr_set (q
->value
.complex.i
, p
->value
.complex.i
, GFC_RND_MODE
);
448 if (p
->representation
.string
)
449 q
->value
.character
.string
450 = gfc_char_to_widechar (q
->representation
.string
);
453 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
454 q
->value
.character
.string
= s
;
456 /* This is the case for the C_NULL_CHAR named constant. */
457 if (p
->value
.character
.length
== 0
458 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
461 /* Need to set the length to 1 to make sure the NUL
462 terminator is copied. */
463 q
->value
.character
.length
= 1;
466 memcpy (s
, p
->value
.character
.string
,
467 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
474 break; /* Already done. */
478 /* Should never be reached. */
480 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
487 switch (q
->value
.op
.op
)
490 case INTRINSIC_PARENTHESES
:
491 case INTRINSIC_UPLUS
:
492 case INTRINSIC_UMINUS
:
493 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
496 default: /* Binary operators. */
497 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
498 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
505 q
->value
.function
.actual
=
506 gfc_copy_actual_arglist (p
->value
.function
.actual
);
510 q
->value
.compcall
.actual
=
511 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
512 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
517 q
->value
.constructor
= gfc_copy_constructor (p
->value
.constructor
);
525 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
527 q
->ref
= gfc_copy_ref (p
->ref
);
533 /* Return the maximum kind of two expressions. In general, higher
534 kind numbers mean more precision for numeric types. */
537 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
539 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
543 /* Returns nonzero if the type is numeric, zero otherwise. */
546 numeric_type (bt type
)
548 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
552 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
555 gfc_numeric_ts (gfc_typespec
*ts
)
557 return numeric_type (ts
->type
);
561 /* Returns an expression node that is an integer constant. */
570 p
->expr_type
= EXPR_CONSTANT
;
571 p
->ts
.type
= BT_INTEGER
;
572 p
->ts
.kind
= gfc_default_integer_kind
;
574 p
->where
= gfc_current_locus
;
575 mpz_init_set_si (p
->value
.integer
, i
);
581 /* Returns an expression node that is a logical constant. */
584 gfc_logical_expr (int i
, locus
*where
)
590 p
->expr_type
= EXPR_CONSTANT
;
591 p
->ts
.type
= BT_LOGICAL
;
592 p
->ts
.kind
= gfc_default_logical_kind
;
595 where
= &gfc_current_locus
;
597 p
->value
.logical
= i
;
603 /* Return an expression node with an optional argument list attached.
604 A variable number of gfc_expr pointers are strung together in an
605 argument list with a NULL pointer terminating the list. */
608 gfc_build_conversion (gfc_expr
*e
)
613 p
->expr_type
= EXPR_FUNCTION
;
615 p
->value
.function
.actual
= NULL
;
617 p
->value
.function
.actual
= gfc_get_actual_arglist ();
618 p
->value
.function
.actual
->expr
= e
;
624 /* Given an expression node with some sort of numeric binary
625 expression, insert type conversions required to make the operands
628 The exception is that the operands of an exponential don't have to
629 have the same type. If possible, the base is promoted to the type
630 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
631 1.0**2 stays as it is. */
634 gfc_type_convert_binary (gfc_expr
*e
)
638 op1
= e
->value
.op
.op1
;
639 op2
= e
->value
.op
.op2
;
641 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
643 gfc_clear_ts (&e
->ts
);
647 /* Kind conversions of same type. */
648 if (op1
->ts
.type
== op2
->ts
.type
)
650 if (op1
->ts
.kind
== op2
->ts
.kind
)
652 /* No type conversions. */
657 if (op1
->ts
.kind
> op2
->ts
.kind
)
658 gfc_convert_type (op2
, &op1
->ts
, 2);
660 gfc_convert_type (op1
, &op2
->ts
, 2);
666 /* Integer combined with real or complex. */
667 if (op2
->ts
.type
== BT_INTEGER
)
671 /* Special case for ** operator. */
672 if (e
->value
.op
.op
== INTRINSIC_POWER
)
675 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
679 if (op1
->ts
.type
== BT_INTEGER
)
682 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
686 /* Real combined with complex. */
687 e
->ts
.type
= BT_COMPLEX
;
688 if (op1
->ts
.kind
> op2
->ts
.kind
)
689 e
->ts
.kind
= op1
->ts
.kind
;
691 e
->ts
.kind
= op2
->ts
.kind
;
692 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
693 gfc_convert_type (e
->value
.op
.op1
, &e
->ts
, 2);
694 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
695 gfc_convert_type (e
->value
.op
.op2
, &e
->ts
, 2);
703 check_specification_function (gfc_expr
*e
)
710 sym
= e
->symtree
->n
.sym
;
712 /* F95, 7.1.6.2; F2003, 7.1.7 */
714 && sym
->attr
.function
716 && !sym
->attr
.intrinsic
717 && !sym
->attr
.recursive
718 && sym
->attr
.proc
!= PROC_INTERNAL
719 && sym
->attr
.proc
!= PROC_ST_FUNCTION
720 && sym
->attr
.proc
!= PROC_UNKNOWN
721 && sym
->formal
== NULL
)
727 /* Function to determine if an expression is constant or not. This
728 function expects that the expression has already been simplified. */
731 gfc_is_constant_expr (gfc_expr
*e
)
734 gfc_actual_arglist
*arg
;
740 switch (e
->expr_type
)
743 rv
= (gfc_is_constant_expr (e
->value
.op
.op1
)
744 && (e
->value
.op
.op2
== NULL
745 || gfc_is_constant_expr (e
->value
.op
.op2
)));
753 /* Specification functions are constant. */
754 if (check_specification_function (e
) == MATCH_YES
)
760 /* Call to intrinsic with at least one argument. */
762 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
764 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
766 if (!gfc_is_constant_expr (arg
->expr
))
780 rv
= e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
781 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
786 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
787 if (!gfc_is_constant_expr (c
->expr
))
795 rv
= gfc_constant_ac (e
);
799 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
806 /* Is true if an array reference is followed by a component or substring
809 is_subref_array (gfc_expr
* e
)
814 if (e
->expr_type
!= EXPR_VARIABLE
)
817 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
821 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
823 if (ref
->type
== REF_ARRAY
824 && ref
->u
.ar
.type
!= AR_ELEMENT
)
828 && ref
->type
!= REF_ARRAY
)
835 /* Try to collapse intrinsic expressions. */
838 simplify_intrinsic_op (gfc_expr
*p
, int type
)
841 gfc_expr
*op1
, *op2
, *result
;
843 if (p
->value
.op
.op
== INTRINSIC_USER
)
846 op1
= p
->value
.op
.op1
;
847 op2
= p
->value
.op
.op2
;
850 if (gfc_simplify_expr (op1
, type
) == FAILURE
)
852 if (gfc_simplify_expr (op2
, type
) == FAILURE
)
855 if (!gfc_is_constant_expr (op1
)
856 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
860 p
->value
.op
.op1
= NULL
;
861 p
->value
.op
.op2
= NULL
;
865 case INTRINSIC_PARENTHESES
:
866 result
= gfc_parentheses (op1
);
869 case INTRINSIC_UPLUS
:
870 result
= gfc_uplus (op1
);
873 case INTRINSIC_UMINUS
:
874 result
= gfc_uminus (op1
);
878 result
= gfc_add (op1
, op2
);
881 case INTRINSIC_MINUS
:
882 result
= gfc_subtract (op1
, op2
);
885 case INTRINSIC_TIMES
:
886 result
= gfc_multiply (op1
, op2
);
889 case INTRINSIC_DIVIDE
:
890 result
= gfc_divide (op1
, op2
);
893 case INTRINSIC_POWER
:
894 result
= gfc_power (op1
, op2
);
897 case INTRINSIC_CONCAT
:
898 result
= gfc_concat (op1
, op2
);
902 case INTRINSIC_EQ_OS
:
903 result
= gfc_eq (op1
, op2
, op
);
907 case INTRINSIC_NE_OS
:
908 result
= gfc_ne (op1
, op2
, op
);
912 case INTRINSIC_GT_OS
:
913 result
= gfc_gt (op1
, op2
, op
);
917 case INTRINSIC_GE_OS
:
918 result
= gfc_ge (op1
, op2
, op
);
922 case INTRINSIC_LT_OS
:
923 result
= gfc_lt (op1
, op2
, op
);
927 case INTRINSIC_LE_OS
:
928 result
= gfc_le (op1
, op2
, op
);
932 result
= gfc_not (op1
);
936 result
= gfc_and (op1
, op2
);
940 result
= gfc_or (op1
, op2
);
944 result
= gfc_eqv (op1
, op2
);
948 result
= gfc_neqv (op1
, op2
);
952 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
962 result
->rank
= p
->rank
;
963 result
->where
= p
->where
;
964 gfc_replace_expr (p
, result
);
970 /* Subroutine to simplify constructor expressions. Mutually recursive
971 with gfc_simplify_expr(). */
974 simplify_constructor (gfc_constructor
*c
, int type
)
978 for (; c
; c
= c
->next
)
981 && (gfc_simplify_expr (c
->iterator
->start
, type
) == FAILURE
982 || gfc_simplify_expr (c
->iterator
->end
, type
) == FAILURE
983 || gfc_simplify_expr (c
->iterator
->step
, type
) == FAILURE
))
988 /* Try and simplify a copy. Replace the original if successful
989 but keep going through the constructor at all costs. Not
990 doing so can make a dog's dinner of complicated things. */
991 p
= gfc_copy_expr (c
->expr
);
993 if (gfc_simplify_expr (p
, type
) == FAILURE
)
999 gfc_replace_expr (c
->expr
, p
);
1007 /* Pull a single array element out of an array constructor. */
1010 find_array_element (gfc_constructor
*cons
, gfc_array_ref
*ar
,
1011 gfc_constructor
**rval
)
1013 unsigned long nelemen
;
1025 mpz_init_set_ui (offset
, 0);
1028 mpz_init_set_ui (span
, 1);
1029 for (i
= 0; i
< ar
->dimen
; i
++)
1031 e
= gfc_copy_expr (ar
->start
[i
]);
1032 if (e
->expr_type
!= EXPR_CONSTANT
)
1038 /* Check the bounds. */
1039 if ((ar
->as
->upper
[i
]
1040 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1041 && mpz_cmp (e
->value
.integer
,
1042 ar
->as
->upper
[i
]->value
.integer
) > 0)
1043 || (ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
1044 && mpz_cmp (e
->value
.integer
,
1045 ar
->as
->lower
[i
]->value
.integer
) < 0))
1047 gfc_error ("Index in dimension %d is out of bounds "
1048 "at %L", i
+ 1, &ar
->c_where
[i
]);
1054 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1055 mpz_mul (delta
, delta
, span
);
1056 mpz_add (offset
, offset
, delta
);
1058 mpz_set_ui (tmp
, 1);
1059 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1060 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1061 mpz_mul (span
, span
, tmp
);
1064 for (nelemen
= mpz_get_ui (offset
); nelemen
> 0; nelemen
--)
1089 /* Find a component of a structure constructor. */
1091 static gfc_constructor
*
1092 find_component_ref (gfc_constructor
*cons
, gfc_ref
*ref
)
1094 gfc_component
*comp
;
1095 gfc_component
*pick
;
1097 comp
= ref
->u
.c
.sym
->components
;
1098 pick
= ref
->u
.c
.component
;
1099 while (comp
!= pick
)
1109 /* Replace an expression with the contents of a constructor, removing
1110 the subobject reference in the process. */
1113 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1119 e
->ref
= p
->ref
->next
;
1120 p
->ref
->next
= NULL
;
1121 gfc_replace_expr (p
, e
);
1125 /* Pull an array section out of an array constructor. */
1128 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1134 long unsigned one
= 1;
1136 mpz_t start
[GFC_MAX_DIMENSIONS
];
1137 mpz_t end
[GFC_MAX_DIMENSIONS
];
1138 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1139 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1140 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1146 gfc_constructor
*cons
;
1147 gfc_constructor
*base
;
1153 gfc_constructor
*vecsub
[GFC_MAX_DIMENSIONS
], *c
;
1158 base
= expr
->value
.constructor
;
1159 expr
->value
.constructor
= NULL
;
1161 rank
= ref
->u
.ar
.as
->rank
;
1163 if (expr
->shape
== NULL
)
1164 expr
->shape
= gfc_get_shape (rank
);
1166 mpz_init_set_ui (delta_mpz
, one
);
1167 mpz_init_set_ui (nelts
, one
);
1170 /* Do the initialization now, so that we can cleanup without
1171 keeping track of where we were. */
1172 for (d
= 0; d
< rank
; d
++)
1174 mpz_init (delta
[d
]);
1175 mpz_init (start
[d
]);
1178 mpz_init (stride
[d
]);
1182 /* Build the counters to clock through the array reference. */
1184 for (d
= 0; d
< rank
; d
++)
1186 /* Make this stretch of code easier on the eye! */
1187 begin
= ref
->u
.ar
.start
[d
];
1188 finish
= ref
->u
.ar
.end
[d
];
1189 step
= ref
->u
.ar
.stride
[d
];
1190 lower
= ref
->u
.ar
.as
->lower
[d
];
1191 upper
= ref
->u
.ar
.as
->upper
[d
];
1193 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1197 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1203 gcc_assert (begin
->rank
== 1);
1204 gcc_assert (begin
->shape
);
1206 vecsub
[d
] = begin
->value
.constructor
;
1207 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1208 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1209 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1212 for (c
= vecsub
[d
]; c
; c
= c
->next
)
1214 if (mpz_cmp (c
->expr
->value
.integer
, upper
->value
.integer
) > 0
1215 || mpz_cmp (c
->expr
->value
.integer
,
1216 lower
->value
.integer
) < 0)
1218 gfc_error ("index in dimension %d is out of bounds "
1219 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1227 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1228 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1229 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1235 /* Obtain the stride. */
1237 mpz_set (stride
[d
], step
->value
.integer
);
1239 mpz_set_ui (stride
[d
], one
);
1241 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1242 mpz_set_ui (stride
[d
], one
);
1244 /* Obtain the start value for the index. */
1246 mpz_set (start
[d
], begin
->value
.integer
);
1248 mpz_set (start
[d
], lower
->value
.integer
);
1250 mpz_set (ctr
[d
], start
[d
]);
1252 /* Obtain the end value for the index. */
1254 mpz_set (end
[d
], finish
->value
.integer
);
1256 mpz_set (end
[d
], upper
->value
.integer
);
1258 /* Separate 'if' because elements sometimes arrive with
1260 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1261 mpz_set (end
[d
], begin
->value
.integer
);
1263 /* Check the bounds. */
1264 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1265 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1266 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1267 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1269 gfc_error ("index in dimension %d is out of bounds "
1270 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1275 /* Calculate the number of elements and the shape. */
1276 mpz_set (tmp_mpz
, stride
[d
]);
1277 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1278 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1279 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1280 mpz_mul (nelts
, nelts
, tmp_mpz
);
1282 /* An element reference reduces the rank of the expression; don't
1283 add anything to the shape array. */
1284 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1285 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1288 /* Calculate the 'stride' (=delta) for conversion of the
1289 counter values into the index along the constructor. */
1290 mpz_set (delta
[d
], delta_mpz
);
1291 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1292 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1293 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1300 /* Now clock through the array reference, calculating the index in
1301 the source constructor and transferring the elements to the new
1303 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1305 if (ref
->u
.ar
.offset
)
1306 mpz_set (ptr
, ref
->u
.ar
.offset
->value
.integer
);
1308 mpz_init_set_ui (ptr
, 0);
1311 for (d
= 0; d
< rank
; d
++)
1313 mpz_set (tmp_mpz
, ctr
[d
]);
1314 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1315 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1316 mpz_add (ptr
, ptr
, tmp_mpz
);
1318 if (!incr_ctr
) continue;
1320 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1322 gcc_assert(vecsub
[d
]);
1324 if (!vecsub
[d
]->next
)
1325 vecsub
[d
] = ref
->u
.ar
.start
[d
]->value
.constructor
;
1328 vecsub
[d
] = vecsub
[d
]->next
;
1331 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1335 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1337 if (mpz_cmp_ui (stride
[d
], 0) > 0
1338 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1339 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1340 mpz_set (ctr
[d
], start
[d
]);
1346 /* There must be a better way of dealing with negative strides
1347 than resetting the index and the constructor pointer! */
1348 if (mpz_cmp (ptr
, index
) < 0)
1350 mpz_set_ui (index
, 0);
1354 while (cons
&& cons
->next
&& mpz_cmp (ptr
, index
) > 0)
1356 mpz_add_ui (index
, index
, one
);
1360 gfc_append_constructor (expr
, gfc_copy_expr (cons
->expr
));
1368 mpz_clear (delta_mpz
);
1369 mpz_clear (tmp_mpz
);
1371 for (d
= 0; d
< rank
; d
++)
1373 mpz_clear (delta
[d
]);
1374 mpz_clear (start
[d
]);
1377 mpz_clear (stride
[d
]);
1379 gfc_free_constructor (base
);
1383 /* Pull a substring out of an expression. */
1386 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1393 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1394 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1397 *newp
= gfc_copy_expr (p
);
1398 gfc_free ((*newp
)->value
.character
.string
);
1400 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1401 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1402 length
= end
- start
+ 1;
1404 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1405 (*newp
)->value
.character
.length
= length
;
1406 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1407 length
* sizeof (gfc_char_t
));
1414 /* Simplify a subobject reference of a constructor. This occurs when
1415 parameter variable values are substituted. */
1418 simplify_const_ref (gfc_expr
*p
)
1420 gfc_constructor
*cons
;
1425 switch (p
->ref
->type
)
1428 switch (p
->ref
->u
.ar
.type
)
1431 if (find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
,
1438 remove_subobject_ref (p
, cons
);
1442 if (find_array_section (p
, p
->ref
) == FAILURE
)
1444 p
->ref
->u
.ar
.type
= AR_FULL
;
1449 if (p
->ref
->next
!= NULL
1450 && (p
->ts
.type
== BT_CHARACTER
|| p
->ts
.type
== BT_DERIVED
))
1452 cons
= p
->value
.constructor
;
1453 for (; cons
; cons
= cons
->next
)
1455 cons
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1456 if (simplify_const_ref (cons
->expr
) == FAILURE
)
1460 /* If this is a CHARACTER array and we possibly took a
1461 substring out of it, update the type-spec's character
1462 length according to the first element (as all should have
1463 the same length). */
1464 if (p
->ts
.type
== BT_CHARACTER
)
1468 gcc_assert (p
->ref
->next
);
1469 gcc_assert (!p
->ref
->next
->next
);
1470 gcc_assert (p
->ref
->next
->type
== REF_SUBSTRING
);
1472 if (p
->value
.constructor
)
1474 const gfc_expr
* first
= p
->value
.constructor
->expr
;
1475 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1476 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1477 string_len
= first
->value
.character
.length
;
1484 p
->ts
.cl
= gfc_get_charlen ();
1485 p
->ts
.cl
->next
= NULL
;
1486 p
->ts
.cl
->length
= NULL
;
1488 gfc_free_expr (p
->ts
.cl
->length
);
1489 p
->ts
.cl
->length
= gfc_int_expr (string_len
);
1492 gfc_free_ref_list (p
->ref
);
1503 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1504 remove_subobject_ref (p
, cons
);
1508 if (find_substring_ref (p
, &newp
) == FAILURE
)
1511 gfc_replace_expr (p
, newp
);
1512 gfc_free_ref_list (p
->ref
);
1522 /* Simplify a chain of references. */
1525 simplify_ref_chain (gfc_ref
*ref
, int type
)
1529 for (; ref
; ref
= ref
->next
)
1534 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1536 if (gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
) == FAILURE
)
1538 if (gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
) == FAILURE
)
1540 if (gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
) == FAILURE
)
1546 if (gfc_simplify_expr (ref
->u
.ss
.start
, type
) == FAILURE
)
1548 if (gfc_simplify_expr (ref
->u
.ss
.end
, type
) == FAILURE
)
1560 /* Try to substitute the value of a parameter variable. */
1563 simplify_parameter_variable (gfc_expr
*p
, int type
)
1568 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1574 /* Do not copy subobject refs for constant. */
1575 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1576 e
->ref
= gfc_copy_ref (p
->ref
);
1577 t
= gfc_simplify_expr (e
, type
);
1579 /* Only use the simplification if it eliminated all subobject references. */
1580 if (t
== SUCCESS
&& !e
->ref
)
1581 gfc_replace_expr (p
, e
);
1588 /* Given an expression, simplify it by collapsing constant
1589 expressions. Most simplification takes place when the expression
1590 tree is being constructed. If an intrinsic function is simplified
1591 at some point, we get called again to collapse the result against
1594 We work by recursively simplifying expression nodes, simplifying
1595 intrinsic functions where possible, which can lead to further
1596 constant collapsing. If an operator has constant operand(s), we
1597 rip the expression apart, and rebuild it, hoping that it becomes
1600 The expression type is defined for:
1601 0 Basic expression parsing
1602 1 Simplifying array constructors -- will substitute
1604 Returns FAILURE on error, SUCCESS otherwise.
1605 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1608 gfc_simplify_expr (gfc_expr
*p
, int type
)
1610 gfc_actual_arglist
*ap
;
1615 switch (p
->expr_type
)
1622 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1623 if (gfc_simplify_expr (ap
->expr
, type
) == FAILURE
)
1626 if (p
->value
.function
.isym
!= NULL
1627 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1632 case EXPR_SUBSTRING
:
1633 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1636 if (gfc_is_constant_expr (p
))
1641 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1643 gfc_extract_int (p
->ref
->u
.ss
.start
, &start
);
1644 start
--; /* Convert from one-based to zero-based. */
1649 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1650 gfc_extract_int (p
->ref
->u
.ss
.end
, &end
);
1652 end
= p
->value
.character
.length
;
1654 s
= gfc_get_wide_string (end
- start
+ 2);
1655 memcpy (s
, p
->value
.character
.string
+ start
,
1656 (end
- start
) * sizeof (gfc_char_t
));
1657 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1658 gfc_free (p
->value
.character
.string
);
1659 p
->value
.character
.string
= s
;
1660 p
->value
.character
.length
= end
- start
;
1661 p
->ts
.cl
= gfc_get_charlen ();
1662 p
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
1663 gfc_current_ns
->cl_list
= p
->ts
.cl
;
1664 p
->ts
.cl
->length
= gfc_int_expr (p
->value
.character
.length
);
1665 gfc_free_ref_list (p
->ref
);
1667 p
->expr_type
= EXPR_CONSTANT
;
1672 if (simplify_intrinsic_op (p
, type
) == FAILURE
)
1677 /* Only substitute array parameter variables if we are in an
1678 initialization expression, or we want a subsection. */
1679 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1680 && (gfc_init_expr
|| p
->ref
1681 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1683 if (simplify_parameter_variable (p
, type
) == FAILURE
)
1690 gfc_simplify_iterator_var (p
);
1693 /* Simplify subcomponent references. */
1694 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1699 case EXPR_STRUCTURE
:
1701 if (simplify_ref_chain (p
->ref
, type
) == FAILURE
)
1704 if (simplify_constructor (p
->value
.constructor
, type
) == FAILURE
)
1707 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
1708 && p
->ref
->u
.ar
.type
== AR_FULL
)
1709 gfc_expand_constructor (p
);
1711 if (simplify_const_ref (p
) == FAILURE
)
1725 /* Returns the type of an expression with the exception that iterator
1726 variables are automatically integers no matter what else they may
1732 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
) == SUCCESS
)
1739 /* Check an intrinsic arithmetic operation to see if it is consistent
1740 with some type of expression. */
1742 static gfc_try
check_init_expr (gfc_expr
*);
1745 /* Scalarize an expression for an elemental intrinsic call. */
1748 scalarize_intrinsic_call (gfc_expr
*e
)
1750 gfc_actual_arglist
*a
, *b
;
1751 gfc_constructor
*args
[5], *ctor
, *new_ctor
;
1752 gfc_expr
*expr
, *old
;
1753 int n
, i
, rank
[5], array_arg
;
1755 /* Find which, if any, arguments are arrays. Assume that the old
1756 expression carries the type information and that the first arg
1757 that is an array expression carries all the shape information.*/
1759 a
= e
->value
.function
.actual
;
1760 for (; a
; a
= a
->next
)
1763 if (a
->expr
->expr_type
!= EXPR_ARRAY
)
1766 expr
= gfc_copy_expr (a
->expr
);
1773 old
= gfc_copy_expr (e
);
1775 gfc_free_constructor (expr
->value
.constructor
);
1776 expr
->value
.constructor
= NULL
;
1779 expr
->where
= old
->where
;
1780 expr
->expr_type
= EXPR_ARRAY
;
1782 /* Copy the array argument constructors into an array, with nulls
1785 a
= old
->value
.function
.actual
;
1786 for (; a
; a
= a
->next
)
1788 /* Check that this is OK for an initialization expression. */
1789 if (a
->expr
&& check_init_expr (a
->expr
) == FAILURE
)
1793 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
1795 rank
[n
] = a
->expr
->rank
;
1796 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
1797 args
[n
] = gfc_copy_constructor (ctor
);
1799 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
1802 rank
[n
] = a
->expr
->rank
;
1805 args
[n
] = gfc_copy_constructor (a
->expr
->value
.constructor
);
1813 /* Using the array argument as the master, step through the array
1814 calling the function for each element and advancing the array
1815 constructors together. */
1816 ctor
= args
[array_arg
- 1];
1818 for (; ctor
; ctor
= ctor
->next
)
1820 if (expr
->value
.constructor
== NULL
)
1821 expr
->value
.constructor
1822 = new_ctor
= gfc_get_constructor ();
1825 new_ctor
->next
= gfc_get_constructor ();
1826 new_ctor
= new_ctor
->next
;
1828 new_ctor
->expr
= gfc_copy_expr (old
);
1829 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
1831 b
= old
->value
.function
.actual
;
1832 for (i
= 0; i
< n
; i
++)
1835 new_ctor
->expr
->value
.function
.actual
1836 = a
= gfc_get_actual_arglist ();
1839 a
->next
= gfc_get_actual_arglist ();
1843 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
1845 a
->expr
= gfc_copy_expr (b
->expr
);
1850 /* Simplify the function calls. If the simplification fails, the
1851 error will be flagged up down-stream or the library will deal
1853 gfc_simplify_expr (new_ctor
->expr
, 0);
1855 for (i
= 0; i
< n
; i
++)
1857 args
[i
] = args
[i
]->next
;
1859 for (i
= 1; i
< n
; i
++)
1860 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
1861 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
1867 gfc_free_expr (old
);
1871 gfc_error_now ("elemental function arguments at %C are not compliant");
1874 gfc_free_expr (expr
);
1875 gfc_free_expr (old
);
1881 check_intrinsic_op (gfc_expr
*e
, gfc_try (*check_function
) (gfc_expr
*))
1883 gfc_expr
*op1
= e
->value
.op
.op1
;
1884 gfc_expr
*op2
= e
->value
.op
.op2
;
1886 if ((*check_function
) (op1
) == FAILURE
)
1889 switch (e
->value
.op
.op
)
1891 case INTRINSIC_UPLUS
:
1892 case INTRINSIC_UMINUS
:
1893 if (!numeric_type (et0 (op1
)))
1898 case INTRINSIC_EQ_OS
:
1900 case INTRINSIC_NE_OS
:
1902 case INTRINSIC_GT_OS
:
1904 case INTRINSIC_GE_OS
:
1906 case INTRINSIC_LT_OS
:
1908 case INTRINSIC_LE_OS
:
1909 if ((*check_function
) (op2
) == FAILURE
)
1912 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
1913 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
1915 gfc_error ("Numeric or CHARACTER operands are required in "
1916 "expression at %L", &e
->where
);
1921 case INTRINSIC_PLUS
:
1922 case INTRINSIC_MINUS
:
1923 case INTRINSIC_TIMES
:
1924 case INTRINSIC_DIVIDE
:
1925 case INTRINSIC_POWER
:
1926 if ((*check_function
) (op2
) == FAILURE
)
1929 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
1932 if (e
->value
.op
.op
== INTRINSIC_POWER
1933 && check_function
== check_init_expr
&& et0 (op2
) != BT_INTEGER
)
1935 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Noninteger "
1936 "exponent in an initialization "
1937 "expression at %L", &op2
->where
)
1944 case INTRINSIC_CONCAT
:
1945 if ((*check_function
) (op2
) == FAILURE
)
1948 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
1950 gfc_error ("Concatenation operator in expression at %L "
1951 "must have two CHARACTER operands", &op1
->where
);
1955 if (op1
->ts
.kind
!= op2
->ts
.kind
)
1957 gfc_error ("Concat operator at %L must concatenate strings of the "
1958 "same kind", &e
->where
);
1965 if (et0 (op1
) != BT_LOGICAL
)
1967 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1968 "operand", &op1
->where
);
1977 case INTRINSIC_NEQV
:
1978 if ((*check_function
) (op2
) == FAILURE
)
1981 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
1983 gfc_error ("LOGICAL operands are required in expression at %L",
1990 case INTRINSIC_PARENTHESES
:
1994 gfc_error ("Only intrinsic operators can be used in expression at %L",
2002 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2009 check_init_expr_arguments (gfc_expr
*e
)
2011 gfc_actual_arglist
*ap
;
2013 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2014 if (check_init_expr (ap
->expr
) == FAILURE
)
2020 /* F95, 7.1.6.1, Initialization expressions, (7)
2021 F2003, 7.1.7 Initialization expression, (8) */
2024 check_inquiry (gfc_expr
*e
, int not_restricted
)
2027 const char *const *functions
;
2029 static const char *const inquiry_func_f95
[] = {
2030 "lbound", "shape", "size", "ubound",
2031 "bit_size", "len", "kind",
2032 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2033 "precision", "radix", "range", "tiny",
2037 static const char *const inquiry_func_f2003
[] = {
2038 "lbound", "shape", "size", "ubound",
2039 "bit_size", "len", "kind",
2040 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2041 "precision", "radix", "range", "tiny",
2046 gfc_actual_arglist
*ap
;
2048 if (!e
->value
.function
.isym
2049 || !e
->value
.function
.isym
->inquiry
)
2052 /* An undeclared parameter will get us here (PR25018). */
2053 if (e
->symtree
== NULL
)
2056 name
= e
->symtree
->n
.sym
->name
;
2058 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2059 ? inquiry_func_f2003
: inquiry_func_f95
;
2061 for (i
= 0; functions
[i
]; i
++)
2062 if (strcmp (functions
[i
], name
) == 0)
2065 if (functions
[i
] == NULL
)
2068 /* At this point we have an inquiry function with a variable argument. The
2069 type of the variable might be undefined, but we need it now, because the
2070 arguments of these functions are not allowed to be undefined. */
2072 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2077 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2079 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2080 && gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
)
2084 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2087 /* Assumed character length will not reduce to a constant expression
2088 with LEN, as required by the standard. */
2089 if (i
== 5 && not_restricted
2090 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2091 && ap
->expr
->symtree
->n
.sym
->ts
.cl
->length
== NULL
)
2093 gfc_error ("Assumed character length variable '%s' in constant "
2094 "expression at %L", e
->symtree
->n
.sym
->name
, &e
->where
);
2097 else if (not_restricted
&& check_init_expr (ap
->expr
) == FAILURE
)
2105 /* F95, 7.1.6.1, Initialization expressions, (5)
2106 F2003, 7.1.7 Initialization expression, (5) */
2109 check_transformational (gfc_expr
*e
)
2111 static const char * const trans_func_f95
[] = {
2112 "repeat", "reshape", "selected_int_kind",
2113 "selected_real_kind", "transfer", "trim", NULL
2119 if (!e
->value
.function
.isym
2120 || !e
->value
.function
.isym
->transformational
)
2123 name
= e
->symtree
->n
.sym
->name
;
2125 /* NULL() is dealt with below. */
2126 if (strcmp ("null", name
) == 0)
2129 for (i
= 0; trans_func_f95
[i
]; i
++)
2130 if (strcmp (trans_func_f95
[i
], name
) == 0)
2133 /* FIXME, F2003: implement translation of initialization
2134 expressions before enabling this check. For F95, error
2135 out if the transformational function is not in the list. */
2137 if (trans_func_f95
[i
] == NULL
2138 && gfc_notify_std (GFC_STD_F2003
,
2139 "transformational intrinsic '%s' at %L is not permitted "
2140 "in an initialization expression", name
, &e
->where
) == FAILURE
)
2143 if (trans_func_f95
[i
] == NULL
)
2145 gfc_error("transformational intrinsic '%s' at %L is not permitted "
2146 "in an initialization expression", name
, &e
->where
);
2151 return check_init_expr_arguments (e
);
2155 /* F95, 7.1.6.1, Initialization expressions, (6)
2156 F2003, 7.1.7 Initialization expression, (6) */
2159 check_null (gfc_expr
*e
)
2161 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2164 return check_init_expr_arguments (e
);
2169 check_elemental (gfc_expr
*e
)
2171 if (!e
->value
.function
.isym
2172 || !e
->value
.function
.isym
->elemental
)
2175 if (e
->ts
.type
!= BT_INTEGER
2176 && e
->ts
.type
!= BT_CHARACTER
2177 && gfc_notify_std (GFC_STD_F2003
, "Extension: Evaluation of "
2178 "nonstandard initialization expression at %L",
2179 &e
->where
) == FAILURE
)
2182 return check_init_expr_arguments (e
);
2187 check_conversion (gfc_expr
*e
)
2189 if (!e
->value
.function
.isym
2190 || !e
->value
.function
.isym
->conversion
)
2193 return check_init_expr_arguments (e
);
2197 /* Verify that an expression is an initialization expression. A side
2198 effect is that the expression tree is reduced to a single constant
2199 node if all goes well. This would normally happen when the
2200 expression is constructed but function references are assumed to be
2201 intrinsics in the context of initialization expressions. If
2202 FAILURE is returned an error message has been generated. */
2205 check_init_expr (gfc_expr
*e
)
2213 switch (e
->expr_type
)
2216 t
= check_intrinsic_op (e
, check_init_expr
);
2218 t
= gfc_simplify_expr (e
, 0);
2225 if ((m
= check_specification_function (e
)) != MATCH_YES
)
2227 gfc_intrinsic_sym
* isym
;
2230 sym
= e
->symtree
->n
.sym
;
2231 if (!gfc_is_intrinsic (sym
, 0, e
->where
)
2232 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
)
2234 gfc_error ("Function '%s' in initialization expression at %L "
2235 "must be an intrinsic or a specification function",
2236 e
->symtree
->n
.sym
->name
, &e
->where
);
2240 if ((m
= check_conversion (e
)) == MATCH_NO
2241 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2242 && (m
= check_null (e
)) == MATCH_NO
2243 && (m
= check_transformational (e
)) == MATCH_NO
2244 && (m
= check_elemental (e
)) == MATCH_NO
)
2246 gfc_error ("Intrinsic function '%s' at %L is not permitted "
2247 "in an initialization expression",
2248 e
->symtree
->n
.sym
->name
, &e
->where
);
2252 /* Try to scalarize an elemental intrinsic function that has an
2254 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2255 if (isym
&& isym
->elemental
2256 && (t
= scalarize_intrinsic_call (e
)) == SUCCESS
)
2261 t
= gfc_simplify_expr (e
, 0);
2268 if (gfc_check_iter_variable (e
) == SUCCESS
)
2271 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2273 /* A PARAMETER shall not be used to define itself, i.e.
2274 REAL, PARAMETER :: x = transfer(0, x)
2276 if (!e
->symtree
->n
.sym
->value
)
2278 gfc_error("PARAMETER '%s' is used at %L before its definition "
2279 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2283 t
= simplify_parameter_variable (e
, 0);
2288 if (gfc_in_match_data ())
2293 if (e
->symtree
->n
.sym
->as
)
2295 switch (e
->symtree
->n
.sym
->as
->type
)
2297 case AS_ASSUMED_SIZE
:
2298 gfc_error ("Assumed size array '%s' at %L is not permitted "
2299 "in an initialization expression",
2300 e
->symtree
->n
.sym
->name
, &e
->where
);
2303 case AS_ASSUMED_SHAPE
:
2304 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2305 "in an initialization expression",
2306 e
->symtree
->n
.sym
->name
, &e
->where
);
2310 gfc_error ("Deferred array '%s' at %L is not permitted "
2311 "in an initialization expression",
2312 e
->symtree
->n
.sym
->name
, &e
->where
);
2316 gfc_error ("Array '%s' at %L is a variable, which does "
2317 "not reduce to a constant expression",
2318 e
->symtree
->n
.sym
->name
, &e
->where
);
2326 gfc_error ("Parameter '%s' at %L has not been declared or is "
2327 "a variable, which does not reduce to a constant "
2328 "expression", e
->symtree
->n
.sym
->name
, &e
->where
);
2337 case EXPR_SUBSTRING
:
2338 t
= check_init_expr (e
->ref
->u
.ss
.start
);
2342 t
= check_init_expr (e
->ref
->u
.ss
.end
);
2344 t
= gfc_simplify_expr (e
, 0);
2348 case EXPR_STRUCTURE
:
2352 t
= gfc_check_constructor (e
, check_init_expr
);
2356 t
= gfc_check_constructor (e
, check_init_expr
);
2360 t
= gfc_expand_constructor (e
);
2364 t
= gfc_check_constructor_type (e
);
2368 gfc_internal_error ("check_init_expr(): Unknown expression type");
2375 /* Match an initialization expression. We work by first matching an
2376 expression, then reducing it to a constant. */
2379 gfc_match_init_expr (gfc_expr
**result
)
2385 m
= gfc_match_expr (&expr
);
2390 t
= gfc_resolve_expr (expr
);
2392 t
= check_init_expr (expr
);
2397 gfc_free_expr (expr
);
2401 if (expr
->expr_type
== EXPR_ARRAY
2402 && (gfc_check_constructor_type (expr
) == FAILURE
2403 || gfc_expand_constructor (expr
) == FAILURE
))
2405 gfc_free_expr (expr
);
2409 /* Not all inquiry functions are simplified to constant expressions
2410 so it is necessary to call check_inquiry again. */
2411 if (!gfc_is_constant_expr (expr
) && check_inquiry (expr
, 1) != MATCH_YES
2412 && !gfc_in_match_data ())
2414 gfc_error ("Initialization expression didn't reduce %C");
2424 static gfc_try
check_restricted (gfc_expr
*);
2426 /* Given an actual argument list, test to see that each argument is a
2427 restricted expression and optionally if the expression type is
2428 integer or character. */
2431 restricted_args (gfc_actual_arglist
*a
)
2433 for (; a
; a
= a
->next
)
2435 if (check_restricted (a
->expr
) == FAILURE
)
2443 /************* Restricted/specification expressions *************/
2446 /* Make sure a non-intrinsic function is a specification function. */
2449 external_spec_function (gfc_expr
*e
)
2453 f
= e
->value
.function
.esym
;
2455 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2457 gfc_error ("Specification function '%s' at %L cannot be a statement "
2458 "function", f
->name
, &e
->where
);
2462 if (f
->attr
.proc
== PROC_INTERNAL
)
2464 gfc_error ("Specification function '%s' at %L cannot be an internal "
2465 "function", f
->name
, &e
->where
);
2469 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2471 gfc_error ("Specification function '%s' at %L must be PURE", f
->name
,
2476 if (f
->attr
.recursive
)
2478 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2479 f
->name
, &e
->where
);
2483 return restricted_args (e
->value
.function
.actual
);
2487 /* Check to see that a function reference to an intrinsic is a
2488 restricted expression. */
2491 restricted_intrinsic (gfc_expr
*e
)
2493 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2494 if (check_inquiry (e
, 0) == MATCH_YES
)
2497 return restricted_args (e
->value
.function
.actual
);
2501 /* Verify that an expression is a restricted expression. Like its
2502 cousin check_init_expr(), an error message is generated if we
2506 check_restricted (gfc_expr
*e
)
2514 switch (e
->expr_type
)
2517 t
= check_intrinsic_op (e
, check_restricted
);
2519 t
= gfc_simplify_expr (e
, 0);
2524 t
= e
->value
.function
.esym
? external_spec_function (e
)
2525 : restricted_intrinsic (e
);
2529 sym
= e
->symtree
->n
.sym
;
2532 /* If a dummy argument appears in a context that is valid for a
2533 restricted expression in an elemental procedure, it will have
2534 already been simplified away once we get here. Therefore we
2535 don't need to jump through hoops to distinguish valid from
2537 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
2538 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
2540 gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2541 sym
->name
, &e
->where
);
2545 if (sym
->attr
.optional
)
2547 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2548 sym
->name
, &e
->where
);
2552 if (sym
->attr
.intent
== INTENT_OUT
)
2554 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2555 sym
->name
, &e
->where
);
2559 /* gfc_is_formal_arg broadcasts that a formal argument list is being
2560 processed in resolve.c(resolve_formal_arglist). This is done so
2561 that host associated dummy array indices are accepted (PR23446).
2562 This mechanism also does the same for the specification expressions
2563 of array-valued functions. */
2564 if (sym
->attr
.in_common
2565 || sym
->attr
.use_assoc
2567 || sym
->attr
.implied_index
2568 || sym
->ns
!= gfc_current_ns
2569 || (sym
->ns
->proc_name
!= NULL
2570 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
2571 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
2577 gfc_error ("Variable '%s' cannot appear in the expression at %L",
2578 sym
->name
, &e
->where
);
2587 case EXPR_SUBSTRING
:
2588 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
2592 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
2594 t
= gfc_simplify_expr (e
, 0);
2598 case EXPR_STRUCTURE
:
2599 t
= gfc_check_constructor (e
, check_restricted
);
2603 t
= gfc_check_constructor (e
, check_restricted
);
2607 gfc_internal_error ("check_restricted(): Unknown expression type");
2614 /* Check to see that an expression is a specification expression. If
2615 we return FAILURE, an error has been generated. */
2618 gfc_specification_expr (gfc_expr
*e
)
2624 if (e
->ts
.type
!= BT_INTEGER
)
2626 gfc_error ("Expression at %L must be of INTEGER type, found %s",
2627 &e
->where
, gfc_basic_typename (e
->ts
.type
));
2631 if (e
->expr_type
== EXPR_FUNCTION
2632 && !e
->value
.function
.isym
2633 && !e
->value
.function
.esym
2634 && !gfc_pure (e
->symtree
->n
.sym
))
2636 gfc_error ("Function '%s' at %L must be PURE",
2637 e
->symtree
->n
.sym
->name
, &e
->where
);
2638 /* Prevent repeat error messages. */
2639 e
->symtree
->n
.sym
->attr
.pure
= 1;
2645 gfc_error ("Expression at %L must be scalar", &e
->where
);
2649 if (gfc_simplify_expr (e
, 0) == FAILURE
)
2652 return check_restricted (e
);
2656 /************** Expression conformance checks. *************/
2658 /* Given two expressions, make sure that the arrays are conformable. */
2661 gfc_check_conformance (const char *optype_msgid
, gfc_expr
*op1
, gfc_expr
*op2
)
2663 int op1_flag
, op2_flag
, d
;
2664 mpz_t op1_size
, op2_size
;
2667 if (op1
->rank
== 0 || op2
->rank
== 0)
2670 if (op1
->rank
!= op2
->rank
)
2672 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid
),
2673 op1
->rank
, op2
->rank
, &op1
->where
);
2679 for (d
= 0; d
< op1
->rank
; d
++)
2681 op1_flag
= gfc_array_dimen_size (op1
, d
, &op1_size
) == SUCCESS
;
2682 op2_flag
= gfc_array_dimen_size (op2
, d
, &op2_size
) == SUCCESS
;
2684 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
2686 gfc_error ("Different shape for %s at %L on dimension %d "
2687 "(%d and %d)", _(optype_msgid
), &op1
->where
, d
+ 1,
2688 (int) mpz_get_si (op1_size
),
2689 (int) mpz_get_si (op2_size
));
2695 mpz_clear (op1_size
);
2697 mpz_clear (op2_size
);
2707 /* Given an assignable expression and an arbitrary expression, make
2708 sure that the assignment can take place. */
2711 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
)
2717 sym
= lvalue
->symtree
->n
.sym
;
2719 /* Check INTENT(IN), unless the object itself is the component or
2720 sub-component of a pointer. */
2721 has_pointer
= sym
->attr
.pointer
;
2723 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2724 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
2730 if (!has_pointer
&& sym
->attr
.intent
== INTENT_IN
)
2732 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2733 sym
->name
, &lvalue
->where
);
2737 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2738 variable local to a function subprogram. Its existence begins when
2739 execution of the function is initiated and ends when execution of the
2740 function is terminated...
2741 Therefore, the left hand side is no longer a variable, when it is: */
2742 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
2743 && !sym
->attr
.external
)
2748 /* (i) Use associated; */
2749 if (sym
->attr
.use_assoc
)
2752 /* (ii) The assignment is in the main program; or */
2753 if (gfc_current_ns
->proc_name
->attr
.is_main_program
)
2756 /* (iii) A module or internal procedure... */
2757 if ((gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
2758 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2759 && gfc_current_ns
->parent
2760 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
2761 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
2762 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
2764 /* ... that is not a function... */
2765 if (!gfc_current_ns
->proc_name
->attr
.function
)
2768 /* ... or is not an entry and has a different name. */
2769 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
2773 /* (iv) Host associated and not the function symbol or the
2774 parent result. This picks up sibling references, which
2775 cannot be entries. */
2776 if (!sym
->attr
.entry
2777 && sym
->ns
== gfc_current_ns
->parent
2778 && sym
!= gfc_current_ns
->proc_name
2779 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
2784 gfc_error ("'%s' at %L is not a VALUE", sym
->name
, &lvalue
->where
);
2789 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
2791 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2792 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
2796 if (lvalue
->ts
.type
== BT_UNKNOWN
)
2798 gfc_error ("Variable type is UNKNOWN in assignment at %L",
2803 if (rvalue
->expr_type
== EXPR_NULL
)
2805 if (lvalue
->symtree
->n
.sym
->attr
.pointer
2806 && lvalue
->symtree
->n
.sym
->attr
.data
)
2810 gfc_error ("NULL appears on right-hand side in assignment at %L",
2816 if (sym
->attr
.cray_pointee
2817 && lvalue
->ref
!= NULL
2818 && lvalue
->ref
->u
.ar
.type
== AR_FULL
2819 && lvalue
->ref
->u
.ar
.as
->cp_was_assumed
)
2821 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2822 "is illegal", &lvalue
->where
);
2826 /* This is possibly a typo: x = f() instead of x => f(). */
2827 if (gfc_option
.warn_surprising
2828 && rvalue
->expr_type
== EXPR_FUNCTION
2829 && rvalue
->symtree
->n
.sym
->attr
.pointer
)
2830 gfc_warning ("POINTER valued function appears on right-hand side of "
2831 "assignment at %L", &rvalue
->where
);
2833 /* Check size of array assignments. */
2834 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
2835 && gfc_check_conformance ("array assignment", lvalue
, rvalue
) != SUCCESS
)
2838 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
2839 && lvalue
->symtree
->n
.sym
->attr
.data
2840 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L used to "
2841 "initialize non-integer variable '%s'",
2842 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
)
2845 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
2846 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
2847 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2848 &rvalue
->where
) == FAILURE
)
2851 /* Handle the case of a BOZ literal on the RHS. */
2852 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
2855 if (gfc_option
.warn_surprising
)
2856 gfc_warning ("BOZ literal at %L is bitwise transferred "
2857 "non-integer symbol '%s'", &rvalue
->where
,
2858 lvalue
->symtree
->n
.sym
->name
);
2859 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
2861 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
2863 if (rc
== ARITH_UNDERFLOW
)
2864 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2865 ". This check can be disabled with the option "
2866 "-fno-range-check", &rvalue
->where
);
2867 else if (rc
== ARITH_OVERFLOW
)
2868 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2869 ". This check can be disabled with the option "
2870 "-fno-range-check", &rvalue
->where
);
2871 else if (rc
== ARITH_NAN
)
2872 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2873 ". This check can be disabled with the option "
2874 "-fno-range-check", &rvalue
->where
);
2879 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
2882 /* Only DATA Statements come here. */
2885 /* Numeric can be converted to any other numeric. And Hollerith can be
2886 converted to any other type. */
2887 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
2888 || rvalue
->ts
.type
== BT_HOLLERITH
)
2891 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
2894 gfc_error ("Incompatible types in DATA statement at %L; attempted "
2895 "conversion of %s to %s", &lvalue
->where
,
2896 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
2901 /* Assignment is the only case where character variables of different
2902 kind values can be converted into one another. */
2903 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
2905 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
2906 gfc_convert_chartype (rvalue
, &lvalue
->ts
);
2911 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
2915 /* Check that a pointer assignment is OK. We first check lvalue, and
2916 we only check rvalue if it's not an assignment to NULL() or a
2917 NULLIFY statement. */
2920 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
2922 symbol_attribute attr
;
2925 int pointer
, check_intent_in
;
2927 if (lvalue
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2928 && !lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
2930 gfc_error ("Pointer assignment target is not a POINTER at %L",
2935 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
2936 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
2938 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2939 "l-value since it is a procedure",
2940 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2945 /* Check INTENT(IN), unless the object itself is the component or
2946 sub-component of a pointer. */
2947 check_intent_in
= 1;
2948 pointer
= lvalue
->symtree
->n
.sym
->attr
.pointer
2949 | lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
2951 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
2954 check_intent_in
= 0;
2956 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
2959 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
2961 if (ref
->u
.ar
.type
== AR_FULL
)
2964 if (ref
->u
.ar
.type
!= AR_SECTION
)
2966 gfc_error ("Expected bounds specification for '%s' at %L",
2967 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2971 if (gfc_notify_std (GFC_STD_F2003
,"Fortran 2003: Bounds "
2972 "specification for '%s' in pointer assignment "
2973 "at %L", lvalue
->symtree
->n
.sym
->name
,
2974 &lvalue
->where
) == FAILURE
)
2977 gfc_error ("Pointer bounds remapping at %L is not yet implemented "
2978 "in gfortran", &lvalue
->where
);
2979 /* TODO: See PR 29785. Add checks that all lbounds are specified and
2980 either never or always the upper-bound; strides shall not be
2986 if (check_intent_in
&& lvalue
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2988 gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2989 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
2995 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue
->where
);
2999 is_pure
= gfc_pure (NULL
);
3001 if (is_pure
&& gfc_impure_variable (lvalue
->symtree
->n
.sym
)
3002 && lvalue
->symtree
->n
.sym
->value
!= rvalue
)
3004 gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue
->where
);
3008 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3009 kind, etc for lvalue and rvalue must match, and rvalue must be a
3010 pure variable if we're in a pure function. */
3011 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3014 /* TODO checks on rvalue for a procedure pointer assignment. */
3015 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
)
3018 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3020 gfc_error ("Different types in pointer assignment at %L; attempted "
3021 "assignment of %s to %s", &lvalue
->where
,
3022 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3026 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3028 gfc_error ("Different kind type parameters in pointer "
3029 "assignment at %L", &lvalue
->where
);
3033 if (lvalue
->rank
!= rvalue
->rank
)
3035 gfc_error ("Different ranks in pointer assignment at %L",
3040 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3041 if (rvalue
->expr_type
== EXPR_NULL
)
3044 if (lvalue
->ts
.type
== BT_CHARACTER
3045 && lvalue
->ts
.cl
&& rvalue
->ts
.cl
3046 && lvalue
->ts
.cl
->length
&& rvalue
->ts
.cl
->length
3047 && abs (gfc_dep_compare_expr (lvalue
->ts
.cl
->length
,
3048 rvalue
->ts
.cl
->length
)) == 1)
3050 gfc_error ("Different character lengths in pointer "
3051 "assignment at %L", &lvalue
->where
);
3055 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3056 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3058 attr
= gfc_expr_attr (rvalue
);
3059 if (!attr
.target
&& !attr
.pointer
)
3061 gfc_error ("Pointer assignment target is neither TARGET "
3062 "nor POINTER at %L", &rvalue
->where
);
3066 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3068 gfc_error ("Bad target in pointer assignment in PURE "
3069 "procedure at %L", &rvalue
->where
);
3072 if (gfc_has_vector_index (rvalue
))
3074 gfc_error ("Pointer assignment with vector subscript "
3075 "on rhs at %L", &rvalue
->where
);
3079 if (attr
.is_protected
&& attr
.use_assoc
3080 && !(attr
.pointer
|| attr
.proc_pointer
))
3082 gfc_error ("Pointer assignment target has PROTECTED "
3083 "attribute at %L", &rvalue
->where
);
3091 /* Relative of gfc_check_assign() except that the lvalue is a single
3092 symbol. Used for initialization assignments. */
3095 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_expr
*rvalue
)
3100 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3102 lvalue
.expr_type
= EXPR_VARIABLE
;
3103 lvalue
.ts
= sym
->ts
;
3105 lvalue
.rank
= sym
->as
->rank
;
3106 lvalue
.symtree
= (gfc_symtree
*) gfc_getmem (sizeof (gfc_symtree
));
3107 lvalue
.symtree
->n
.sym
= sym
;
3108 lvalue
.where
= sym
->declared_at
;
3110 if (sym
->attr
.pointer
|| sym
->attr
.proc_pointer
)
3111 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
3113 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
3115 gfc_free (lvalue
.symtree
);
3121 /* Get an expression for a default initializer. */
3124 gfc_default_initializer (gfc_typespec
*ts
)
3126 gfc_constructor
*tail
;
3130 /* See if we have a default initializer. */
3131 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3132 if (c
->initializer
|| c
->attr
.allocatable
)
3138 /* Build the constructor. */
3139 init
= gfc_get_expr ();
3140 init
->expr_type
= EXPR_STRUCTURE
;
3142 init
->where
= ts
->derived
->declared_at
;
3145 for (c
= ts
->derived
->components
; c
; c
= c
->next
)
3148 init
->value
.constructor
= tail
= gfc_get_constructor ();
3151 tail
->next
= gfc_get_constructor ();
3156 tail
->expr
= gfc_copy_expr (c
->initializer
);
3158 if (c
->attr
.allocatable
)
3160 tail
->expr
= gfc_get_expr ();
3161 tail
->expr
->expr_type
= EXPR_NULL
;
3162 tail
->expr
->ts
= c
->ts
;
3169 /* Given a symbol, create an expression node with that symbol as a
3170 variable. If the symbol is array valued, setup a reference of the
3174 gfc_get_variable_expr (gfc_symtree
*var
)
3178 e
= gfc_get_expr ();
3179 e
->expr_type
= EXPR_VARIABLE
;
3181 e
->ts
= var
->n
.sym
->ts
;
3183 if (var
->n
.sym
->as
!= NULL
)
3185 e
->rank
= var
->n
.sym
->as
->rank
;
3186 e
->ref
= gfc_get_ref ();
3187 e
->ref
->type
= REF_ARRAY
;
3188 e
->ref
->u
.ar
.type
= AR_FULL
;
3195 /* General expression traversal function. */
3198 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
3199 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
3204 gfc_actual_arglist
*args
;
3211 if ((*func
) (expr
, sym
, &f
))
3214 if (expr
->ts
.type
== BT_CHARACTER
3216 && expr
->ts
.cl
->length
3217 && expr
->ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
3218 && gfc_traverse_expr (expr
->ts
.cl
->length
, sym
, func
, f
))
3221 switch (expr
->expr_type
)
3224 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
3226 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
3234 case EXPR_SUBSTRING
:
3237 case EXPR_STRUCTURE
:
3239 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
3241 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
3245 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
3247 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
3249 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
3251 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
3258 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
3260 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
3276 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
3278 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
3280 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
3282 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
3288 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
3290 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
3295 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
3296 && ref
->u
.c
.component
->ts
.cl
3297 && ref
->u
.c
.component
->ts
.cl
->length
3298 && ref
->u
.c
.component
->ts
.cl
->length
->expr_type
3300 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.cl
->length
,
3304 if (ref
->u
.c
.component
->as
)
3305 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
; i
++)
3307 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
3310 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
3324 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
3327 expr_set_symbols_referenced (gfc_expr
*expr
,
3328 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3329 int *f ATTRIBUTE_UNUSED
)
3331 if (expr
->expr_type
!= EXPR_VARIABLE
)
3333 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
3338 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
3340 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
3344 /* Walk an expression tree and check each variable encountered for being typed.
3345 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3346 mode; this is for things in legacy-code like:
3348 INTEGER :: arr(n), n
3350 The namespace is needed for IMPLICIT typing. */
3352 static gfc_namespace
* check_typed_ns
;
3355 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
3356 int* f ATTRIBUTE_UNUSED
)
3360 if (e
->expr_type
!= EXPR_VARIABLE
)
3363 gcc_assert (e
->symtree
);
3364 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
3367 return (t
== FAILURE
);
3371 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
3375 /* If this is a top-level variable, do the check with strict given to us. */
3376 if (!strict
&& e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
3377 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
3379 /* Otherwise, walk the expression and do it strictly. */
3380 check_typed_ns
= ns
;
3381 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
3383 return error_found
? FAILURE
: SUCCESS
;