1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000-2018 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #include "constructor.h"
33 /* The following set of functions provide access to gfc_expr* of
34 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
36 There are two functions available elsewhere that provide
37 slightly different flavours of variables. Namely:
38 expr.c (gfc_get_variable_expr)
39 symbol.c (gfc_lval_expr_from_sym)
40 TODO: Merge these functions, if possible. */
42 /* Get a new expression node. */
50 gfc_clear_ts (&e
->ts
);
58 /* Get a new expression node that is an array constructor
59 of given type and kind. */
62 gfc_get_array_expr (bt type
, int kind
, locus
*where
)
67 e
->expr_type
= EXPR_ARRAY
;
68 e
->value
.constructor
= NULL
;
81 /* Get a new expression node that is the NULL expression. */
84 gfc_get_null_expr (locus
*where
)
89 e
->expr_type
= EXPR_NULL
;
90 e
->ts
.type
= BT_UNKNOWN
;
99 /* Get a new expression node that is an operator expression node. */
102 gfc_get_operator_expr (locus
*where
, gfc_intrinsic_op op
,
103 gfc_expr
*op1
, gfc_expr
*op2
)
108 e
->expr_type
= EXPR_OP
;
110 e
->value
.op
.op1
= op1
;
111 e
->value
.op
.op2
= op2
;
120 /* Get a new expression node that is an structure constructor
121 of given type and kind. */
124 gfc_get_structure_constructor_expr (bt type
, int kind
, locus
*where
)
129 e
->expr_type
= EXPR_STRUCTURE
;
130 e
->value
.constructor
= NULL
;
141 /* Get a new expression node that is an constant of given type and kind. */
144 gfc_get_constant_expr (bt type
, int kind
, locus
*where
)
149 gfc_internal_error ("gfc_get_constant_expr(): locus %<where%> cannot be "
154 e
->expr_type
= EXPR_CONSTANT
;
162 mpz_init (e
->value
.integer
);
166 gfc_set_model_kind (kind
);
167 mpfr_init (e
->value
.real
);
171 gfc_set_model_kind (kind
);
172 mpc_init2 (e
->value
.complex, mpfr_get_default_prec());
183 /* Get a new expression node that is an string constant.
184 If no string is passed, a string of len is allocated,
185 blanked and null-terminated. */
188 gfc_get_character_expr (int kind
, locus
*where
, const char *src
, gfc_charlen_t len
)
195 dest
= gfc_get_wide_string (len
+ 1);
196 gfc_wide_memset (dest
, ' ', len
);
200 dest
= gfc_char_to_widechar (src
);
202 e
= gfc_get_constant_expr (BT_CHARACTER
, kind
,
203 where
? where
: &gfc_current_locus
);
204 e
->value
.character
.string
= dest
;
205 e
->value
.character
.length
= len
;
211 /* Get a new expression node that is an integer constant. */
214 gfc_get_int_expr (int kind
, locus
*where
, HOST_WIDE_INT value
)
217 p
= gfc_get_constant_expr (BT_INTEGER
, kind
,
218 where
? where
: &gfc_current_locus
);
220 const wide_int w
= wi::shwi (value
, kind
* BITS_PER_UNIT
);
221 wi::to_mpz (w
, p
->value
.integer
, SIGNED
);
227 /* Get a new expression node that is a logical constant. */
230 gfc_get_logical_expr (int kind
, locus
*where
, bool value
)
233 p
= gfc_get_constant_expr (BT_LOGICAL
, kind
,
234 where
? where
: &gfc_current_locus
);
236 p
->value
.logical
= value
;
243 gfc_get_iokind_expr (locus
*where
, io_kind k
)
247 /* Set the types to something compatible with iokind. This is needed to
248 get through gfc_free_expr later since iokind really has no Basic Type,
252 e
->expr_type
= EXPR_CONSTANT
;
253 e
->ts
.type
= BT_LOGICAL
;
261 /* Given an expression pointer, return a copy of the expression. This
262 subroutine is recursive. */
265 gfc_copy_expr (gfc_expr
*p
)
277 switch (q
->expr_type
)
280 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
281 q
->value
.character
.string
= s
;
282 memcpy (s
, p
->value
.character
.string
,
283 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
287 /* Copy target representation, if it exists. */
288 if (p
->representation
.string
)
290 c
= XCNEWVEC (char, p
->representation
.length
+ 1);
291 q
->representation
.string
= c
;
292 memcpy (c
, p
->representation
.string
, (p
->representation
.length
+ 1));
295 /* Copy the values of any pointer components of p->value. */
299 mpz_init_set (q
->value
.integer
, p
->value
.integer
);
303 gfc_set_model_kind (q
->ts
.kind
);
304 mpfr_init (q
->value
.real
);
305 mpfr_set (q
->value
.real
, p
->value
.real
, GFC_RND_MODE
);
309 gfc_set_model_kind (q
->ts
.kind
);
310 mpc_init2 (q
->value
.complex, mpfr_get_default_prec());
311 mpc_set (q
->value
.complex, p
->value
.complex, GFC_MPC_RND_MODE
);
315 if (p
->representation
.string
)
316 q
->value
.character
.string
317 = gfc_char_to_widechar (q
->representation
.string
);
320 s
= gfc_get_wide_string (p
->value
.character
.length
+ 1);
321 q
->value
.character
.string
= s
;
323 /* This is the case for the C_NULL_CHAR named constant. */
324 if (p
->value
.character
.length
== 0
325 && (p
->ts
.is_c_interop
|| p
->ts
.is_iso_c
))
328 /* Need to set the length to 1 to make sure the NUL
329 terminator is copied. */
330 q
->value
.character
.length
= 1;
333 memcpy (s
, p
->value
.character
.string
,
334 (p
->value
.character
.length
+ 1) * sizeof (gfc_char_t
));
343 break; /* Already done. */
347 /* Should never be reached. */
349 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
356 switch (q
->value
.op
.op
)
359 case INTRINSIC_PARENTHESES
:
360 case INTRINSIC_UPLUS
:
361 case INTRINSIC_UMINUS
:
362 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
365 default: /* Binary operators. */
366 q
->value
.op
.op1
= gfc_copy_expr (p
->value
.op
.op1
);
367 q
->value
.op
.op2
= gfc_copy_expr (p
->value
.op
.op2
);
374 q
->value
.function
.actual
=
375 gfc_copy_actual_arglist (p
->value
.function
.actual
);
380 q
->value
.compcall
.actual
=
381 gfc_copy_actual_arglist (p
->value
.compcall
.actual
);
382 q
->value
.compcall
.tbp
= p
->value
.compcall
.tbp
;
387 q
->value
.constructor
= gfc_constructor_copy (p
->value
.constructor
);
395 q
->shape
= gfc_copy_shape (p
->shape
, p
->rank
);
397 q
->ref
= gfc_copy_ref (p
->ref
);
400 q
->param_list
= gfc_copy_actual_arglist (p
->param_list
);
407 gfc_clear_shape (mpz_t
*shape
, int rank
)
411 for (i
= 0; i
< rank
; i
++)
412 mpz_clear (shape
[i
]);
417 gfc_free_shape (mpz_t
**shape
, int rank
)
422 gfc_clear_shape (*shape
, rank
);
428 /* Workhorse function for gfc_free_expr() that frees everything
429 beneath an expression node, but not the node itself. This is
430 useful when we want to simplify a node and replace it with
431 something else or the expression node belongs to another structure. */
434 free_expr0 (gfc_expr
*e
)
436 switch (e
->expr_type
)
439 /* Free any parts of the value that need freeing. */
443 mpz_clear (e
->value
.integer
);
447 mpfr_clear (e
->value
.real
);
451 free (e
->value
.character
.string
);
455 mpc_clear (e
->value
.complex);
462 /* Free the representation. */
463 free (e
->representation
.string
);
468 if (e
->value
.op
.op1
!= NULL
)
469 gfc_free_expr (e
->value
.op
.op1
);
470 if (e
->value
.op
.op2
!= NULL
)
471 gfc_free_expr (e
->value
.op
.op2
);
475 gfc_free_actual_arglist (e
->value
.function
.actual
);
480 gfc_free_actual_arglist (e
->value
.compcall
.actual
);
488 gfc_constructor_free (e
->value
.constructor
);
492 free (e
->value
.character
.string
);
499 gfc_internal_error ("free_expr0(): Bad expr type");
502 /* Free a shape array. */
503 gfc_free_shape (&e
->shape
, e
->rank
);
505 gfc_free_ref_list (e
->ref
);
507 gfc_free_actual_arglist (e
->param_list
);
509 memset (e
, '\0', sizeof (gfc_expr
));
513 /* Free an expression node and everything beneath it. */
516 gfc_free_expr (gfc_expr
*e
)
525 /* Free an argument list and everything below it. */
528 gfc_free_actual_arglist (gfc_actual_arglist
*a1
)
530 gfc_actual_arglist
*a2
;
536 gfc_free_expr (a1
->expr
);
543 /* Copy an arglist structure and all of the arguments. */
546 gfc_copy_actual_arglist (gfc_actual_arglist
*p
)
548 gfc_actual_arglist
*head
, *tail
, *new_arg
;
552 for (; p
; p
= p
->next
)
554 new_arg
= gfc_get_actual_arglist ();
557 new_arg
->expr
= gfc_copy_expr (p
->expr
);
558 new_arg
->next
= NULL
;
563 tail
->next
= new_arg
;
572 /* Free a list of reference structures. */
575 gfc_free_ref_list (gfc_ref
*p
)
587 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
589 gfc_free_expr (p
->u
.ar
.start
[i
]);
590 gfc_free_expr (p
->u
.ar
.end
[i
]);
591 gfc_free_expr (p
->u
.ar
.stride
[i
]);
597 gfc_free_expr (p
->u
.ss
.start
);
598 gfc_free_expr (p
->u
.ss
.end
);
610 /* Graft the *src expression onto the *dest subexpression. */
613 gfc_replace_expr (gfc_expr
*dest
, gfc_expr
*src
)
621 /* Try to extract an integer constant from the passed expression node.
622 Return true if some error occurred, false on success. If REPORT_ERROR
623 is non-zero, emit error, for positive REPORT_ERROR using gfc_error,
624 for negative using gfc_error_now. */
627 gfc_extract_int (gfc_expr
*expr
, int *result
, int report_error
)
631 /* A KIND component is a parameter too. The expression for it
632 is stored in the initializer and should be consistent with
634 if (gfc_expr_attr(expr
).pdt_kind
)
636 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
638 if (ref
->u
.c
.component
->attr
.pdt_kind
)
639 expr
= ref
->u
.c
.component
->initializer
;
643 if (expr
->expr_type
!= EXPR_CONSTANT
)
645 if (report_error
> 0)
646 gfc_error ("Constant expression required at %C");
647 else if (report_error
< 0)
648 gfc_error_now ("Constant expression required at %C");
652 if (expr
->ts
.type
!= BT_INTEGER
)
654 if (report_error
> 0)
655 gfc_error ("Integer expression required at %C");
656 else if (report_error
< 0)
657 gfc_error_now ("Integer expression required at %C");
661 if ((mpz_cmp_si (expr
->value
.integer
, INT_MAX
) > 0)
662 || (mpz_cmp_si (expr
->value
.integer
, INT_MIN
) < 0))
664 if (report_error
> 0)
665 gfc_error ("Integer value too large in expression at %C");
666 else if (report_error
< 0)
667 gfc_error_now ("Integer value too large in expression at %C");
671 *result
= (int) mpz_get_si (expr
->value
.integer
);
677 /* Same as gfc_extract_int, but use a HWI. */
680 gfc_extract_hwi (gfc_expr
*expr
, HOST_WIDE_INT
*result
, int report_error
)
684 /* A KIND component is a parameter too. The expression for it is
685 stored in the initializer and should be consistent with the tests
687 if (gfc_expr_attr(expr
).pdt_kind
)
689 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
691 if (ref
->u
.c
.component
->attr
.pdt_kind
)
692 expr
= ref
->u
.c
.component
->initializer
;
696 if (expr
->expr_type
!= EXPR_CONSTANT
)
698 if (report_error
> 0)
699 gfc_error ("Constant expression required at %C");
700 else if (report_error
< 0)
701 gfc_error_now ("Constant expression required at %C");
705 if (expr
->ts
.type
!= BT_INTEGER
)
707 if (report_error
> 0)
708 gfc_error ("Integer expression required at %C");
709 else if (report_error
< 0)
710 gfc_error_now ("Integer expression required at %C");
714 /* Use long_long_integer_type_node to determine when to saturate. */
715 const wide_int val
= wi::from_mpz (long_long_integer_type_node
,
716 expr
->value
.integer
, false);
718 if (!wi::fits_shwi_p (val
))
720 if (report_error
> 0)
721 gfc_error ("Integer value too large in expression at %C");
722 else if (report_error
< 0)
723 gfc_error_now ("Integer value too large in expression at %C");
727 *result
= val
.to_shwi ();
733 /* Recursively copy a list of reference structures. */
736 gfc_copy_ref (gfc_ref
*src
)
744 dest
= gfc_get_ref ();
745 dest
->type
= src
->type
;
750 ar
= gfc_copy_array_ref (&src
->u
.ar
);
756 dest
->u
.c
= src
->u
.c
;
760 dest
->u
.ss
= src
->u
.ss
;
761 dest
->u
.ss
.start
= gfc_copy_expr (src
->u
.ss
.start
);
762 dest
->u
.ss
.end
= gfc_copy_expr (src
->u
.ss
.end
);
766 dest
->next
= gfc_copy_ref (src
->next
);
772 /* Detect whether an expression has any vector index array references. */
775 gfc_has_vector_index (gfc_expr
*e
)
779 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
780 if (ref
->type
== REF_ARRAY
)
781 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
782 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
788 /* Copy a shape array. */
791 gfc_copy_shape (mpz_t
*shape
, int rank
)
799 new_shape
= gfc_get_shape (rank
);
801 for (n
= 0; n
< rank
; n
++)
802 mpz_init_set (new_shape
[n
], shape
[n
]);
808 /* Copy a shape array excluding dimension N, where N is an integer
809 constant expression. Dimensions are numbered in Fortran style --
812 So, if the original shape array contains R elements
813 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
814 the result contains R-1 elements:
815 { s1 ... sN-1 sN+1 ... sR-1}
817 If anything goes wrong -- N is not a constant, its value is out
818 of range -- or anything else, just returns NULL. */
821 gfc_copy_shape_excluding (mpz_t
*shape
, int rank
, gfc_expr
*dim
)
823 mpz_t
*new_shape
, *s
;
829 || dim
->expr_type
!= EXPR_CONSTANT
830 || dim
->ts
.type
!= BT_INTEGER
)
833 n
= mpz_get_si (dim
->value
.integer
);
834 n
--; /* Convert to zero based index. */
835 if (n
< 0 || n
>= rank
)
838 s
= new_shape
= gfc_get_shape (rank
- 1);
840 for (i
= 0; i
< rank
; i
++)
844 mpz_init_set (*s
, shape
[i
]);
852 /* Return the maximum kind of two expressions. In general, higher
853 kind numbers mean more precision for numeric types. */
856 gfc_kind_max (gfc_expr
*e1
, gfc_expr
*e2
)
858 return (e1
->ts
.kind
> e2
->ts
.kind
) ? e1
->ts
.kind
: e2
->ts
.kind
;
862 /* Returns nonzero if the type is numeric, zero otherwise. */
865 numeric_type (bt type
)
867 return type
== BT_COMPLEX
|| type
== BT_REAL
|| type
== BT_INTEGER
;
871 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
874 gfc_numeric_ts (gfc_typespec
*ts
)
876 return numeric_type (ts
->type
);
880 /* Return an expression node with an optional argument list attached.
881 A variable number of gfc_expr pointers are strung together in an
882 argument list with a NULL pointer terminating the list. */
885 gfc_build_conversion (gfc_expr
*e
)
890 p
->expr_type
= EXPR_FUNCTION
;
892 p
->value
.function
.actual
= gfc_get_actual_arglist ();
893 p
->value
.function
.actual
->expr
= e
;
899 /* Given an expression node with some sort of numeric binary
900 expression, insert type conversions required to make the operands
901 have the same type. Conversion warnings are disabled if wconversion
904 The exception is that the operands of an exponential don't have to
905 have the same type. If possible, the base is promoted to the type
906 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
907 1.0**2 stays as it is. */
910 gfc_type_convert_binary (gfc_expr
*e
, int wconversion
)
914 op1
= e
->value
.op
.op1
;
915 op2
= e
->value
.op
.op2
;
917 if (op1
->ts
.type
== BT_UNKNOWN
|| op2
->ts
.type
== BT_UNKNOWN
)
919 gfc_clear_ts (&e
->ts
);
923 /* Kind conversions of same type. */
924 if (op1
->ts
.type
== op2
->ts
.type
)
926 if (op1
->ts
.kind
== op2
->ts
.kind
)
928 /* No type conversions. */
933 if (op1
->ts
.kind
> op2
->ts
.kind
)
934 gfc_convert_type_warn (op2
, &op1
->ts
, 2, wconversion
);
936 gfc_convert_type_warn (op1
, &op2
->ts
, 2, wconversion
);
942 /* Integer combined with real or complex. */
943 if (op2
->ts
.type
== BT_INTEGER
)
947 /* Special case for ** operator. */
948 if (e
->value
.op
.op
== INTRINSIC_POWER
)
951 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
955 if (op1
->ts
.type
== BT_INTEGER
)
958 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
962 /* Real combined with complex. */
963 e
->ts
.type
= BT_COMPLEX
;
964 if (op1
->ts
.kind
> op2
->ts
.kind
)
965 e
->ts
.kind
= op1
->ts
.kind
;
967 e
->ts
.kind
= op2
->ts
.kind
;
968 if (op1
->ts
.type
!= BT_COMPLEX
|| op1
->ts
.kind
!= e
->ts
.kind
)
969 gfc_convert_type_warn (e
->value
.op
.op1
, &e
->ts
, 2, wconversion
);
970 if (op2
->ts
.type
!= BT_COMPLEX
|| op2
->ts
.kind
!= e
->ts
.kind
)
971 gfc_convert_type_warn (e
->value
.op
.op2
, &e
->ts
, 2, wconversion
);
978 /* Determine if an expression is constant in the sense of F08:7.1.12.
979 * This function expects that the expression has already been simplified. */
982 gfc_is_constant_expr (gfc_expr
*e
)
985 gfc_actual_arglist
*arg
;
990 switch (e
->expr_type
)
993 return (gfc_is_constant_expr (e
->value
.op
.op1
)
994 && (e
->value
.op
.op2
== NULL
995 || gfc_is_constant_expr (e
->value
.op
.op2
)));
998 /* The only context in which this can occur is in a parameterized
999 derived type declaration, so returning true is OK. */
1000 if (e
->symtree
->n
.sym
->attr
.pdt_len
1001 || e
->symtree
->n
.sym
->attr
.pdt_kind
)
1008 gcc_assert (e
->symtree
|| e
->value
.function
.esym
1009 || e
->value
.function
.isym
);
1011 /* Call to intrinsic with at least one argument. */
1012 if (e
->value
.function
.isym
&& e
->value
.function
.actual
)
1014 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1015 if (!gfc_is_constant_expr (arg
->expr
))
1019 if (e
->value
.function
.isym
1020 && (e
->value
.function
.isym
->elemental
1021 || e
->value
.function
.isym
->pure
1022 || e
->value
.function
.isym
->inquiry
1023 || e
->value
.function
.isym
->transformational
))
1032 case EXPR_SUBSTRING
:
1033 return e
->ref
== NULL
|| (gfc_is_constant_expr (e
->ref
->u
.ss
.start
)
1034 && gfc_is_constant_expr (e
->ref
->u
.ss
.end
));
1037 case EXPR_STRUCTURE
:
1038 c
= gfc_constructor_first (e
->value
.constructor
);
1039 if ((e
->expr_type
== EXPR_ARRAY
) && c
&& c
->iterator
)
1040 return gfc_constant_ac (e
);
1042 for (; c
; c
= gfc_constructor_next (c
))
1043 if (!gfc_is_constant_expr (c
->expr
))
1050 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
1056 /* Is true if an array reference is followed by a component or substring
1059 is_subref_array (gfc_expr
* e
)
1064 if (e
->expr_type
!= EXPR_VARIABLE
)
1067 if (e
->symtree
->n
.sym
->attr
.subref_array_pointer
)
1070 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
1071 && e
->symtree
->n
.sym
->attr
.dummy
1072 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.class_pointer
)
1076 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1078 if (ref
->type
== REF_ARRAY
1079 && ref
->u
.ar
.type
!= AR_ELEMENT
)
1083 && ref
->type
!= REF_ARRAY
)
1090 /* Try to collapse intrinsic expressions. */
1093 simplify_intrinsic_op (gfc_expr
*p
, int type
)
1095 gfc_intrinsic_op op
;
1096 gfc_expr
*op1
, *op2
, *result
;
1098 if (p
->value
.op
.op
== INTRINSIC_USER
)
1101 op1
= p
->value
.op
.op1
;
1102 op2
= p
->value
.op
.op2
;
1103 op
= p
->value
.op
.op
;
1105 if (!gfc_simplify_expr (op1
, type
))
1107 if (!gfc_simplify_expr (op2
, type
))
1110 if (!gfc_is_constant_expr (op1
)
1111 || (op2
!= NULL
&& !gfc_is_constant_expr (op2
)))
1115 p
->value
.op
.op1
= NULL
;
1116 p
->value
.op
.op2
= NULL
;
1120 case INTRINSIC_PARENTHESES
:
1121 result
= gfc_parentheses (op1
);
1124 case INTRINSIC_UPLUS
:
1125 result
= gfc_uplus (op1
);
1128 case INTRINSIC_UMINUS
:
1129 result
= gfc_uminus (op1
);
1132 case INTRINSIC_PLUS
:
1133 result
= gfc_add (op1
, op2
);
1136 case INTRINSIC_MINUS
:
1137 result
= gfc_subtract (op1
, op2
);
1140 case INTRINSIC_TIMES
:
1141 result
= gfc_multiply (op1
, op2
);
1144 case INTRINSIC_DIVIDE
:
1145 result
= gfc_divide (op1
, op2
);
1148 case INTRINSIC_POWER
:
1149 result
= gfc_power (op1
, op2
);
1152 case INTRINSIC_CONCAT
:
1153 result
= gfc_concat (op1
, op2
);
1157 case INTRINSIC_EQ_OS
:
1158 result
= gfc_eq (op1
, op2
, op
);
1162 case INTRINSIC_NE_OS
:
1163 result
= gfc_ne (op1
, op2
, op
);
1167 case INTRINSIC_GT_OS
:
1168 result
= gfc_gt (op1
, op2
, op
);
1172 case INTRINSIC_GE_OS
:
1173 result
= gfc_ge (op1
, op2
, op
);
1177 case INTRINSIC_LT_OS
:
1178 result
= gfc_lt (op1
, op2
, op
);
1182 case INTRINSIC_LE_OS
:
1183 result
= gfc_le (op1
, op2
, op
);
1187 result
= gfc_not (op1
);
1191 result
= gfc_and (op1
, op2
);
1195 result
= gfc_or (op1
, op2
);
1199 result
= gfc_eqv (op1
, op2
);
1202 case INTRINSIC_NEQV
:
1203 result
= gfc_neqv (op1
, op2
);
1207 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1212 gfc_free_expr (op1
);
1213 gfc_free_expr (op2
);
1217 result
->rank
= p
->rank
;
1218 result
->where
= p
->where
;
1219 gfc_replace_expr (p
, result
);
1225 /* Subroutine to simplify constructor expressions. Mutually recursive
1226 with gfc_simplify_expr(). */
1229 simplify_constructor (gfc_constructor_base base
, int type
)
1234 for (c
= gfc_constructor_first (base
); c
; c
= gfc_constructor_next (c
))
1237 && (!gfc_simplify_expr(c
->iterator
->start
, type
)
1238 || !gfc_simplify_expr (c
->iterator
->end
, type
)
1239 || !gfc_simplify_expr (c
->iterator
->step
, type
)))
1244 /* Try and simplify a copy. Replace the original if successful
1245 but keep going through the constructor at all costs. Not
1246 doing so can make a dog's dinner of complicated things. */
1247 p
= gfc_copy_expr (c
->expr
);
1249 if (!gfc_simplify_expr (p
, type
))
1255 gfc_replace_expr (c
->expr
, p
);
1263 /* Pull a single array element out of an array constructor. */
1266 find_array_element (gfc_constructor_base base
, gfc_array_ref
*ar
,
1267 gfc_constructor
**rval
)
1269 unsigned long nelemen
;
1275 gfc_constructor
*cons
;
1282 mpz_init_set_ui (offset
, 0);
1285 mpz_init_set_ui (span
, 1);
1286 for (i
= 0; i
< ar
->dimen
; i
++)
1288 if (!gfc_reduce_init_expr (ar
->as
->lower
[i
])
1289 || !gfc_reduce_init_expr (ar
->as
->upper
[i
]))
1297 if (e
->expr_type
!= EXPR_CONSTANT
)
1303 gcc_assert (ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
1304 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
);
1306 /* Check the bounds. */
1307 if ((ar
->as
->upper
[i
]
1308 && mpz_cmp (e
->value
.integer
,
1309 ar
->as
->upper
[i
]->value
.integer
) > 0)
1310 || (mpz_cmp (e
->value
.integer
,
1311 ar
->as
->lower
[i
]->value
.integer
) < 0))
1313 gfc_error ("Index in dimension %d is out of bounds "
1314 "at %L", i
+ 1, &ar
->c_where
[i
]);
1320 mpz_sub (delta
, e
->value
.integer
, ar
->as
->lower
[i
]->value
.integer
);
1321 mpz_mul (delta
, delta
, span
);
1322 mpz_add (offset
, offset
, delta
);
1324 mpz_set_ui (tmp
, 1);
1325 mpz_add (tmp
, tmp
, ar
->as
->upper
[i
]->value
.integer
);
1326 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
1327 mpz_mul (span
, span
, tmp
);
1330 for (cons
= gfc_constructor_first (base
), nelemen
= mpz_get_ui (offset
);
1331 cons
&& nelemen
> 0; cons
= gfc_constructor_next (cons
), nelemen
--)
1350 /* Find a component of a structure constructor. */
1352 static gfc_constructor
*
1353 find_component_ref (gfc_constructor_base base
, gfc_ref
*ref
)
1355 gfc_component
*pick
= ref
->u
.c
.component
;
1356 gfc_constructor
*c
= gfc_constructor_first (base
);
1358 gfc_symbol
*dt
= ref
->u
.c
.sym
;
1359 int ext
= dt
->attr
.extension
;
1361 /* For extended types, check if the desired component is in one of the
1363 while (ext
> 0 && gfc_find_component (dt
->components
->ts
.u
.derived
,
1364 pick
->name
, true, true, NULL
))
1366 dt
= dt
->components
->ts
.u
.derived
;
1367 c
= gfc_constructor_first (c
->expr
->value
.constructor
);
1371 gfc_component
*comp
= dt
->components
;
1372 while (comp
!= pick
)
1375 c
= gfc_constructor_next (c
);
1382 /* Replace an expression with the contents of a constructor, removing
1383 the subobject reference in the process. */
1386 remove_subobject_ref (gfc_expr
*p
, gfc_constructor
*cons
)
1396 e
= gfc_copy_expr (p
);
1397 e
->ref
= p
->ref
->next
;
1398 p
->ref
->next
= NULL
;
1399 gfc_replace_expr (p
, e
);
1403 /* Pull an array section out of an array constructor. */
1406 find_array_section (gfc_expr
*expr
, gfc_ref
*ref
)
1413 long unsigned one
= 1;
1415 mpz_t start
[GFC_MAX_DIMENSIONS
];
1416 mpz_t end
[GFC_MAX_DIMENSIONS
];
1417 mpz_t stride
[GFC_MAX_DIMENSIONS
];
1418 mpz_t delta
[GFC_MAX_DIMENSIONS
];
1419 mpz_t ctr
[GFC_MAX_DIMENSIONS
];
1424 gfc_constructor_base base
;
1425 gfc_constructor
*cons
, *vecsub
[GFC_MAX_DIMENSIONS
];
1435 base
= expr
->value
.constructor
;
1436 expr
->value
.constructor
= NULL
;
1438 rank
= ref
->u
.ar
.as
->rank
;
1440 if (expr
->shape
== NULL
)
1441 expr
->shape
= gfc_get_shape (rank
);
1443 mpz_init_set_ui (delta_mpz
, one
);
1444 mpz_init_set_ui (nelts
, one
);
1447 /* Do the initialization now, so that we can cleanup without
1448 keeping track of where we were. */
1449 for (d
= 0; d
< rank
; d
++)
1451 mpz_init (delta
[d
]);
1452 mpz_init (start
[d
]);
1455 mpz_init (stride
[d
]);
1459 /* Build the counters to clock through the array reference. */
1461 for (d
= 0; d
< rank
; d
++)
1463 /* Make this stretch of code easier on the eye! */
1464 begin
= ref
->u
.ar
.start
[d
];
1465 finish
= ref
->u
.ar
.end
[d
];
1466 step
= ref
->u
.ar
.stride
[d
];
1467 lower
= ref
->u
.ar
.as
->lower
[d
];
1468 upper
= ref
->u
.ar
.as
->upper
[d
];
1470 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1472 gfc_constructor
*ci
;
1475 if (begin
->expr_type
!= EXPR_ARRAY
|| !gfc_is_constant_expr (begin
))
1481 gcc_assert (begin
->rank
== 1);
1482 /* Zero-sized arrays have no shape and no elements, stop early. */
1485 mpz_init_set_ui (nelts
, 0);
1489 vecsub
[d
] = gfc_constructor_first (begin
->value
.constructor
);
1490 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1491 mpz_mul (nelts
, nelts
, begin
->shape
[0]);
1492 mpz_set (expr
->shape
[shape_i
++], begin
->shape
[0]);
1495 for (ci
= vecsub
[d
]; ci
; ci
= gfc_constructor_next (ci
))
1497 if (mpz_cmp (ci
->expr
->value
.integer
, upper
->value
.integer
) > 0
1498 || mpz_cmp (ci
->expr
->value
.integer
,
1499 lower
->value
.integer
) < 0)
1501 gfc_error ("index in dimension %d is out of bounds "
1502 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1510 if ((begin
&& begin
->expr_type
!= EXPR_CONSTANT
)
1511 || (finish
&& finish
->expr_type
!= EXPR_CONSTANT
)
1512 || (step
&& step
->expr_type
!= EXPR_CONSTANT
))
1518 /* Obtain the stride. */
1520 mpz_set (stride
[d
], step
->value
.integer
);
1522 mpz_set_ui (stride
[d
], one
);
1524 if (mpz_cmp_ui (stride
[d
], 0) == 0)
1525 mpz_set_ui (stride
[d
], one
);
1527 /* Obtain the start value for the index. */
1529 mpz_set (start
[d
], begin
->value
.integer
);
1531 mpz_set (start
[d
], lower
->value
.integer
);
1533 mpz_set (ctr
[d
], start
[d
]);
1535 /* Obtain the end value for the index. */
1537 mpz_set (end
[d
], finish
->value
.integer
);
1539 mpz_set (end
[d
], upper
->value
.integer
);
1541 /* Separate 'if' because elements sometimes arrive with
1543 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_ELEMENT
)
1544 mpz_set (end
[d
], begin
->value
.integer
);
1546 /* Check the bounds. */
1547 if (mpz_cmp (ctr
[d
], upper
->value
.integer
) > 0
1548 || mpz_cmp (end
[d
], upper
->value
.integer
) > 0
1549 || mpz_cmp (ctr
[d
], lower
->value
.integer
) < 0
1550 || mpz_cmp (end
[d
], lower
->value
.integer
) < 0)
1552 gfc_error ("index in dimension %d is out of bounds "
1553 "at %L", d
+ 1, &ref
->u
.ar
.c_where
[d
]);
1558 /* Calculate the number of elements and the shape. */
1559 mpz_set (tmp_mpz
, stride
[d
]);
1560 mpz_add (tmp_mpz
, end
[d
], tmp_mpz
);
1561 mpz_sub (tmp_mpz
, tmp_mpz
, ctr
[d
]);
1562 mpz_div (tmp_mpz
, tmp_mpz
, stride
[d
]);
1563 mpz_mul (nelts
, nelts
, tmp_mpz
);
1565 /* An element reference reduces the rank of the expression; don't
1566 add anything to the shape array. */
1567 if (ref
->u
.ar
.dimen_type
[d
] != DIMEN_ELEMENT
)
1568 mpz_set (expr
->shape
[shape_i
++], tmp_mpz
);
1571 /* Calculate the 'stride' (=delta) for conversion of the
1572 counter values into the index along the constructor. */
1573 mpz_set (delta
[d
], delta_mpz
);
1574 mpz_sub (tmp_mpz
, upper
->value
.integer
, lower
->value
.integer
);
1575 mpz_add_ui (tmp_mpz
, tmp_mpz
, one
);
1576 mpz_mul (delta_mpz
, delta_mpz
, tmp_mpz
);
1580 cons
= gfc_constructor_first (base
);
1582 /* Now clock through the array reference, calculating the index in
1583 the source constructor and transferring the elements to the new
1585 for (idx
= 0; idx
< (int) mpz_get_si (nelts
); idx
++)
1587 mpz_init_set_ui (ptr
, 0);
1590 for (d
= 0; d
< rank
; d
++)
1592 mpz_set (tmp_mpz
, ctr
[d
]);
1593 mpz_sub (tmp_mpz
, tmp_mpz
, ref
->u
.ar
.as
->lower
[d
]->value
.integer
);
1594 mpz_mul (tmp_mpz
, tmp_mpz
, delta
[d
]);
1595 mpz_add (ptr
, ptr
, tmp_mpz
);
1597 if (!incr_ctr
) continue;
1599 if (ref
->u
.ar
.dimen_type
[d
] == DIMEN_VECTOR
) /* Vector subscript. */
1601 gcc_assert(vecsub
[d
]);
1603 if (!gfc_constructor_next (vecsub
[d
]))
1604 vecsub
[d
] = gfc_constructor_first (ref
->u
.ar
.start
[d
]->value
.constructor
);
1607 vecsub
[d
] = gfc_constructor_next (vecsub
[d
]);
1610 mpz_set (ctr
[d
], vecsub
[d
]->expr
->value
.integer
);
1614 mpz_add (ctr
[d
], ctr
[d
], stride
[d
]);
1616 if (mpz_cmp_ui (stride
[d
], 0) > 0
1617 ? mpz_cmp (ctr
[d
], end
[d
]) > 0
1618 : mpz_cmp (ctr
[d
], end
[d
]) < 0)
1619 mpz_set (ctr
[d
], start
[d
]);
1625 limit
= mpz_get_ui (ptr
);
1626 if (limit
>= flag_max_array_constructor
)
1628 gfc_error ("The number of elements in the array constructor "
1629 "at %L requires an increase of the allowed %d "
1630 "upper limit. See -fmax-array-constructor "
1631 "option", &expr
->where
, flag_max_array_constructor
);
1635 cons
= gfc_constructor_lookup (base
, limit
);
1637 gfc_constructor_append_expr (&expr
->value
.constructor
,
1638 gfc_copy_expr (cons
->expr
), NULL
);
1645 mpz_clear (delta_mpz
);
1646 mpz_clear (tmp_mpz
);
1648 for (d
= 0; d
< rank
; d
++)
1650 mpz_clear (delta
[d
]);
1651 mpz_clear (start
[d
]);
1654 mpz_clear (stride
[d
]);
1656 gfc_constructor_free (base
);
1660 /* Pull a substring out of an expression. */
1663 find_substring_ref (gfc_expr
*p
, gfc_expr
**newp
)
1670 if (p
->ref
->u
.ss
.start
->expr_type
!= EXPR_CONSTANT
1671 || p
->ref
->u
.ss
.end
->expr_type
!= EXPR_CONSTANT
)
1674 *newp
= gfc_copy_expr (p
);
1675 free ((*newp
)->value
.character
.string
);
1677 end
= (int) mpz_get_ui (p
->ref
->u
.ss
.end
->value
.integer
);
1678 start
= (int) mpz_get_ui (p
->ref
->u
.ss
.start
->value
.integer
);
1679 length
= end
- start
+ 1;
1681 chr
= (*newp
)->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1682 (*newp
)->value
.character
.length
= length
;
1683 memcpy (chr
, &p
->value
.character
.string
[start
- 1],
1684 length
* sizeof (gfc_char_t
));
1691 /* Simplify a subobject reference of a constructor. This occurs when
1692 parameter variable values are substituted. */
1695 simplify_const_ref (gfc_expr
*p
)
1697 gfc_constructor
*cons
, *c
;
1703 switch (p
->ref
->type
)
1706 switch (p
->ref
->u
.ar
.type
)
1709 /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1710 will generate this. */
1711 if (p
->expr_type
!= EXPR_ARRAY
)
1713 remove_subobject_ref (p
, NULL
);
1716 if (!find_array_element (p
->value
.constructor
, &p
->ref
->u
.ar
, &cons
))
1722 remove_subobject_ref (p
, cons
);
1726 if (!find_array_section (p
, p
->ref
))
1728 p
->ref
->u
.ar
.type
= AR_FULL
;
1733 if (p
->ref
->next
!= NULL
1734 && (p
->ts
.type
== BT_CHARACTER
|| gfc_bt_struct (p
->ts
.type
)))
1736 for (c
= gfc_constructor_first (p
->value
.constructor
);
1737 c
; c
= gfc_constructor_next (c
))
1739 c
->expr
->ref
= gfc_copy_ref (p
->ref
->next
);
1740 if (!simplify_const_ref (c
->expr
))
1744 if (gfc_bt_struct (p
->ts
.type
)
1746 && (c
= gfc_constructor_first (p
->value
.constructor
)))
1748 /* There may have been component references. */
1749 p
->ts
= c
->expr
->ts
;
1753 for (; last_ref
->next
; last_ref
= last_ref
->next
) {};
1755 if (p
->ts
.type
== BT_CHARACTER
1756 && last_ref
->type
== REF_SUBSTRING
)
1758 /* If this is a CHARACTER array and we possibly took
1759 a substring out of it, update the type-spec's
1760 character length according to the first element
1761 (as all should have the same length). */
1762 gfc_charlen_t string_len
;
1763 if ((c
= gfc_constructor_first (p
->value
.constructor
)))
1765 const gfc_expr
* first
= c
->expr
;
1766 gcc_assert (first
->expr_type
== EXPR_CONSTANT
);
1767 gcc_assert (first
->ts
.type
== BT_CHARACTER
);
1768 string_len
= first
->value
.character
.length
;
1774 p
->ts
.u
.cl
= gfc_new_charlen (p
->symtree
->n
.sym
->ns
,
1777 gfc_free_expr (p
->ts
.u
.cl
->length
);
1780 = gfc_get_int_expr (gfc_charlen_int_kind
,
1784 gfc_free_ref_list (p
->ref
);
1795 cons
= find_component_ref (p
->value
.constructor
, p
->ref
);
1796 remove_subobject_ref (p
, cons
);
1800 if (!find_substring_ref (p
, &newp
))
1803 gfc_replace_expr (p
, newp
);
1804 gfc_free_ref_list (p
->ref
);
1814 /* Simplify a chain of references. */
1817 simplify_ref_chain (gfc_ref
*ref
, int type
)
1821 for (; ref
; ref
= ref
->next
)
1826 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
1828 if (!gfc_simplify_expr (ref
->u
.ar
.start
[n
], type
))
1830 if (!gfc_simplify_expr (ref
->u
.ar
.end
[n
], type
))
1832 if (!gfc_simplify_expr (ref
->u
.ar
.stride
[n
], type
))
1838 if (!gfc_simplify_expr (ref
->u
.ss
.start
, type
))
1840 if (!gfc_simplify_expr (ref
->u
.ss
.end
, type
))
1852 /* Try to substitute the value of a parameter variable. */
1855 simplify_parameter_variable (gfc_expr
*p
, int type
)
1860 e
= gfc_copy_expr (p
->symtree
->n
.sym
->value
);
1866 /* Do not copy subobject refs for constant. */
1867 if (e
->expr_type
!= EXPR_CONSTANT
&& p
->ref
!= NULL
)
1868 e
->ref
= gfc_copy_ref (p
->ref
);
1869 t
= gfc_simplify_expr (e
, type
);
1871 /* Only use the simplification if it eliminated all subobject references. */
1873 gfc_replace_expr (p
, e
);
1880 /* Given an expression, simplify it by collapsing constant
1881 expressions. Most simplification takes place when the expression
1882 tree is being constructed. If an intrinsic function is simplified
1883 at some point, we get called again to collapse the result against
1886 We work by recursively simplifying expression nodes, simplifying
1887 intrinsic functions where possible, which can lead to further
1888 constant collapsing. If an operator has constant operand(s), we
1889 rip the expression apart, and rebuild it, hoping that it becomes
1892 The expression type is defined for:
1893 0 Basic expression parsing
1894 1 Simplifying array constructors -- will substitute
1896 Returns false on error, true otherwise.
1897 NOTE: Will return true even if the expression can not be simplified. */
1900 gfc_simplify_expr (gfc_expr
*p
, int type
)
1902 gfc_actual_arglist
*ap
;
1907 switch (p
->expr_type
)
1914 for (ap
= p
->value
.function
.actual
; ap
; ap
= ap
->next
)
1915 if (!gfc_simplify_expr (ap
->expr
, type
))
1918 if (p
->value
.function
.isym
!= NULL
1919 && gfc_intrinsic_func_interface (p
, 1) == MATCH_ERROR
)
1924 case EXPR_SUBSTRING
:
1925 if (!simplify_ref_chain (p
->ref
, type
))
1928 if (gfc_is_constant_expr (p
))
1931 HOST_WIDE_INT start
, end
;
1934 if (p
->ref
&& p
->ref
->u
.ss
.start
)
1936 gfc_extract_hwi (p
->ref
->u
.ss
.start
, &start
);
1937 start
--; /* Convert from one-based to zero-based. */
1940 end
= p
->value
.character
.length
;
1941 if (p
->ref
&& p
->ref
->u
.ss
.end
)
1942 gfc_extract_hwi (p
->ref
->u
.ss
.end
, &end
);
1947 s
= gfc_get_wide_string (end
- start
+ 2);
1948 memcpy (s
, p
->value
.character
.string
+ start
,
1949 (end
- start
) * sizeof (gfc_char_t
));
1950 s
[end
- start
+ 1] = '\0'; /* TODO: C-style string. */
1951 free (p
->value
.character
.string
);
1952 p
->value
.character
.string
= s
;
1953 p
->value
.character
.length
= end
- start
;
1954 p
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1955 p
->ts
.u
.cl
->length
= gfc_get_int_expr (gfc_charlen_int_kind
,
1957 p
->value
.character
.length
);
1958 gfc_free_ref_list (p
->ref
);
1960 p
->expr_type
= EXPR_CONSTANT
;
1965 if (!simplify_intrinsic_op (p
, type
))
1970 /* Only substitute array parameter variables if we are in an
1971 initialization expression, or we want a subsection. */
1972 if (p
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
1973 && (gfc_init_expr_flag
|| p
->ref
1974 || p
->symtree
->n
.sym
->value
->expr_type
!= EXPR_ARRAY
))
1976 if (!simplify_parameter_variable (p
, type
))
1983 gfc_simplify_iterator_var (p
);
1986 /* Simplify subcomponent references. */
1987 if (!simplify_ref_chain (p
->ref
, type
))
1992 case EXPR_STRUCTURE
:
1994 if (!simplify_ref_chain (p
->ref
, type
))
1997 if (!simplify_constructor (p
->value
.constructor
, type
))
2000 if (p
->expr_type
== EXPR_ARRAY
&& p
->ref
&& p
->ref
->type
== REF_ARRAY
2001 && p
->ref
->u
.ar
.type
== AR_FULL
)
2002 gfc_expand_constructor (p
, false);
2004 if (!simplify_const_ref (p
))
2018 /* Returns the type of an expression with the exception that iterator
2019 variables are automatically integers no matter what else they may
2025 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_check_iter_variable (e
))
2032 /* Scalarize an expression for an elemental intrinsic call. */
2035 scalarize_intrinsic_call (gfc_expr
*e
)
2037 gfc_actual_arglist
*a
, *b
;
2038 gfc_constructor_base ctor
;
2039 gfc_constructor
*args
[5] = {}; /* Avoid uninitialized warnings. */
2040 gfc_constructor
*ci
, *new_ctor
;
2041 gfc_expr
*expr
, *old
;
2042 int n
, i
, rank
[5], array_arg
;
2044 /* Find which, if any, arguments are arrays. Assume that the old
2045 expression carries the type information and that the first arg
2046 that is an array expression carries all the shape information.*/
2048 a
= e
->value
.function
.actual
;
2049 for (; a
; a
= a
->next
)
2052 if (!a
->expr
|| a
->expr
->expr_type
!= EXPR_ARRAY
)
2055 expr
= gfc_copy_expr (a
->expr
);
2062 old
= gfc_copy_expr (e
);
2064 gfc_constructor_free (expr
->value
.constructor
);
2065 expr
->value
.constructor
= NULL
;
2067 expr
->where
= old
->where
;
2068 expr
->expr_type
= EXPR_ARRAY
;
2070 /* Copy the array argument constructors into an array, with nulls
2073 a
= old
->value
.function
.actual
;
2074 for (; a
; a
= a
->next
)
2076 /* Check that this is OK for an initialization expression. */
2077 if (a
->expr
&& !gfc_check_init_expr (a
->expr
))
2081 if (a
->expr
&& a
->expr
->rank
&& a
->expr
->expr_type
== EXPR_VARIABLE
)
2083 rank
[n
] = a
->expr
->rank
;
2084 ctor
= a
->expr
->symtree
->n
.sym
->value
->value
.constructor
;
2085 args
[n
] = gfc_constructor_first (ctor
);
2087 else if (a
->expr
&& a
->expr
->expr_type
== EXPR_ARRAY
)
2090 rank
[n
] = a
->expr
->rank
;
2093 ctor
= gfc_constructor_copy (a
->expr
->value
.constructor
);
2094 args
[n
] = gfc_constructor_first (ctor
);
2103 /* Using the array argument as the master, step through the array
2104 calling the function for each element and advancing the array
2105 constructors together. */
2106 for (ci
= args
[array_arg
- 1]; ci
; ci
= gfc_constructor_next (ci
))
2108 new_ctor
= gfc_constructor_append_expr (&expr
->value
.constructor
,
2109 gfc_copy_expr (old
), NULL
);
2111 gfc_free_actual_arglist (new_ctor
->expr
->value
.function
.actual
);
2113 b
= old
->value
.function
.actual
;
2114 for (i
= 0; i
< n
; i
++)
2117 new_ctor
->expr
->value
.function
.actual
2118 = a
= gfc_get_actual_arglist ();
2121 a
->next
= gfc_get_actual_arglist ();
2126 a
->expr
= gfc_copy_expr (args
[i
]->expr
);
2128 a
->expr
= gfc_copy_expr (b
->expr
);
2133 /* Simplify the function calls. If the simplification fails, the
2134 error will be flagged up down-stream or the library will deal
2136 gfc_simplify_expr (new_ctor
->expr
, 0);
2138 for (i
= 0; i
< n
; i
++)
2140 args
[i
] = gfc_constructor_next (args
[i
]);
2142 for (i
= 1; i
< n
; i
++)
2143 if (rank
[i
] && ((args
[i
] != NULL
&& args
[array_arg
- 1] == NULL
)
2144 || (args
[i
] == NULL
&& args
[array_arg
- 1] != NULL
)))
2150 /* Free "expr" but not the pointers it contains. */
2152 gfc_free_expr (old
);
2156 gfc_error_now ("elemental function arguments at %C are not compliant");
2159 gfc_free_expr (expr
);
2160 gfc_free_expr (old
);
2166 check_intrinsic_op (gfc_expr
*e
, bool (*check_function
) (gfc_expr
*))
2168 gfc_expr
*op1
= e
->value
.op
.op1
;
2169 gfc_expr
*op2
= e
->value
.op
.op2
;
2171 if (!(*check_function
)(op1
))
2174 switch (e
->value
.op
.op
)
2176 case INTRINSIC_UPLUS
:
2177 case INTRINSIC_UMINUS
:
2178 if (!numeric_type (et0 (op1
)))
2183 case INTRINSIC_EQ_OS
:
2185 case INTRINSIC_NE_OS
:
2187 case INTRINSIC_GT_OS
:
2189 case INTRINSIC_GE_OS
:
2191 case INTRINSIC_LT_OS
:
2193 case INTRINSIC_LE_OS
:
2194 if (!(*check_function
)(op2
))
2197 if (!(et0 (op1
) == BT_CHARACTER
&& et0 (op2
) == BT_CHARACTER
)
2198 && !(numeric_type (et0 (op1
)) && numeric_type (et0 (op2
))))
2200 gfc_error ("Numeric or CHARACTER operands are required in "
2201 "expression at %L", &e
->where
);
2206 case INTRINSIC_PLUS
:
2207 case INTRINSIC_MINUS
:
2208 case INTRINSIC_TIMES
:
2209 case INTRINSIC_DIVIDE
:
2210 case INTRINSIC_POWER
:
2211 if (!(*check_function
)(op2
))
2214 if (!numeric_type (et0 (op1
)) || !numeric_type (et0 (op2
)))
2219 case INTRINSIC_CONCAT
:
2220 if (!(*check_function
)(op2
))
2223 if (et0 (op1
) != BT_CHARACTER
|| et0 (op2
) != BT_CHARACTER
)
2225 gfc_error ("Concatenation operator in expression at %L "
2226 "must have two CHARACTER operands", &op1
->where
);
2230 if (op1
->ts
.kind
!= op2
->ts
.kind
)
2232 gfc_error ("Concat operator at %L must concatenate strings of the "
2233 "same kind", &e
->where
);
2240 if (et0 (op1
) != BT_LOGICAL
)
2242 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2243 "operand", &op1
->where
);
2252 case INTRINSIC_NEQV
:
2253 if (!(*check_function
)(op2
))
2256 if (et0 (op1
) != BT_LOGICAL
|| et0 (op2
) != BT_LOGICAL
)
2258 gfc_error ("LOGICAL operands are required in expression at %L",
2265 case INTRINSIC_PARENTHESES
:
2269 gfc_error ("Only intrinsic operators can be used in expression at %L",
2277 gfc_error ("Numeric operands are required in expression at %L", &e
->where
);
2282 /* F2003, 7.1.7 (3): In init expression, allocatable components
2283 must not be data-initialized. */
2285 check_alloc_comp_init (gfc_expr
*e
)
2287 gfc_component
*comp
;
2288 gfc_constructor
*ctor
;
2290 gcc_assert (e
->expr_type
== EXPR_STRUCTURE
);
2291 gcc_assert (e
->ts
.type
== BT_DERIVED
|| e
->ts
.type
== BT_CLASS
);
2293 for (comp
= e
->ts
.u
.derived
->components
,
2294 ctor
= gfc_constructor_first (e
->value
.constructor
);
2295 comp
; comp
= comp
->next
, ctor
= gfc_constructor_next (ctor
))
2297 if (comp
->attr
.allocatable
&& ctor
->expr
2298 && ctor
->expr
->expr_type
!= EXPR_NULL
)
2300 gfc_error ("Invalid initialization expression for ALLOCATABLE "
2301 "component %qs in structure constructor at %L",
2302 comp
->name
, &ctor
->expr
->where
);
2311 check_init_expr_arguments (gfc_expr
*e
)
2313 gfc_actual_arglist
*ap
;
2315 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2316 if (!gfc_check_init_expr (ap
->expr
))
2322 static bool check_restricted (gfc_expr
*);
2324 /* F95, 7.1.6.1, Initialization expressions, (7)
2325 F2003, 7.1.7 Initialization expression, (8) */
2328 check_inquiry (gfc_expr
*e
, int not_restricted
)
2331 const char *const *functions
;
2333 static const char *const inquiry_func_f95
[] = {
2334 "lbound", "shape", "size", "ubound",
2335 "bit_size", "len", "kind",
2336 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2337 "precision", "radix", "range", "tiny",
2341 static const char *const inquiry_func_f2003
[] = {
2342 "lbound", "shape", "size", "ubound",
2343 "bit_size", "len", "kind",
2344 "digits", "epsilon", "huge", "maxexponent", "minexponent",
2345 "precision", "radix", "range", "tiny",
2350 gfc_actual_arglist
*ap
;
2352 if (!e
->value
.function
.isym
2353 || !e
->value
.function
.isym
->inquiry
)
2356 /* An undeclared parameter will get us here (PR25018). */
2357 if (e
->symtree
== NULL
)
2360 if (e
->symtree
->n
.sym
->from_intmod
)
2362 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2363 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_OPTIONS
2364 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOFORTRAN_COMPILER_VERSION
)
2367 if (e
->symtree
->n
.sym
->from_intmod
== INTMOD_ISO_C_BINDING
2368 && e
->symtree
->n
.sym
->intmod_sym_id
!= ISOCBINDING_C_SIZEOF
)
2373 name
= e
->symtree
->n
.sym
->name
;
2375 functions
= (gfc_option
.warn_std
& GFC_STD_F2003
)
2376 ? inquiry_func_f2003
: inquiry_func_f95
;
2378 for (i
= 0; functions
[i
]; i
++)
2379 if (strcmp (functions
[i
], name
) == 0)
2382 if (functions
[i
] == NULL
)
2386 /* At this point we have an inquiry function with a variable argument. The
2387 type of the variable might be undefined, but we need it now, because the
2388 arguments of these functions are not allowed to be undefined. */
2390 for (ap
= e
->value
.function
.actual
; ap
; ap
= ap
->next
)
2395 if (ap
->expr
->ts
.type
== BT_UNKNOWN
)
2397 if (ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
2398 && !gfc_set_default_type (ap
->expr
->symtree
->n
.sym
, 0, gfc_current_ns
))
2401 ap
->expr
->ts
= ap
->expr
->symtree
->n
.sym
->ts
;
2404 /* Assumed character length will not reduce to a constant expression
2405 with LEN, as required by the standard. */
2406 if (i
== 5 && not_restricted
2407 && ap
->expr
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
2408 && (ap
->expr
->symtree
->n
.sym
->ts
.u
.cl
->length
== NULL
2409 || ap
->expr
->symtree
->n
.sym
->ts
.deferred
))
2411 gfc_error ("Assumed or deferred character length variable %qs "
2412 "in constant expression at %L",
2413 ap
->expr
->symtree
->n
.sym
->name
,
2417 else if (not_restricted
&& !gfc_check_init_expr (ap
->expr
))
2420 if (not_restricted
== 0
2421 && ap
->expr
->expr_type
!= EXPR_VARIABLE
2422 && !check_restricted (ap
->expr
))
2425 if (not_restricted
== 0
2426 && ap
->expr
->expr_type
== EXPR_VARIABLE
2427 && ap
->expr
->symtree
->n
.sym
->attr
.dummy
2428 && ap
->expr
->symtree
->n
.sym
->attr
.optional
)
2436 /* F95, 7.1.6.1, Initialization expressions, (5)
2437 F2003, 7.1.7 Initialization expression, (5) */
2440 check_transformational (gfc_expr
*e
)
2442 static const char * const trans_func_f95
[] = {
2443 "repeat", "reshape", "selected_int_kind",
2444 "selected_real_kind", "transfer", "trim", NULL
2447 static const char * const trans_func_f2003
[] = {
2448 "all", "any", "count", "dot_product", "matmul", "null", "pack",
2449 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2450 "selected_real_kind", "spread", "sum", "transfer", "transpose",
2451 "trim", "unpack", NULL
2456 const char *const *functions
;
2458 if (!e
->value
.function
.isym
2459 || !e
->value
.function
.isym
->transformational
)
2462 name
= e
->symtree
->n
.sym
->name
;
2464 functions
= (gfc_option
.allow_std
& GFC_STD_F2003
)
2465 ? trans_func_f2003
: trans_func_f95
;
2467 /* NULL() is dealt with below. */
2468 if (strcmp ("null", name
) == 0)
2471 for (i
= 0; functions
[i
]; i
++)
2472 if (strcmp (functions
[i
], name
) == 0)
2475 if (functions
[i
] == NULL
)
2477 gfc_error ("transformational intrinsic %qs at %L is not permitted "
2478 "in an initialization expression", name
, &e
->where
);
2482 return check_init_expr_arguments (e
);
2486 /* F95, 7.1.6.1, Initialization expressions, (6)
2487 F2003, 7.1.7 Initialization expression, (6) */
2490 check_null (gfc_expr
*e
)
2492 if (strcmp ("null", e
->symtree
->n
.sym
->name
) != 0)
2495 return check_init_expr_arguments (e
);
2500 check_elemental (gfc_expr
*e
)
2502 if (!e
->value
.function
.isym
2503 || !e
->value
.function
.isym
->elemental
)
2506 if (e
->ts
.type
!= BT_INTEGER
2507 && e
->ts
.type
!= BT_CHARACTER
2508 && !gfc_notify_std (GFC_STD_F2003
, "Evaluation of nonstandard "
2509 "initialization expression at %L", &e
->where
))
2512 return check_init_expr_arguments (e
);
2517 check_conversion (gfc_expr
*e
)
2519 if (!e
->value
.function
.isym
2520 || !e
->value
.function
.isym
->conversion
)
2523 return check_init_expr_arguments (e
);
2527 /* Verify that an expression is an initialization expression. A side
2528 effect is that the expression tree is reduced to a single constant
2529 node if all goes well. This would normally happen when the
2530 expression is constructed but function references are assumed to be
2531 intrinsics in the context of initialization expressions. If
2532 false is returned an error message has been generated. */
2535 gfc_check_init_expr (gfc_expr
*e
)
2543 switch (e
->expr_type
)
2546 t
= check_intrinsic_op (e
, gfc_check_init_expr
);
2548 t
= gfc_simplify_expr (e
, 0);
2557 gfc_intrinsic_sym
* isym
= NULL
;
2558 gfc_symbol
* sym
= e
->symtree
->n
.sym
;
2560 /* Simplify here the intrinsics from the IEEE_ARITHMETIC and
2561 IEEE_EXCEPTIONS modules. */
2562 int mod
= sym
->from_intmod
;
2563 if (mod
== INTMOD_NONE
&& sym
->generic
)
2564 mod
= sym
->generic
->sym
->from_intmod
;
2565 if (mod
== INTMOD_IEEE_ARITHMETIC
|| mod
== INTMOD_IEEE_EXCEPTIONS
)
2567 gfc_expr
*new_expr
= gfc_simplify_ieee_functions (e
);
2570 gfc_replace_expr (e
, new_expr
);
2576 /* If a conversion function, e.g., __convert_i8_i4, was inserted
2577 into an array constructor, we need to skip the error check here.
2578 Conversion errors are caught below in scalarize_intrinsic_call. */
2579 conversion
= e
->value
.function
.isym
2580 && (e
->value
.function
.isym
->conversion
== 1);
2582 if (!conversion
&& (!gfc_is_intrinsic (sym
, 0, e
->where
)
2583 || (m
= gfc_intrinsic_func_interface (e
, 0)) != MATCH_YES
))
2585 gfc_error ("Function %qs in initialization expression at %L "
2586 "must be an intrinsic function",
2587 e
->symtree
->n
.sym
->name
, &e
->where
);
2591 if ((m
= check_conversion (e
)) == MATCH_NO
2592 && (m
= check_inquiry (e
, 1)) == MATCH_NO
2593 && (m
= check_null (e
)) == MATCH_NO
2594 && (m
= check_transformational (e
)) == MATCH_NO
2595 && (m
= check_elemental (e
)) == MATCH_NO
)
2597 gfc_error ("Intrinsic function %qs at %L is not permitted "
2598 "in an initialization expression",
2599 e
->symtree
->n
.sym
->name
, &e
->where
);
2603 if (m
== MATCH_ERROR
)
2606 /* Try to scalarize an elemental intrinsic function that has an
2608 isym
= gfc_find_function (e
->symtree
->n
.sym
->name
);
2609 if (isym
&& isym
->elemental
2610 && (t
= scalarize_intrinsic_call (e
)))
2615 t
= gfc_simplify_expr (e
, 0);
2622 /* This occurs when parsing pdt templates. */
2623 if (gfc_expr_attr (e
).pdt_kind
)
2626 if (gfc_check_iter_variable (e
))
2629 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
2631 /* A PARAMETER shall not be used to define itself, i.e.
2632 REAL, PARAMETER :: x = transfer(0, x)
2634 if (!e
->symtree
->n
.sym
->value
)
2636 gfc_error ("PARAMETER %qs is used at %L before its definition "
2637 "is complete", e
->symtree
->n
.sym
->name
, &e
->where
);
2641 t
= simplify_parameter_variable (e
, 0);
2646 if (gfc_in_match_data ())
2651 if (e
->symtree
->n
.sym
->as
)
2653 switch (e
->symtree
->n
.sym
->as
->type
)
2655 case AS_ASSUMED_SIZE
:
2656 gfc_error ("Assumed size array %qs at %L is not permitted "
2657 "in an initialization expression",
2658 e
->symtree
->n
.sym
->name
, &e
->where
);
2661 case AS_ASSUMED_SHAPE
:
2662 gfc_error ("Assumed shape array %qs at %L is not permitted "
2663 "in an initialization expression",
2664 e
->symtree
->n
.sym
->name
, &e
->where
);
2668 gfc_error ("Deferred array %qs at %L is not permitted "
2669 "in an initialization expression",
2670 e
->symtree
->n
.sym
->name
, &e
->where
);
2674 gfc_error ("Array %qs at %L is a variable, which does "
2675 "not reduce to a constant expression",
2676 e
->symtree
->n
.sym
->name
, &e
->where
);
2684 gfc_error ("Parameter %qs at %L has not been declared or is "
2685 "a variable, which does not reduce to a constant "
2686 "expression", e
->symtree
->name
, &e
->where
);
2695 case EXPR_SUBSTRING
:
2698 t
= gfc_check_init_expr (e
->ref
->u
.ss
.start
);
2702 t
= gfc_check_init_expr (e
->ref
->u
.ss
.end
);
2704 t
= gfc_simplify_expr (e
, 0);
2710 case EXPR_STRUCTURE
:
2711 t
= e
->ts
.is_iso_c
? true : false;
2715 t
= check_alloc_comp_init (e
);
2719 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2726 t
= gfc_check_constructor (e
, gfc_check_init_expr
);
2730 t
= gfc_expand_constructor (e
, true);
2734 t
= gfc_check_constructor_type (e
);
2738 gfc_internal_error ("check_init_expr(): Unknown expression type");
2744 /* Reduces a general expression to an initialization expression (a constant).
2745 This used to be part of gfc_match_init_expr.
2746 Note that this function doesn't free the given expression on false. */
2749 gfc_reduce_init_expr (gfc_expr
*expr
)
2753 gfc_init_expr_flag
= true;
2754 t
= gfc_resolve_expr (expr
);
2756 t
= gfc_check_init_expr (expr
);
2757 gfc_init_expr_flag
= false;
2762 if (expr
->expr_type
== EXPR_ARRAY
)
2764 if (!gfc_check_constructor_type (expr
))
2766 if (!gfc_expand_constructor (expr
, true))
2774 /* Match an initialization expression. We work by first matching an
2775 expression, then reducing it to a constant. */
2778 gfc_match_init_expr (gfc_expr
**result
)
2786 gfc_init_expr_flag
= true;
2788 m
= gfc_match_expr (&expr
);
2791 gfc_init_expr_flag
= false;
2795 if (gfc_derived_parameter_expr (expr
))
2798 gfc_init_expr_flag
= false;
2802 t
= gfc_reduce_init_expr (expr
);
2805 gfc_free_expr (expr
);
2806 gfc_init_expr_flag
= false;
2811 gfc_init_expr_flag
= false;
2817 /* Given an actual argument list, test to see that each argument is a
2818 restricted expression and optionally if the expression type is
2819 integer or character. */
2822 restricted_args (gfc_actual_arglist
*a
)
2824 for (; a
; a
= a
->next
)
2826 if (!check_restricted (a
->expr
))
2834 /************* Restricted/specification expressions *************/
2837 /* Make sure a non-intrinsic function is a specification function,
2838 * see F08:7.1.11.5. */
2841 external_spec_function (gfc_expr
*e
)
2845 f
= e
->value
.function
.esym
;
2847 /* IEEE functions allowed are "a reference to a transformational function
2848 from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and
2849 "inquiry function from the intrinsic modules IEEE_ARITHMETIC and
2850 IEEE_EXCEPTIONS". */
2851 if (f
->from_intmod
== INTMOD_IEEE_ARITHMETIC
2852 || f
->from_intmod
== INTMOD_IEEE_EXCEPTIONS
)
2854 if (!strcmp (f
->name
, "ieee_selected_real_kind")
2855 || !strcmp (f
->name
, "ieee_support_rounding")
2856 || !strcmp (f
->name
, "ieee_support_flag")
2857 || !strcmp (f
->name
, "ieee_support_halting")
2858 || !strcmp (f
->name
, "ieee_support_datatype")
2859 || !strcmp (f
->name
, "ieee_support_denormal")
2860 || !strcmp (f
->name
, "ieee_support_divide")
2861 || !strcmp (f
->name
, "ieee_support_inf")
2862 || !strcmp (f
->name
, "ieee_support_io")
2863 || !strcmp (f
->name
, "ieee_support_nan")
2864 || !strcmp (f
->name
, "ieee_support_sqrt")
2865 || !strcmp (f
->name
, "ieee_support_standard")
2866 || !strcmp (f
->name
, "ieee_support_underflow_control"))
2867 goto function_allowed
;
2870 if (f
->attr
.proc
== PROC_ST_FUNCTION
)
2872 gfc_error ("Specification function %qs at %L cannot be a statement "
2873 "function", f
->name
, &e
->where
);
2877 if (f
->attr
.proc
== PROC_INTERNAL
)
2879 gfc_error ("Specification function %qs at %L cannot be an internal "
2880 "function", f
->name
, &e
->where
);
2884 if (!f
->attr
.pure
&& !f
->attr
.elemental
)
2886 gfc_error ("Specification function %qs at %L must be PURE", f
->name
,
2892 if (f
->attr
.recursive
2893 && !gfc_notify_std (GFC_STD_F2003
,
2894 "Specification function %qs "
2895 "at %L cannot be RECURSIVE", f
->name
, &e
->where
))
2899 return restricted_args (e
->value
.function
.actual
);
2903 /* Check to see that a function reference to an intrinsic is a
2904 restricted expression. */
2907 restricted_intrinsic (gfc_expr
*e
)
2909 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
2910 if (check_inquiry (e
, 0) == MATCH_YES
)
2913 return restricted_args (e
->value
.function
.actual
);
2917 /* Check the expressions of an actual arglist. Used by check_restricted. */
2920 check_arglist (gfc_actual_arglist
* arg
, bool (*checker
) (gfc_expr
*))
2922 for (; arg
; arg
= arg
->next
)
2923 if (!checker (arg
->expr
))
2930 /* Check the subscription expressions of a reference chain with a checking
2931 function; used by check_restricted. */
2934 check_references (gfc_ref
* ref
, bool (*checker
) (gfc_expr
*))
2944 for (dim
= 0; dim
!= ref
->u
.ar
.dimen
; ++dim
)
2946 if (!checker (ref
->u
.ar
.start
[dim
]))
2948 if (!checker (ref
->u
.ar
.end
[dim
]))
2950 if (!checker (ref
->u
.ar
.stride
[dim
]))
2956 /* Nothing needed, just proceed to next reference. */
2960 if (!checker (ref
->u
.ss
.start
))
2962 if (!checker (ref
->u
.ss
.end
))
2971 return check_references (ref
->next
, checker
);
2974 /* Return true if ns is a parent of the current ns. */
2977 is_parent_of_current_ns (gfc_namespace
*ns
)
2980 for (p
= gfc_current_ns
->parent
; p
; p
= p
->parent
)
2987 /* Verify that an expression is a restricted expression. Like its
2988 cousin check_init_expr(), an error message is generated if we
2992 check_restricted (gfc_expr
*e
)
3000 switch (e
->expr_type
)
3003 t
= check_intrinsic_op (e
, check_restricted
);
3005 t
= gfc_simplify_expr (e
, 0);
3010 if (e
->value
.function
.esym
)
3012 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3014 t
= external_spec_function (e
);
3018 if (e
->value
.function
.isym
&& e
->value
.function
.isym
->inquiry
)
3021 t
= check_arglist (e
->value
.function
.actual
, &check_restricted
);
3024 t
= restricted_intrinsic (e
);
3029 sym
= e
->symtree
->n
.sym
;
3032 /* If a dummy argument appears in a context that is valid for a
3033 restricted expression in an elemental procedure, it will have
3034 already been simplified away once we get here. Therefore we
3035 don't need to jump through hoops to distinguish valid from
3037 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
3038 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.elemental
)
3040 gfc_error ("Dummy argument %qs not allowed in expression at %L",
3041 sym
->name
, &e
->where
);
3045 if (sym
->attr
.optional
)
3047 gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL",
3048 sym
->name
, &e
->where
);
3052 if (sym
->attr
.intent
== INTENT_OUT
)
3054 gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)",
3055 sym
->name
, &e
->where
);
3059 /* Check reference chain if any. */
3060 if (!check_references (e
->ref
, &check_restricted
))
3063 /* gfc_is_formal_arg broadcasts that a formal argument list is being
3064 processed in resolve.c(resolve_formal_arglist). This is done so
3065 that host associated dummy array indices are accepted (PR23446).
3066 This mechanism also does the same for the specification expressions
3067 of array-valued functions. */
3069 || sym
->attr
.in_common
3070 || sym
->attr
.use_assoc
3072 || sym
->attr
.implied_index
3073 || sym
->attr
.flavor
== FL_PARAMETER
3074 || is_parent_of_current_ns (sym
->ns
)
3075 || (sym
->ns
->proc_name
!= NULL
3076 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3077 || (gfc_is_formal_arg () && (sym
->ns
== gfc_current_ns
)))
3083 gfc_error ("Variable %qs cannot appear in the expression at %L",
3084 sym
->name
, &e
->where
);
3085 /* Prevent a repetition of the error. */
3094 case EXPR_SUBSTRING
:
3095 t
= gfc_specification_expr (e
->ref
->u
.ss
.start
);
3099 t
= gfc_specification_expr (e
->ref
->u
.ss
.end
);
3101 t
= gfc_simplify_expr (e
, 0);
3105 case EXPR_STRUCTURE
:
3106 t
= gfc_check_constructor (e
, check_restricted
);
3110 t
= gfc_check_constructor (e
, check_restricted
);
3114 gfc_internal_error ("check_restricted(): Unknown expression type");
3121 /* Check to see that an expression is a specification expression. If
3122 we return false, an error has been generated. */
3125 gfc_specification_expr (gfc_expr
*e
)
3127 gfc_component
*comp
;
3132 if (e
->ts
.type
!= BT_INTEGER
)
3134 gfc_error ("Expression at %L must be of INTEGER type, found %s",
3135 &e
->where
, gfc_basic_typename (e
->ts
.type
));
3139 comp
= gfc_get_proc_ptr_comp (e
);
3140 if (e
->expr_type
== EXPR_FUNCTION
3141 && !e
->value
.function
.isym
3142 && !e
->value
.function
.esym
3143 && !gfc_pure (e
->symtree
->n
.sym
)
3144 && (!comp
|| !comp
->attr
.pure
))
3146 gfc_error ("Function %qs at %L must be PURE",
3147 e
->symtree
->n
.sym
->name
, &e
->where
);
3148 /* Prevent repeat error messages. */
3149 e
->symtree
->n
.sym
->attr
.pure
= 1;
3155 gfc_error ("Expression at %L must be scalar", &e
->where
);
3159 if (!gfc_simplify_expr (e
, 0))
3162 return check_restricted (e
);
3166 /************** Expression conformance checks. *************/
3168 /* Given two expressions, make sure that the arrays are conformable. */
3171 gfc_check_conformance (gfc_expr
*op1
, gfc_expr
*op2
, const char *optype_msgid
, ...)
3173 int op1_flag
, op2_flag
, d
;
3174 mpz_t op1_size
, op2_size
;
3180 if (op1
->rank
== 0 || op2
->rank
== 0)
3183 va_start (argp
, optype_msgid
);
3184 vsnprintf (buffer
, 240, optype_msgid
, argp
);
3187 if (op1
->rank
!= op2
->rank
)
3189 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer
),
3190 op1
->rank
, op2
->rank
, &op1
->where
);
3196 for (d
= 0; d
< op1
->rank
; d
++)
3198 op1_flag
= gfc_array_dimen_size(op1
, d
, &op1_size
);
3199 op2_flag
= gfc_array_dimen_size(op2
, d
, &op2_size
);
3201 if (op1_flag
&& op2_flag
&& mpz_cmp (op1_size
, op2_size
) != 0)
3203 gfc_error ("Different shape for %s at %L on dimension %d "
3204 "(%d and %d)", _(buffer
), &op1
->where
, d
+ 1,
3205 (int) mpz_get_si (op1_size
),
3206 (int) mpz_get_si (op2_size
));
3212 mpz_clear (op1_size
);
3214 mpz_clear (op2_size
);
3224 /* Given an assignable expression and an arbitrary expression, make
3225 sure that the assignment can take place. Only add a call to the intrinsic
3226 conversion routines, when allow_convert is set. When this assign is a
3227 coarray call, then the convert is done by the coarray routine implictly and
3228 adding the intrinsic conversion would do harm in most cases. */
3231 gfc_check_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
, int conform
,
3238 sym
= lvalue
->symtree
->n
.sym
;
3240 /* See if this is the component or subcomponent of a pointer. */
3241 has_pointer
= sym
->attr
.pointer
;
3242 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3243 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
3249 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3250 variable local to a function subprogram. Its existence begins when
3251 execution of the function is initiated and ends when execution of the
3252 function is terminated...
3253 Therefore, the left hand side is no longer a variable, when it is: */
3254 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
3255 && !sym
->attr
.external
)
3260 /* (i) Use associated; */
3261 if (sym
->attr
.use_assoc
)
3264 /* (ii) The assignment is in the main program; or */
3265 if (gfc_current_ns
->proc_name
3266 && gfc_current_ns
->proc_name
->attr
.is_main_program
)
3269 /* (iii) A module or internal procedure... */
3270 if (gfc_current_ns
->proc_name
3271 && (gfc_current_ns
->proc_name
->attr
.proc
== PROC_INTERNAL
3272 || gfc_current_ns
->proc_name
->attr
.proc
== PROC_MODULE
)
3273 && gfc_current_ns
->parent
3274 && (!(gfc_current_ns
->parent
->proc_name
->attr
.function
3275 || gfc_current_ns
->parent
->proc_name
->attr
.subroutine
)
3276 || gfc_current_ns
->parent
->proc_name
->attr
.is_main_program
))
3278 /* ... that is not a function... */
3279 if (gfc_current_ns
->proc_name
3280 && !gfc_current_ns
->proc_name
->attr
.function
)
3283 /* ... or is not an entry and has a different name. */
3284 if (!sym
->attr
.entry
&& sym
->name
!= gfc_current_ns
->proc_name
->name
)
3288 /* (iv) Host associated and not the function symbol or the
3289 parent result. This picks up sibling references, which
3290 cannot be entries. */
3291 if (!sym
->attr
.entry
3292 && sym
->ns
== gfc_current_ns
->parent
3293 && sym
!= gfc_current_ns
->proc_name
3294 && sym
!= gfc_current_ns
->parent
->proc_name
->result
)
3299 gfc_error ("%qs at %L is not a VALUE", sym
->name
, &lvalue
->where
);
3304 if (rvalue
->rank
!= 0 && lvalue
->rank
!= rvalue
->rank
)
3306 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3307 lvalue
->rank
, rvalue
->rank
, &lvalue
->where
);
3311 if (lvalue
->ts
.type
== BT_UNKNOWN
)
3313 gfc_error ("Variable type is UNKNOWN in assignment at %L",
3318 if (rvalue
->expr_type
== EXPR_NULL
)
3320 if (has_pointer
&& (ref
== NULL
|| ref
->next
== NULL
)
3321 && lvalue
->symtree
->n
.sym
->attr
.data
)
3325 gfc_error ("NULL appears on right-hand side in assignment at %L",
3331 /* This is possibly a typo: x = f() instead of x => f(). */
3333 && rvalue
->expr_type
== EXPR_FUNCTION
&& gfc_expr_attr (rvalue
).pointer
)
3334 gfc_warning (OPT_Wsurprising
,
3335 "POINTER-valued function appears on right-hand side of "
3336 "assignment at %L", &rvalue
->where
);
3338 /* Check size of array assignments. */
3339 if (lvalue
->rank
!= 0 && rvalue
->rank
!= 0
3340 && !gfc_check_conformance (lvalue
, rvalue
, "array assignment"))
3343 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
3344 && lvalue
->symtree
->n
.sym
->attr
.data
3345 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L used to "
3346 "initialize non-integer variable %qs",
3347 &rvalue
->where
, lvalue
->symtree
->n
.sym
->name
))
3349 else if (rvalue
->is_boz
&& !lvalue
->symtree
->n
.sym
->attr
.data
3350 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
3351 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3355 /* Handle the case of a BOZ literal on the RHS. */
3356 if (rvalue
->is_boz
&& lvalue
->ts
.type
!= BT_INTEGER
)
3359 if (warn_surprising
)
3360 gfc_warning (OPT_Wsurprising
,
3361 "BOZ literal at %L is bitwise transferred "
3362 "non-integer symbol %qs", &rvalue
->where
,
3363 lvalue
->symtree
->n
.sym
->name
);
3364 if (!gfc_convert_boz (rvalue
, &lvalue
->ts
))
3366 if ((rc
= gfc_range_check (rvalue
)) != ARITH_OK
)
3368 if (rc
== ARITH_UNDERFLOW
)
3369 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3370 ". This check can be disabled with the option "
3371 "%<-fno-range-check%>", &rvalue
->where
);
3372 else if (rc
== ARITH_OVERFLOW
)
3373 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3374 ". This check can be disabled with the option "
3375 "%<-fno-range-check%>", &rvalue
->where
);
3376 else if (rc
== ARITH_NAN
)
3377 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3378 ". This check can be disabled with the option "
3379 "%<-fno-range-check%>", &rvalue
->where
);
3384 if (gfc_expr_attr (lvalue
).pdt_kind
|| gfc_expr_attr (lvalue
).pdt_len
)
3386 gfc_error ("The assignment to a KIND or LEN component of a "
3387 "parameterized type at %L is not allowed",
3392 if (gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3395 /* Only DATA Statements come here. */
3398 /* Numeric can be converted to any other numeric. And Hollerith can be
3399 converted to any other type. */
3400 if ((gfc_numeric_ts (&lvalue
->ts
) && gfc_numeric_ts (&rvalue
->ts
))
3401 || rvalue
->ts
.type
== BT_HOLLERITH
)
3404 if (lvalue
->ts
.type
== BT_LOGICAL
&& rvalue
->ts
.type
== BT_LOGICAL
)
3407 gfc_error ("Incompatible types in DATA statement at %L; attempted "
3408 "conversion of %s to %s", &lvalue
->where
,
3409 gfc_typename (&rvalue
->ts
), gfc_typename (&lvalue
->ts
));
3414 /* Assignment is the only case where character variables of different
3415 kind values can be converted into one another. */
3416 if (lvalue
->ts
.type
== BT_CHARACTER
&& rvalue
->ts
.type
== BT_CHARACTER
)
3418 if (lvalue
->ts
.kind
!= rvalue
->ts
.kind
&& allow_convert
)
3419 return gfc_convert_chartype (rvalue
, &lvalue
->ts
);
3427 return gfc_convert_type (rvalue
, &lvalue
->ts
, 1);
3431 /* Check that a pointer assignment is OK. We first check lvalue, and
3432 we only check rvalue if it's not an assignment to NULL() or a
3433 NULLIFY statement. */
3436 gfc_check_pointer_assign (gfc_expr
*lvalue
, gfc_expr
*rvalue
)
3438 symbol_attribute attr
, lhs_attr
;
3440 bool is_pure
, is_implicit_pure
, rank_remap
;
3443 lhs_attr
= gfc_expr_attr (lvalue
);
3444 if (lvalue
->ts
.type
== BT_UNKNOWN
&& !lhs_attr
.proc_pointer
)
3446 gfc_error ("Pointer assignment target is not a POINTER at %L",
3451 if (lhs_attr
.flavor
== FL_PROCEDURE
&& lhs_attr
.use_assoc
3452 && !lhs_attr
.proc_pointer
)
3454 gfc_error ("%qs in the pointer assignment at %L cannot be an "
3455 "l-value since it is a procedure",
3456 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3460 proc_pointer
= lvalue
->symtree
->n
.sym
->attr
.proc_pointer
;
3463 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3465 if (ref
->type
== REF_COMPONENT
)
3466 proc_pointer
= ref
->u
.c
.component
->attr
.proc_pointer
;
3468 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
3472 if (ref
->u
.ar
.type
== AR_FULL
)
3475 if (ref
->u
.ar
.type
!= AR_SECTION
)
3477 gfc_error ("Expected bounds specification for %qs at %L",
3478 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
);
3482 if (!gfc_notify_std (GFC_STD_F2003
, "Bounds specification "
3483 "for %qs in pointer assignment at %L",
3484 lvalue
->symtree
->n
.sym
->name
, &lvalue
->where
))
3487 /* When bounds are given, all lbounds are necessary and either all
3488 or none of the upper bounds; no strides are allowed. If the
3489 upper bounds are present, we may do rank remapping. */
3490 for (dim
= 0; dim
< ref
->u
.ar
.dimen
; ++dim
)
3492 if (!ref
->u
.ar
.start
[dim
]
3493 || ref
->u
.ar
.dimen_type
[dim
] != DIMEN_RANGE
)
3495 gfc_error ("Lower bound has to be present at %L",
3499 if (ref
->u
.ar
.stride
[dim
])
3501 gfc_error ("Stride must not be present at %L",
3507 rank_remap
= (ref
->u
.ar
.end
[dim
] != NULL
);
3510 if ((rank_remap
&& !ref
->u
.ar
.end
[dim
])
3511 || (!rank_remap
&& ref
->u
.ar
.end
[dim
]))
3513 gfc_error ("Either all or none of the upper bounds"
3514 " must be specified at %L", &lvalue
->where
);
3522 is_pure
= gfc_pure (NULL
);
3523 is_implicit_pure
= gfc_implicit_pure (NULL
);
3525 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3526 kind, etc for lvalue and rvalue must match, and rvalue must be a
3527 pure variable if we're in a pure function. */
3528 if (rvalue
->expr_type
== EXPR_NULL
&& rvalue
->ts
.type
== BT_UNKNOWN
)
3531 /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
3532 if (lvalue
->expr_type
== EXPR_VARIABLE
3533 && gfc_is_coindexed (lvalue
))
3536 for (ref
= lvalue
->ref
; ref
; ref
= ref
->next
)
3537 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3539 gfc_error ("Pointer object at %L shall not have a coindex",
3545 /* Checks on rvalue for procedure pointer assignments. */
3550 gfc_component
*comp1
, *comp2
;
3553 attr
= gfc_expr_attr (rvalue
);
3554 if (!((rvalue
->expr_type
== EXPR_NULL
)
3555 || (rvalue
->expr_type
== EXPR_FUNCTION
&& attr
.proc_pointer
)
3556 || (rvalue
->expr_type
== EXPR_VARIABLE
&& attr
.proc_pointer
)
3557 || (rvalue
->expr_type
== EXPR_VARIABLE
3558 && attr
.flavor
== FL_PROCEDURE
)))
3560 gfc_error ("Invalid procedure pointer assignment at %L",
3564 if (rvalue
->expr_type
== EXPR_VARIABLE
&& !attr
.proc_pointer
)
3566 /* Check for intrinsics. */
3567 gfc_symbol
*sym
= rvalue
->symtree
->n
.sym
;
3568 if (!sym
->attr
.intrinsic
3569 && (gfc_is_intrinsic (sym
, 0, sym
->declared_at
)
3570 || gfc_is_intrinsic (sym
, 1, sym
->declared_at
)))
3572 sym
->attr
.intrinsic
= 1;
3573 gfc_resolve_intrinsic (sym
, &rvalue
->where
);
3574 attr
= gfc_expr_attr (rvalue
);
3576 /* Check for result of embracing function. */
3577 if (sym
->attr
.function
&& sym
->result
== sym
)
3581 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
3582 if (sym
== ns
->proc_name
)
3584 gfc_error ("Function result %qs is invalid as proc-target "
3585 "in procedure pointer assignment at %L",
3586 sym
->name
, &rvalue
->where
);
3593 gfc_error ("Abstract interface %qs is invalid "
3594 "in procedure pointer assignment at %L",
3595 rvalue
->symtree
->name
, &rvalue
->where
);
3598 /* Check for F08:C729. */
3599 if (attr
.flavor
== FL_PROCEDURE
)
3601 if (attr
.proc
== PROC_ST_FUNCTION
)
3603 gfc_error ("Statement function %qs is invalid "
3604 "in procedure pointer assignment at %L",
3605 rvalue
->symtree
->name
, &rvalue
->where
);
3608 if (attr
.proc
== PROC_INTERNAL
&&
3609 !gfc_notify_std(GFC_STD_F2008
, "Internal procedure %qs "
3610 "is invalid in procedure pointer assignment "
3611 "at %L", rvalue
->symtree
->name
, &rvalue
->where
))
3613 if (attr
.intrinsic
&& gfc_intrinsic_actual_ok (rvalue
->symtree
->name
,
3614 attr
.subroutine
) == 0)
3616 gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer "
3617 "assignment", rvalue
->symtree
->name
, &rvalue
->where
);
3621 /* Check for F08:C730. */
3622 if (attr
.elemental
&& !attr
.intrinsic
)
3624 gfc_error ("Nonintrinsic elemental procedure %qs is invalid "
3625 "in procedure pointer assignment at %L",
3626 rvalue
->symtree
->name
, &rvalue
->where
);
3630 /* Ensure that the calling convention is the same. As other attributes
3631 such as DLLEXPORT may differ, one explicitly only tests for the
3632 calling conventions. */
3633 if (rvalue
->expr_type
== EXPR_VARIABLE
3634 && lvalue
->symtree
->n
.sym
->attr
.ext_attr
3635 != rvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3637 symbol_attribute calls
;
3640 gfc_add_ext_attribute (&calls
, EXT_ATTR_CDECL
, NULL
);
3641 gfc_add_ext_attribute (&calls
, EXT_ATTR_STDCALL
, NULL
);
3642 gfc_add_ext_attribute (&calls
, EXT_ATTR_FASTCALL
, NULL
);
3644 if ((calls
.ext_attr
& lvalue
->symtree
->n
.sym
->attr
.ext_attr
)
3645 != (calls
.ext_attr
& rvalue
->symtree
->n
.sym
->attr
.ext_attr
))
3647 gfc_error ("Mismatch in the procedure pointer assignment "
3648 "at %L: mismatch in the calling convention",
3654 comp1
= gfc_get_proc_ptr_comp (lvalue
);
3656 s1
= comp1
->ts
.interface
;
3659 s1
= lvalue
->symtree
->n
.sym
;
3660 if (s1
->ts
.interface
)
3661 s1
= s1
->ts
.interface
;
3664 comp2
= gfc_get_proc_ptr_comp (rvalue
);
3667 if (rvalue
->expr_type
== EXPR_FUNCTION
)
3669 s2
= comp2
->ts
.interface
->result
;
3674 s2
= comp2
->ts
.interface
;
3678 else if (rvalue
->expr_type
== EXPR_FUNCTION
)
3680 if (rvalue
->value
.function
.esym
)
3681 s2
= rvalue
->value
.function
.esym
->result
;
3683 s2
= rvalue
->symtree
->n
.sym
->result
;
3689 s2
= rvalue
->symtree
->n
.sym
;
3693 if (s2
&& s2
->attr
.proc_pointer
&& s2
->ts
.interface
)
3694 s2
= s2
->ts
.interface
;
3696 /* Special check for the case of absent interface on the lvalue.
3697 * All other interface checks are done below. */
3698 if (!s1
&& comp1
&& comp1
->attr
.subroutine
&& s2
&& s2
->attr
.function
)
3700 gfc_error ("Interface mismatch in procedure pointer assignment "
3701 "at %L: %qs is not a subroutine", &rvalue
->where
, name
);
3705 /* F08:7.2.2.4 (4) */
3706 if (s2
&& gfc_explicit_interface_required (s2
, err
, sizeof(err
)))
3710 gfc_error ("Explicit interface required for component %qs at %L: %s",
3711 comp1
->name
, &lvalue
->where
, err
);
3714 else if (s1
->attr
.if_source
== IFSRC_UNKNOWN
)
3716 gfc_error ("Explicit interface required for %qs at %L: %s",
3717 s1
->name
, &lvalue
->where
, err
);
3721 if (s1
&& gfc_explicit_interface_required (s1
, err
, sizeof(err
)))
3725 gfc_error ("Explicit interface required for component %qs at %L: %s",
3726 comp2
->name
, &rvalue
->where
, err
);
3729 else if (s2
->attr
.if_source
== IFSRC_UNKNOWN
)
3731 gfc_error ("Explicit interface required for %qs at %L: %s",
3732 s2
->name
, &rvalue
->where
, err
);
3737 if (s1
== s2
|| !s1
|| !s2
)
3740 if (!gfc_compare_interfaces (s1
, s2
, name
, 0, 1,
3741 err
, sizeof(err
), NULL
, NULL
))
3743 gfc_error ("Interface mismatch in procedure pointer assignment "
3744 "at %L: %s", &rvalue
->where
, err
);
3748 /* Check F2008Cor2, C729. */
3749 if (!s2
->attr
.intrinsic
&& s2
->attr
.if_source
== IFSRC_UNKNOWN
3750 && !s2
->attr
.external
&& !s2
->attr
.subroutine
&& !s2
->attr
.function
)
3752 gfc_error ("Procedure pointer target %qs at %L must be either an "
3753 "intrinsic, host or use associated, referenced or have "
3754 "the EXTERNAL attribute", s2
->name
, &rvalue
->where
);
3761 if (!gfc_compare_types (&lvalue
->ts
, &rvalue
->ts
))
3763 /* Check for F03:C717. */
3764 if (UNLIMITED_POLY (rvalue
)
3765 && !(UNLIMITED_POLY (lvalue
)
3766 || (lvalue
->ts
.type
== BT_DERIVED
3767 && (lvalue
->ts
.u
.derived
->attr
.is_bind_c
3768 || lvalue
->ts
.u
.derived
->attr
.sequence
))))
3769 gfc_error ("Data-pointer-object at %L must be unlimited "
3770 "polymorphic, or of a type with the BIND or SEQUENCE "
3771 "attribute, to be compatible with an unlimited "
3772 "polymorphic target", &lvalue
->where
);
3774 gfc_error ("Different types in pointer assignment at %L; "
3775 "attempted assignment of %s to %s", &lvalue
->where
,
3776 gfc_typename (&rvalue
->ts
),
3777 gfc_typename (&lvalue
->ts
));
3781 if (lvalue
->ts
.type
!= BT_CLASS
&& lvalue
->ts
.kind
!= rvalue
->ts
.kind
)
3783 gfc_error ("Different kind type parameters in pointer "
3784 "assignment at %L", &lvalue
->where
);
3788 if (lvalue
->rank
!= rvalue
->rank
&& !rank_remap
)
3790 gfc_error ("Different ranks in pointer assignment at %L", &lvalue
->where
);
3794 /* Make sure the vtab is present. */
3795 if (lvalue
->ts
.type
== BT_CLASS
&& !UNLIMITED_POLY (rvalue
))
3796 gfc_find_vtab (&rvalue
->ts
);
3798 /* Check rank remapping. */
3803 /* If this can be determined, check that the target must be at least as
3804 large as the pointer assigned to it is. */
3805 if (gfc_array_size (lvalue
, &lsize
)
3806 && gfc_array_size (rvalue
, &rsize
)
3807 && mpz_cmp (rsize
, lsize
) < 0)
3809 gfc_error ("Rank remapping target is smaller than size of the"
3810 " pointer (%ld < %ld) at %L",
3811 mpz_get_si (rsize
), mpz_get_si (lsize
),
3816 /* The target must be either rank one or it must be simply contiguous
3817 and F2008 must be allowed. */
3818 if (rvalue
->rank
!= 1)
3820 if (!gfc_is_simply_contiguous (rvalue
, true, false))
3822 gfc_error ("Rank remapping target must be rank 1 or"
3823 " simply contiguous at %L", &rvalue
->where
);
3826 if (!gfc_notify_std (GFC_STD_F2008
, "Rank remapping target is not "
3827 "rank 1 at %L", &rvalue
->where
))
3832 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
3833 if (rvalue
->expr_type
== EXPR_NULL
)
3836 if (lvalue
->ts
.type
== BT_CHARACTER
)
3838 bool t
= gfc_check_same_strlen (lvalue
, rvalue
, "pointer assignment");
3843 if (rvalue
->expr_type
== EXPR_VARIABLE
&& is_subref_array (rvalue
))
3844 lvalue
->symtree
->n
.sym
->attr
.subref_array_pointer
= 1;
3846 attr
= gfc_expr_attr (rvalue
);
3848 if (rvalue
->expr_type
== EXPR_FUNCTION
&& !attr
.pointer
)
3850 /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call
3851 to caf_get. Map this to the same error message as below when it is
3852 still a variable expression. */
3853 if (rvalue
->value
.function
.isym
3854 && rvalue
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
3855 /* The test above might need to be extend when F08, Note 5.4 has to be
3856 interpreted in the way that target and pointer with the same coindex
3858 gfc_error ("Data target at %L shall not have a coindex",
3861 gfc_error ("Target expression in pointer assignment "
3862 "at %L must deliver a pointer result",
3867 if (!attr
.target
&& !attr
.pointer
)
3869 gfc_error ("Pointer assignment target is neither TARGET "
3870 "nor POINTER at %L", &rvalue
->where
);
3874 if (is_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3876 gfc_error ("Bad target in pointer assignment in PURE "
3877 "procedure at %L", &rvalue
->where
);
3880 if (is_implicit_pure
&& gfc_impure_variable (rvalue
->symtree
->n
.sym
))
3881 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
3883 if (gfc_has_vector_index (rvalue
))
3885 gfc_error ("Pointer assignment with vector subscript "
3886 "on rhs at %L", &rvalue
->where
);
3890 if (attr
.is_protected
&& attr
.use_assoc
3891 && !(attr
.pointer
|| attr
.proc_pointer
))
3893 gfc_error ("Pointer assignment target has PROTECTED "
3894 "attribute at %L", &rvalue
->where
);
3898 /* F2008, C725. For PURE also C1283. */
3899 if (rvalue
->expr_type
== EXPR_VARIABLE
3900 && gfc_is_coindexed (rvalue
))
3903 for (ref
= rvalue
->ref
; ref
; ref
= ref
->next
)
3904 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
3906 gfc_error ("Data target at %L shall not have a coindex",
3912 /* Error for assignments of contiguous pointers to targets which is not
3913 contiguous. Be lenient in the definition of what counts as
3916 if (lhs_attr
.contiguous
&& !gfc_is_simply_contiguous (rvalue
, false, true))
3917 gfc_error ("Assignment to contiguous pointer from non-contiguous "
3918 "target at %L", &rvalue
->where
);
3920 /* Warn if it is the LHS pointer may lives longer than the RHS target. */
3921 if (warn_target_lifetime
3922 && rvalue
->expr_type
== EXPR_VARIABLE
3923 && !rvalue
->symtree
->n
.sym
->attr
.save
3924 && !rvalue
->symtree
->n
.sym
->attr
.pointer
&& !attr
.pointer
3925 && !rvalue
->symtree
->n
.sym
->attr
.host_assoc
3926 && !rvalue
->symtree
->n
.sym
->attr
.in_common
3927 && !rvalue
->symtree
->n
.sym
->attr
.use_assoc
3928 && !rvalue
->symtree
->n
.sym
->attr
.dummy
)
3933 warn
= lvalue
->symtree
->n
.sym
->attr
.dummy
3934 || lvalue
->symtree
->n
.sym
->attr
.result
3935 || lvalue
->symtree
->n
.sym
->attr
.function
3936 || (lvalue
->symtree
->n
.sym
->attr
.host_assoc
3937 && lvalue
->symtree
->n
.sym
->ns
3938 != rvalue
->symtree
->n
.sym
->ns
)
3939 || lvalue
->symtree
->n
.sym
->attr
.use_assoc
3940 || lvalue
->symtree
->n
.sym
->attr
.in_common
;
3942 if (rvalue
->symtree
->n
.sym
->ns
->proc_name
3943 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
3944 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.flavor
!= FL_PROGRAM
)
3945 for (ns
= rvalue
->symtree
->n
.sym
->ns
;
3946 ns
&& ns
->proc_name
&& ns
->proc_name
->attr
.flavor
!= FL_PROCEDURE
;
3948 if (ns
->parent
== lvalue
->symtree
->n
.sym
->ns
)
3955 gfc_warning (OPT_Wtarget_lifetime
,
3956 "Pointer at %L in pointer assignment might outlive the "
3957 "pointer target", &lvalue
->where
);
3964 /* Relative of gfc_check_assign() except that the lvalue is a single
3965 symbol. Used for initialization assignments. */
3968 gfc_check_assign_symbol (gfc_symbol
*sym
, gfc_component
*comp
, gfc_expr
*rvalue
)
3972 bool pointer
, proc_pointer
;
3974 memset (&lvalue
, '\0', sizeof (gfc_expr
));
3976 lvalue
.expr_type
= EXPR_VARIABLE
;
3977 lvalue
.ts
= sym
->ts
;
3979 lvalue
.rank
= sym
->as
->rank
;
3980 lvalue
.symtree
= XCNEW (gfc_symtree
);
3981 lvalue
.symtree
->n
.sym
= sym
;
3982 lvalue
.where
= sym
->declared_at
;
3986 lvalue
.ref
= gfc_get_ref ();
3987 lvalue
.ref
->type
= REF_COMPONENT
;
3988 lvalue
.ref
->u
.c
.component
= comp
;
3989 lvalue
.ref
->u
.c
.sym
= sym
;
3990 lvalue
.ts
= comp
->ts
;
3991 lvalue
.rank
= comp
->as
? comp
->as
->rank
: 0;
3992 lvalue
.where
= comp
->loc
;
3993 pointer
= comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
3994 ? CLASS_DATA (comp
)->attr
.class_pointer
: comp
->attr
.pointer
;
3995 proc_pointer
= comp
->attr
.proc_pointer
;
3999 pointer
= sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
4000 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
4001 proc_pointer
= sym
->attr
.proc_pointer
;
4004 if (pointer
|| proc_pointer
)
4005 r
= gfc_check_pointer_assign (&lvalue
, rvalue
);
4008 /* If a conversion function, e.g., __convert_i8_i4, was inserted
4009 into an array constructor, we should check if it can be reduced
4010 as an initialization expression. */
4011 if (rvalue
->expr_type
== EXPR_FUNCTION
4012 && rvalue
->value
.function
.isym
4013 && (rvalue
->value
.function
.isym
->conversion
== 1))
4014 gfc_check_init_expr (rvalue
);
4016 r
= gfc_check_assign (&lvalue
, rvalue
, 1);
4019 free (lvalue
.symtree
);
4025 if (pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4027 /* F08:C461. Additional checks for pointer initialization. */
4028 symbol_attribute attr
;
4029 attr
= gfc_expr_attr (rvalue
);
4030 if (attr
.allocatable
)
4032 gfc_error ("Pointer initialization target at %L "
4033 "must not be ALLOCATABLE", &rvalue
->where
);
4036 if (!attr
.target
|| attr
.pointer
)
4038 gfc_error ("Pointer initialization target at %L "
4039 "must have the TARGET attribute", &rvalue
->where
);
4043 if (!attr
.save
&& rvalue
->expr_type
== EXPR_VARIABLE
4044 && rvalue
->symtree
->n
.sym
->ns
->proc_name
4045 && rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.is_main_program
)
4047 rvalue
->symtree
->n
.sym
->ns
->proc_name
->attr
.save
= SAVE_IMPLICIT
;
4048 attr
.save
= SAVE_IMPLICIT
;
4053 gfc_error ("Pointer initialization target at %L "
4054 "must have the SAVE attribute", &rvalue
->where
);
4059 if (proc_pointer
&& rvalue
->expr_type
!= EXPR_NULL
)
4061 /* F08:C1220. Additional checks for procedure pointer initialization. */
4062 symbol_attribute attr
= gfc_expr_attr (rvalue
);
4063 if (attr
.proc_pointer
)
4065 gfc_error ("Procedure pointer initialization target at %L "
4066 "may not be a procedure pointer", &rvalue
->where
);
4074 /* Invoke gfc_build_init_expr to create an initializer expression, but do not
4075 * require that an expression be built. */
4078 gfc_build_default_init_expr (gfc_typespec
*ts
, locus
*where
)
4080 return gfc_build_init_expr (ts
, where
, false);
4083 /* Build an initializer for a local integer, real, complex, logical, or
4084 character variable, based on the command line flags finit-local-zero,
4085 finit-integer=, finit-real=, finit-logical=, and finit-character=.
4086 With force, an initializer is ALWAYS generated. */
4089 gfc_build_init_expr (gfc_typespec
*ts
, locus
*where
, bool force
)
4091 gfc_expr
*init_expr
;
4093 /* Try to build an initializer expression. */
4094 init_expr
= gfc_get_constant_expr (ts
->type
, ts
->kind
, where
);
4096 /* If we want to force generation, make sure we default to zero. */
4097 gfc_init_local_real init_real
= flag_init_real
;
4098 int init_logical
= gfc_option
.flag_init_logical
;
4101 if (init_real
== GFC_INIT_REAL_OFF
)
4102 init_real
= GFC_INIT_REAL_ZERO
;
4103 if (init_logical
== GFC_INIT_LOGICAL_OFF
)
4104 init_logical
= GFC_INIT_LOGICAL_FALSE
;
4107 /* We will only initialize integers, reals, complex, logicals, and
4108 characters, and only if the corresponding command-line flags
4109 were set. Otherwise, we free init_expr and return null. */
4113 if (force
|| gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
4114 mpz_set_si (init_expr
->value
.integer
,
4115 gfc_option
.flag_init_integer_value
);
4118 gfc_free_expr (init_expr
);
4126 case GFC_INIT_REAL_SNAN
:
4127 init_expr
->is_snan
= 1;
4129 case GFC_INIT_REAL_NAN
:
4130 mpfr_set_nan (init_expr
->value
.real
);
4133 case GFC_INIT_REAL_INF
:
4134 mpfr_set_inf (init_expr
->value
.real
, 1);
4137 case GFC_INIT_REAL_NEG_INF
:
4138 mpfr_set_inf (init_expr
->value
.real
, -1);
4141 case GFC_INIT_REAL_ZERO
:
4142 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
4146 gfc_free_expr (init_expr
);
4155 case GFC_INIT_REAL_SNAN
:
4156 init_expr
->is_snan
= 1;
4158 case GFC_INIT_REAL_NAN
:
4159 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
4160 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
4163 case GFC_INIT_REAL_INF
:
4164 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
4165 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
4168 case GFC_INIT_REAL_NEG_INF
:
4169 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
4170 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
4173 case GFC_INIT_REAL_ZERO
:
4174 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4178 gfc_free_expr (init_expr
);
4185 if (init_logical
== GFC_INIT_LOGICAL_FALSE
)
4186 init_expr
->value
.logical
= 0;
4187 else if (init_logical
== GFC_INIT_LOGICAL_TRUE
)
4188 init_expr
->value
.logical
= 1;
4191 gfc_free_expr (init_expr
);
4197 /* For characters, the length must be constant in order to
4198 create a default initializer. */
4199 if ((force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4201 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4203 HOST_WIDE_INT char_len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4204 init_expr
->value
.character
.length
= char_len
;
4205 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
4206 for (size_t i
= 0; i
< (size_t) char_len
; i
++)
4207 init_expr
->value
.character
.string
[i
]
4208 = (unsigned char) gfc_option
.flag_init_character_value
;
4212 gfc_free_expr (init_expr
);
4216 && (force
|| gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
)
4217 && ts
->u
.cl
->length
&& flag_max_stack_var_size
!= 0)
4219 gfc_actual_arglist
*arg
;
4220 init_expr
= gfc_get_expr ();
4221 init_expr
->where
= *where
;
4222 init_expr
->ts
= *ts
;
4223 init_expr
->expr_type
= EXPR_FUNCTION
;
4224 init_expr
->value
.function
.isym
=
4225 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
4226 init_expr
->value
.function
.name
= "repeat";
4227 arg
= gfc_get_actual_arglist ();
4228 arg
->expr
= gfc_get_character_expr (ts
->kind
, where
, NULL
, 1);
4229 arg
->expr
->value
.character
.string
[0] =
4230 gfc_option
.flag_init_character_value
;
4231 arg
->next
= gfc_get_actual_arglist ();
4232 arg
->next
->expr
= gfc_copy_expr (ts
->u
.cl
->length
);
4233 init_expr
->value
.function
.actual
= arg
;
4238 gfc_free_expr (init_expr
);
4245 /* Apply an initialization expression to a typespec. Can be used for symbols or
4246 components. Similar to add_init_expr_to_sym in decl.c; could probably be
4247 combined with some effort. */
4250 gfc_apply_init (gfc_typespec
*ts
, symbol_attribute
*attr
, gfc_expr
*init
)
4252 if (ts
->type
== BT_CHARACTER
&& !attr
->pointer
&& init
4254 && ts
->u
.cl
->length
&& ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
4256 gcc_assert (ts
->u
.cl
&& ts
->u
.cl
->length
);
4257 gcc_assert (ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
);
4258 gcc_assert (ts
->u
.cl
->length
->ts
.type
== BT_INTEGER
);
4260 HOST_WIDE_INT len
= gfc_mpz_get_hwi (ts
->u
.cl
->length
->value
.integer
);
4262 if (init
->expr_type
== EXPR_CONSTANT
)
4263 gfc_set_constant_character_len (len
, init
, -1);
4265 && init
->ts
.type
== BT_CHARACTER
4266 && init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
4267 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
4268 init
->ts
.u
.cl
->length
->value
.integer
))
4270 gfc_constructor
*ctor
;
4271 ctor
= gfc_constructor_first (init
->value
.constructor
);
4275 bool has_ts
= (init
->ts
.u
.cl
4276 && init
->ts
.u
.cl
->length_from_typespec
);
4278 /* Remember the length of the first element for checking
4279 that all elements *in the constructor* have the same
4280 length. This need not be the length of the LHS! */
4281 gcc_assert (ctor
->expr
->expr_type
== EXPR_CONSTANT
);
4282 gcc_assert (ctor
->expr
->ts
.type
== BT_CHARACTER
);
4283 gfc_charlen_t first_len
= ctor
->expr
->value
.character
.length
;
4285 for ( ; ctor
; ctor
= gfc_constructor_next (ctor
))
4286 if (ctor
->expr
->expr_type
== EXPR_CONSTANT
)
4288 gfc_set_constant_character_len (len
, ctor
->expr
,
4289 has_ts
? -1 : first_len
);
4290 if (!ctor
->expr
->ts
.u
.cl
)
4292 = gfc_new_charlen (gfc_current_ns
, ts
->u
.cl
);
4294 ctor
->expr
->ts
.u
.cl
->length
4295 = gfc_copy_expr (ts
->u
.cl
->length
);
4303 /* Check whether an expression is a structure constructor and whether it has
4304 other values than NULL. */
4307 is_non_empty_structure_constructor (gfc_expr
* e
)
4309 if (e
->expr_type
!= EXPR_STRUCTURE
)
4312 gfc_constructor
*cons
= gfc_constructor_first (e
->value
.constructor
);
4315 if (!cons
->expr
|| cons
->expr
->expr_type
!= EXPR_NULL
)
4317 cons
= gfc_constructor_next (cons
);
4323 /* Check for default initializer; sym->value is not enough
4324 as it is also set for EXPR_NULL of allocatables. */
4327 gfc_has_default_initializer (gfc_symbol
*der
)
4331 gcc_assert (gfc_fl_struct (der
->attr
.flavor
));
4332 for (c
= der
->components
; c
; c
= c
->next
)
4333 if (gfc_bt_struct (c
->ts
.type
))
4335 if (!c
->attr
.pointer
&& !c
->attr
.proc_pointer
4336 && !(c
->attr
.allocatable
&& der
== c
->ts
.u
.derived
)
4338 && is_non_empty_structure_constructor (c
->initializer
))
4339 || gfc_has_default_initializer (c
->ts
.u
.derived
)))
4341 if (c
->attr
.pointer
&& c
->initializer
)
4355 Generate an initializer expression which initializes the entirety of a union.
4356 A normal structure constructor is insufficient without undue effort, because
4357 components of maps may be oddly aligned/overlapped. (For example if a
4358 character is initialized from one map overtop a real from the other, only one
4359 byte of the real is actually initialized.) Unfortunately we don't know the
4360 size of the union right now, so we can't generate a proper initializer, but
4361 we use a NULL expr as a placeholder and do the right thing later in
4362 gfc_trans_subcomponent_assign.
4365 generate_union_initializer (gfc_component
*un
)
4367 if (un
== NULL
|| un
->ts
.type
!= BT_UNION
)
4370 gfc_expr
*placeholder
= gfc_get_null_expr (&un
->loc
);
4371 placeholder
->ts
= un
->ts
;
4376 /* Get the user-specified initializer for a union, if any. This means the user
4377 has said to initialize component(s) of a map. For simplicity's sake we
4378 only allow the user to initialize the first map. We don't have to worry
4379 about overlapping initializers as they are released early in resolution (see
4380 resolve_fl_struct). */
4383 get_union_initializer (gfc_symbol
*union_type
, gfc_component
**map_p
)
4386 gfc_expr
*init
=NULL
;
4388 if (!union_type
|| union_type
->attr
.flavor
!= FL_UNION
)
4391 for (map
= union_type
->components
; map
; map
= map
->next
)
4393 if (gfc_has_default_initializer (map
->ts
.u
.derived
))
4395 init
= gfc_default_initializer (&map
->ts
);
4408 /* Fetch or generate an initializer for the given component.
4409 Only generate an initializer if generate is true. */
4412 component_initializer (gfc_typespec
*ts
, gfc_component
*c
, bool generate
)
4414 gfc_expr
*init
= NULL
;
4416 /* See if we can find the initializer immediately.
4417 Some components should never get initializers. */
4418 if (c
->initializer
|| !generate
4419 || (ts
->type
== BT_CLASS
&& !c
->attr
.allocatable
)
4421 || c
->attr
.class_pointer
4422 || c
->attr
.proc_pointer
)
4423 return c
->initializer
;
4425 /* Recursively handle derived type components. */
4426 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
4427 init
= gfc_generate_initializer (&c
->ts
, true);
4429 else if (c
->ts
.type
== BT_UNION
&& c
->ts
.u
.derived
->components
)
4431 gfc_component
*map
= NULL
;
4432 gfc_constructor
*ctor
;
4433 gfc_expr
*user_init
;
4435 /* If we don't have a user initializer and we aren't generating one, this
4436 union has no initializer. */
4437 user_init
= get_union_initializer (c
->ts
.u
.derived
, &map
);
4438 if (!user_init
&& !generate
)
4441 /* Otherwise use a structure constructor. */
4442 init
= gfc_get_structure_constructor_expr (c
->ts
.type
, c
->ts
.kind
,
4446 /* If we are to generate an initializer for the union, add a constructor
4447 which initializes the whole union first. */
4450 ctor
= gfc_constructor_get ();
4451 ctor
->expr
= generate_union_initializer (c
);
4452 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4455 /* If we found an initializer in one of our maps, apply it. Note this
4456 is applied _after_ the entire-union initializer above if any. */
4459 ctor
= gfc_constructor_get ();
4460 ctor
->expr
= user_init
;
4461 ctor
->n
.component
= map
;
4462 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4466 /* Treat simple components like locals. */
4469 /* We MUST give an initializer, so force generation. */
4470 init
= gfc_build_init_expr (&c
->ts
, &c
->loc
, true);
4471 gfc_apply_init (&c
->ts
, &c
->attr
, init
);
4478 /* Get an expression for a default initializer of a derived type. */
4481 gfc_default_initializer (gfc_typespec
*ts
)
4483 return gfc_generate_initializer (ts
, false);
4487 /* Get or generate an expression for a default initializer of a derived type.
4488 If -finit-derived is specified, generate default initialization expressions
4489 for components that lack them when generate is set. */
4492 gfc_generate_initializer (gfc_typespec
*ts
, bool generate
)
4494 gfc_expr
*init
, *tmp
;
4495 gfc_component
*comp
;
4496 generate
= flag_init_derived
&& generate
;
4498 /* See if we have a default initializer in this, but not in nested
4499 types (otherwise we could use gfc_has_default_initializer()).
4500 We don't need to check if we are going to generate them. */
4501 comp
= ts
->u
.derived
->components
;
4504 for (; comp
; comp
= comp
->next
)
4505 if (comp
->initializer
|| comp
->attr
.allocatable
4506 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)
4507 && CLASS_DATA (comp
)->attr
.allocatable
))
4514 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
4515 &ts
->u
.derived
->declared_at
);
4518 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
4520 gfc_constructor
*ctor
= gfc_constructor_get();
4522 /* Fetch or generate an initializer for the component. */
4523 tmp
= component_initializer (ts
, comp
, generate
);
4526 /* Save the component ref for STRUCTUREs and UNIONs. */
4527 if (ts
->u
.derived
->attr
.flavor
== FL_STRUCT
4528 || ts
->u
.derived
->attr
.flavor
== FL_UNION
)
4529 ctor
->n
.component
= comp
;
4531 /* If the initializer was not generated, we need a copy. */
4532 ctor
->expr
= comp
->initializer
? gfc_copy_expr (tmp
) : tmp
;
4533 if ((comp
->ts
.type
!= tmp
->ts
.type
4534 || comp
->ts
.kind
!= tmp
->ts
.kind
)
4535 && !comp
->attr
.pointer
&& !comp
->attr
.proc_pointer
)
4538 val
= gfc_convert_type_warn (ctor
->expr
, &comp
->ts
, 1, false);
4544 if (comp
->attr
.allocatable
4545 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
4547 ctor
->expr
= gfc_get_expr ();
4548 ctor
->expr
->expr_type
= EXPR_NULL
;
4549 ctor
->expr
->where
= init
->where
;
4550 ctor
->expr
->ts
= comp
->ts
;
4553 gfc_constructor_append (&init
->value
.constructor
, ctor
);
4560 /* Given a symbol, create an expression node with that symbol as a
4561 variable. If the symbol is array valued, setup a reference of the
4565 gfc_get_variable_expr (gfc_symtree
*var
)
4569 e
= gfc_get_expr ();
4570 e
->expr_type
= EXPR_VARIABLE
;
4572 e
->ts
= var
->n
.sym
->ts
;
4574 if (var
->n
.sym
->attr
.flavor
!= FL_PROCEDURE
4575 && ((var
->n
.sym
->as
!= NULL
&& var
->n
.sym
->ts
.type
!= BT_CLASS
)
4576 || (var
->n
.sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (var
->n
.sym
)
4577 && CLASS_DATA (var
->n
.sym
)->as
)))
4579 e
->rank
= var
->n
.sym
->ts
.type
== BT_CLASS
4580 ? CLASS_DATA (var
->n
.sym
)->as
->rank
: var
->n
.sym
->as
->rank
;
4581 e
->ref
= gfc_get_ref ();
4582 e
->ref
->type
= REF_ARRAY
;
4583 e
->ref
->u
.ar
.type
= AR_FULL
;
4584 e
->ref
->u
.ar
.as
= gfc_copy_array_spec (var
->n
.sym
->ts
.type
== BT_CLASS
4585 ? CLASS_DATA (var
->n
.sym
)->as
4593 /* Adds a full array reference to an expression, as needed. */
4596 gfc_add_full_array_ref (gfc_expr
*e
, gfc_array_spec
*as
)
4599 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4604 ref
->next
= gfc_get_ref ();
4609 e
->ref
= gfc_get_ref ();
4612 ref
->type
= REF_ARRAY
;
4613 ref
->u
.ar
.type
= AR_FULL
;
4614 ref
->u
.ar
.dimen
= e
->rank
;
4615 ref
->u
.ar
.where
= e
->where
;
4621 gfc_lval_expr_from_sym (gfc_symbol
*sym
)
4625 lval
= gfc_get_expr ();
4626 lval
->expr_type
= EXPR_VARIABLE
;
4627 lval
->where
= sym
->declared_at
;
4629 lval
->symtree
= gfc_find_symtree (sym
->ns
->sym_root
, sym
->name
);
4631 /* It will always be a full array. */
4632 as
= IS_CLASS_ARRAY (sym
) ? CLASS_DATA (sym
)->as
: sym
->as
;
4633 lval
->rank
= as
? as
->rank
: 0;
4635 gfc_add_full_array_ref (lval
, as
);
4640 /* Returns the array_spec of a full array expression. A NULL is
4641 returned otherwise. */
4643 gfc_get_full_arrayspec_from_expr (gfc_expr
*expr
)
4648 if (expr
->rank
== 0)
4651 /* Follow any component references. */
4652 if (expr
->expr_type
== EXPR_VARIABLE
4653 || expr
->expr_type
== EXPR_CONSTANT
)
4656 as
= expr
->symtree
->n
.sym
->as
;
4660 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4665 as
= ref
->u
.c
.component
->as
;
4673 switch (ref
->u
.ar
.type
)
4696 /* General expression traversal function. */
4699 gfc_traverse_expr (gfc_expr
*expr
, gfc_symbol
*sym
,
4700 bool (*func
)(gfc_expr
*, gfc_symbol
*, int*),
4705 gfc_actual_arglist
*args
;
4712 if ((*func
) (expr
, sym
, &f
))
4715 if (expr
->ts
.type
== BT_CHARACTER
4717 && expr
->ts
.u
.cl
->length
4718 && expr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4719 && gfc_traverse_expr (expr
->ts
.u
.cl
->length
, sym
, func
, f
))
4722 switch (expr
->expr_type
)
4727 for (args
= expr
->value
.function
.actual
; args
; args
= args
->next
)
4729 if (gfc_traverse_expr (args
->expr
, sym
, func
, f
))
4737 case EXPR_SUBSTRING
:
4740 case EXPR_STRUCTURE
:
4742 for (c
= gfc_constructor_first (expr
->value
.constructor
);
4743 c
; c
= gfc_constructor_next (c
))
4745 if (gfc_traverse_expr (c
->expr
, sym
, func
, f
))
4749 if (gfc_traverse_expr (c
->iterator
->var
, sym
, func
, f
))
4751 if (gfc_traverse_expr (c
->iterator
->start
, sym
, func
, f
))
4753 if (gfc_traverse_expr (c
->iterator
->end
, sym
, func
, f
))
4755 if (gfc_traverse_expr (c
->iterator
->step
, sym
, func
, f
))
4762 if (gfc_traverse_expr (expr
->value
.op
.op1
, sym
, func
, f
))
4764 if (gfc_traverse_expr (expr
->value
.op
.op2
, sym
, func
, f
))
4780 for (i
= 0; i
< GFC_MAX_DIMENSIONS
; i
++)
4782 if (gfc_traverse_expr (ar
.start
[i
], sym
, func
, f
))
4784 if (gfc_traverse_expr (ar
.end
[i
], sym
, func
, f
))
4786 if (gfc_traverse_expr (ar
.stride
[i
], sym
, func
, f
))
4792 if (gfc_traverse_expr (ref
->u
.ss
.start
, sym
, func
, f
))
4794 if (gfc_traverse_expr (ref
->u
.ss
.end
, sym
, func
, f
))
4799 if (ref
->u
.c
.component
->ts
.type
== BT_CHARACTER
4800 && ref
->u
.c
.component
->ts
.u
.cl
4801 && ref
->u
.c
.component
->ts
.u
.cl
->length
4802 && ref
->u
.c
.component
->ts
.u
.cl
->length
->expr_type
4804 && gfc_traverse_expr (ref
->u
.c
.component
->ts
.u
.cl
->length
,
4808 if (ref
->u
.c
.component
->as
)
4809 for (i
= 0; i
< ref
->u
.c
.component
->as
->rank
4810 + ref
->u
.c
.component
->as
->corank
; i
++)
4812 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->lower
[i
],
4815 if (gfc_traverse_expr (ref
->u
.c
.component
->as
->upper
[i
],
4829 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
4832 expr_set_symbols_referenced (gfc_expr
*expr
,
4833 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
4834 int *f ATTRIBUTE_UNUSED
)
4836 if (expr
->expr_type
!= EXPR_VARIABLE
)
4838 gfc_set_sym_referenced (expr
->symtree
->n
.sym
);
4843 gfc_expr_set_symbols_referenced (gfc_expr
*expr
)
4845 gfc_traverse_expr (expr
, NULL
, expr_set_symbols_referenced
, 0);
4849 /* Determine if an expression is a procedure pointer component and return
4850 the component in that case. Otherwise return NULL. */
4853 gfc_get_proc_ptr_comp (gfc_expr
*expr
)
4857 if (!expr
|| !expr
->ref
)
4864 if (ref
->type
== REF_COMPONENT
4865 && ref
->u
.c
.component
->attr
.proc_pointer
)
4866 return ref
->u
.c
.component
;
4872 /* Determine if an expression is a procedure pointer component. */
4875 gfc_is_proc_ptr_comp (gfc_expr
*expr
)
4877 return (gfc_get_proc_ptr_comp (expr
) != NULL
);
4881 /* Determine if an expression is a function with an allocatable class scalar
4884 gfc_is_alloc_class_scalar_function (gfc_expr
*expr
)
4886 if (expr
->expr_type
== EXPR_FUNCTION
4887 && expr
->value
.function
.esym
4888 && expr
->value
.function
.esym
->result
4889 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4890 && !CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4891 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
)
4898 /* Determine if an expression is a function with an allocatable class array
4901 gfc_is_class_array_function (gfc_expr
*expr
)
4903 if (expr
->expr_type
== EXPR_FUNCTION
4904 && expr
->value
.function
.esym
4905 && expr
->value
.function
.esym
->result
4906 && expr
->value
.function
.esym
->result
->ts
.type
== BT_CLASS
4907 && CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.dimension
4908 && (CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.allocatable
4909 || CLASS_DATA (expr
->value
.function
.esym
->result
)->attr
.pointer
))
4916 /* Walk an expression tree and check each variable encountered for being typed.
4917 If strict is not set, a top-level variable is tolerated untyped in -std=gnu
4918 mode as is a basic arithmetic expression using those; this is for things in
4921 INTEGER :: arr(n), n
4922 INTEGER :: arr(n + 1), n
4924 The namespace is needed for IMPLICIT typing. */
4926 static gfc_namespace
* check_typed_ns
;
4929 expr_check_typed_help (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4930 int* f ATTRIBUTE_UNUSED
)
4934 if (e
->expr_type
!= EXPR_VARIABLE
)
4937 gcc_assert (e
->symtree
);
4938 t
= gfc_check_symbol_typed (e
->symtree
->n
.sym
, check_typed_ns
,
4945 gfc_expr_check_typed (gfc_expr
* e
, gfc_namespace
* ns
, bool strict
)
4949 /* If this is a top-level variable or EXPR_OP, do the check with strict given
4953 if (e
->expr_type
== EXPR_VARIABLE
&& !e
->ref
)
4954 return gfc_check_symbol_typed (e
->symtree
->n
.sym
, ns
, strict
, e
->where
);
4956 if (e
->expr_type
== EXPR_OP
)
4960 gcc_assert (e
->value
.op
.op1
);
4961 t
= gfc_expr_check_typed (e
->value
.op
.op1
, ns
, strict
);
4963 if (t
&& e
->value
.op
.op2
)
4964 t
= gfc_expr_check_typed (e
->value
.op
.op2
, ns
, strict
);
4970 /* Otherwise, walk the expression and do it strictly. */
4971 check_typed_ns
= ns
;
4972 error_found
= gfc_traverse_expr (e
, NULL
, &expr_check_typed_help
, 0);
4974 return error_found
? false : true;
4978 /* This function returns true if it contains any references to PDT KIND
4979 or LEN parameters. */
4982 derived_parameter_expr (gfc_expr
* e
, gfc_symbol
* sym ATTRIBUTE_UNUSED
,
4983 int* f ATTRIBUTE_UNUSED
)
4985 if (e
->expr_type
!= EXPR_VARIABLE
)
4988 gcc_assert (e
->symtree
);
4989 if (e
->symtree
->n
.sym
->attr
.pdt_kind
4990 || e
->symtree
->n
.sym
->attr
.pdt_len
)
4998 gfc_derived_parameter_expr (gfc_expr
*e
)
5000 return gfc_traverse_expr (e
, NULL
, &derived_parameter_expr
, 0);
5004 /* This function returns the overall type of a type parameter spec list.
5005 If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the
5006 parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned
5007 unless derived is not NULL. In this latter case, all the LEN parameters
5008 must be either assumed or deferred for the return argument to be set to
5009 anything other than SPEC_EXPLICIT. */
5012 gfc_spec_list_type (gfc_actual_arglist
*param_list
, gfc_symbol
*derived
)
5014 gfc_param_spec_type res
= SPEC_EXPLICIT
;
5016 bool seen_assumed
= false;
5017 bool seen_deferred
= false;
5019 if (derived
== NULL
)
5021 for (; param_list
; param_list
= param_list
->next
)
5022 if (param_list
->spec_type
== SPEC_ASSUMED
5023 || param_list
->spec_type
== SPEC_DEFERRED
)
5024 return param_list
->spec_type
;
5028 for (; param_list
; param_list
= param_list
->next
)
5030 c
= gfc_find_component (derived
, param_list
->name
,
5032 gcc_assert (c
!= NULL
);
5033 if (c
->attr
.pdt_kind
)
5035 else if (param_list
->spec_type
== SPEC_EXPLICIT
)
5036 return SPEC_EXPLICIT
;
5037 seen_assumed
= param_list
->spec_type
== SPEC_ASSUMED
;
5038 seen_deferred
= param_list
->spec_type
== SPEC_DEFERRED
;
5039 if (seen_assumed
&& seen_deferred
)
5040 return SPEC_EXPLICIT
;
5042 res
= seen_assumed
? SPEC_ASSUMED
: SPEC_DEFERRED
;
5049 gfc_ref_this_image (gfc_ref
*ref
)
5053 gcc_assert (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0);
5055 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
5056 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
5063 gfc_find_team_co (gfc_expr
*e
)
5067 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5068 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5069 return ref
->u
.ar
.team
;
5071 if (e
->value
.function
.actual
->expr
)
5072 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5074 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5075 return ref
->u
.ar
.team
;
5081 gfc_find_stat_co (gfc_expr
*e
)
5085 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5086 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5087 return ref
->u
.ar
.stat
;
5089 if (e
->value
.function
.actual
->expr
)
5090 for (ref
= e
->value
.function
.actual
->expr
->ref
; ref
;
5092 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5093 return ref
->u
.ar
.stat
;
5099 gfc_is_coindexed (gfc_expr
*e
)
5103 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5104 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5105 return !gfc_ref_this_image (ref
);
5111 /* Coarrays are variables with a corank but not being coindexed. However, also
5112 the following is a coarray: A subobject of a coarray is a coarray if it does
5113 not have any cosubscripts, vector subscripts, allocatable component
5114 selection, or pointer component selection. (F2008, 2.4.7) */
5117 gfc_is_coarray (gfc_expr
*e
)
5121 gfc_component
*comp
;
5126 if (e
->expr_type
!= EXPR_VARIABLE
)
5130 sym
= e
->symtree
->n
.sym
;
5132 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
5133 coarray
= CLASS_DATA (sym
)->attr
.codimension
;
5135 coarray
= sym
->attr
.codimension
;
5137 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5141 comp
= ref
->u
.c
.component
;
5142 if (comp
->ts
.type
== BT_CLASS
&& comp
->attr
.class_ok
5143 && (CLASS_DATA (comp
)->attr
.class_pointer
5144 || CLASS_DATA (comp
)->attr
.allocatable
))
5147 coarray
= CLASS_DATA (comp
)->attr
.codimension
;
5149 else if (comp
->attr
.pointer
|| comp
->attr
.allocatable
)
5152 coarray
= comp
->attr
.codimension
;
5160 if (ref
->u
.ar
.codimen
> 0 && !gfc_ref_this_image (ref
))
5166 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5167 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5178 return coarray
&& !coindexed
;
5183 gfc_get_corank (gfc_expr
*e
)
5188 if (!gfc_is_coarray (e
))
5191 if (e
->ts
.type
== BT_CLASS
&& e
->ts
.u
.derived
->components
)
5192 corank
= e
->ts
.u
.derived
->components
->as
5193 ? e
->ts
.u
.derived
->components
->as
->corank
: 0;
5195 corank
= e
->symtree
->n
.sym
->as
? e
->symtree
->n
.sym
->as
->corank
: 0;
5197 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5199 if (ref
->type
== REF_ARRAY
)
5200 corank
= ref
->u
.ar
.as
->corank
;
5201 gcc_assert (ref
->type
!= REF_SUBSTRING
);
5208 /* Check whether the expression has an ultimate allocatable component.
5209 Being itself allocatable does not count. */
5211 gfc_has_ultimate_allocatable (gfc_expr
*e
)
5213 gfc_ref
*ref
, *last
= NULL
;
5215 if (e
->expr_type
!= EXPR_VARIABLE
)
5218 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5219 if (ref
->type
== REF_COMPONENT
)
5222 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5223 return CLASS_DATA (last
->u
.c
.component
)->attr
.alloc_comp
;
5224 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5225 return last
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
;
5229 if (e
->ts
.type
== BT_CLASS
)
5230 return CLASS_DATA (e
)->attr
.alloc_comp
;
5231 else if (e
->ts
.type
== BT_DERIVED
)
5232 return e
->ts
.u
.derived
->attr
.alloc_comp
;
5238 /* Check whether the expression has an pointer component.
5239 Being itself a pointer does not count. */
5241 gfc_has_ultimate_pointer (gfc_expr
*e
)
5243 gfc_ref
*ref
, *last
= NULL
;
5245 if (e
->expr_type
!= EXPR_VARIABLE
)
5248 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5249 if (ref
->type
== REF_COMPONENT
)
5252 if (last
&& last
->u
.c
.component
->ts
.type
== BT_CLASS
)
5253 return CLASS_DATA (last
->u
.c
.component
)->attr
.pointer_comp
;
5254 else if (last
&& last
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5255 return last
->u
.c
.component
->ts
.u
.derived
->attr
.pointer_comp
;
5259 if (e
->ts
.type
== BT_CLASS
)
5260 return CLASS_DATA (e
)->attr
.pointer_comp
;
5261 else if (e
->ts
.type
== BT_DERIVED
)
5262 return e
->ts
.u
.derived
->attr
.pointer_comp
;
5268 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
5269 Note: A scalar is not regarded as "simply contiguous" by the standard.
5270 if bool is not strict, some further checks are done - for instance,
5271 a "(::1)" is accepted. */
5274 gfc_is_simply_contiguous (gfc_expr
*expr
, bool strict
, bool permit_element
)
5278 gfc_array_ref
*ar
= NULL
;
5279 gfc_ref
*ref
, *part_ref
= NULL
;
5282 if (expr
->expr_type
== EXPR_FUNCTION
)
5284 if (expr
->value
.function
.esym
)
5285 return expr
->value
.function
.esym
->result
->attr
.contiguous
;
5288 /* We have to jump through some hoops if this is a vtab entry. */
5292 s
= expr
->symtree
->n
.sym
;
5293 if (s
->ts
.type
!= BT_CLASS
)
5297 for (r
= expr
->ref
; r
; r
= r
->next
)
5298 if (r
->type
== REF_COMPONENT
)
5301 if (rc
== NULL
|| rc
->u
.c
.component
== NULL
5302 || rc
->u
.c
.component
->ts
.interface
== NULL
)
5305 return rc
->u
.c
.component
->ts
.interface
->attr
.contiguous
;
5308 else if (expr
->expr_type
!= EXPR_VARIABLE
)
5311 if (!permit_element
&& expr
->rank
== 0)
5314 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5317 return false; /* Array shall be last part-ref. */
5319 if (ref
->type
== REF_COMPONENT
)
5321 else if (ref
->type
== REF_SUBSTRING
)
5323 else if (ref
->u
.ar
.type
!= AR_ELEMENT
)
5327 sym
= expr
->symtree
->n
.sym
;
5328 if (expr
->ts
.type
!= BT_CLASS
5330 && !part_ref
->u
.c
.component
->attr
.contiguous
5331 && part_ref
->u
.c
.component
->attr
.pointer
)
5333 && !sym
->attr
.contiguous
5334 && (sym
->attr
.pointer
5335 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
5336 || (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
)))))
5339 if (!ar
|| ar
->type
== AR_FULL
)
5342 gcc_assert (ar
->type
== AR_SECTION
);
5344 /* Check for simply contiguous array */
5346 for (i
= 0; i
< ar
->dimen
; i
++)
5348 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
5351 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
5357 gcc_assert (ar
->dimen_type
[i
] == DIMEN_RANGE
);
5360 /* If the previous section was not contiguous, that's an error,
5361 unless we have effective only one element and checking is not
5363 if (!colon
&& (strict
|| !ar
->start
[i
] || !ar
->end
[i
]
5364 || ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5365 || ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5366 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5367 ar
->end
[i
]->value
.integer
) != 0))
5370 /* Following the standard, "(::1)" or - if known at compile time -
5371 "(lbound:ubound)" are not simply contiguous; if strict
5372 is false, they are regarded as simply contiguous. */
5373 if (ar
->stride
[i
] && (strict
|| ar
->stride
[i
]->expr_type
!= EXPR_CONSTANT
5374 || ar
->stride
[i
]->ts
.type
!= BT_INTEGER
5375 || mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1) != 0))
5379 && (strict
|| ar
->start
[i
]->expr_type
!= EXPR_CONSTANT
5380 || !ar
->as
->lower
[i
]
5381 || ar
->as
->lower
[i
]->expr_type
!= EXPR_CONSTANT
5382 || mpz_cmp (ar
->start
[i
]->value
.integer
,
5383 ar
->as
->lower
[i
]->value
.integer
) != 0))
5387 && (strict
|| ar
->end
[i
]->expr_type
!= EXPR_CONSTANT
5388 || !ar
->as
->upper
[i
]
5389 || ar
->as
->upper
[i
]->expr_type
!= EXPR_CONSTANT
5390 || mpz_cmp (ar
->end
[i
]->value
.integer
,
5391 ar
->as
->upper
[i
]->value
.integer
) != 0))
5399 /* Build call to an intrinsic procedure. The number of arguments has to be
5400 passed (rather than ending the list with a NULL value) because we may
5401 want to add arguments but with a NULL-expression. */
5404 gfc_build_intrinsic_call (gfc_namespace
*ns
, gfc_isym_id id
, const char* name
,
5405 locus where
, unsigned numarg
, ...)
5408 gfc_actual_arglist
* atail
;
5409 gfc_intrinsic_sym
* isym
;
5412 const char *mangled_name
= gfc_get_string (GFC_PREFIX ("%s"), name
);
5414 isym
= gfc_intrinsic_function_by_id (id
);
5417 result
= gfc_get_expr ();
5418 result
->expr_type
= EXPR_FUNCTION
;
5419 result
->ts
= isym
->ts
;
5420 result
->where
= where
;
5421 result
->value
.function
.name
= mangled_name
;
5422 result
->value
.function
.isym
= isym
;
5424 gfc_get_sym_tree (mangled_name
, ns
, &result
->symtree
, false);
5425 gfc_commit_symbol (result
->symtree
->n
.sym
);
5426 gcc_assert (result
->symtree
5427 && (result
->symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
5428 || result
->symtree
->n
.sym
->attr
.flavor
== FL_UNKNOWN
));
5429 result
->symtree
->n
.sym
->intmod_sym_id
= id
;
5430 result
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
5431 result
->symtree
->n
.sym
->attr
.intrinsic
= 1;
5432 result
->symtree
->n
.sym
->attr
.artificial
= 1;
5434 va_start (ap
, numarg
);
5436 for (i
= 0; i
< numarg
; ++i
)
5440 atail
->next
= gfc_get_actual_arglist ();
5441 atail
= atail
->next
;
5444 atail
= result
->value
.function
.actual
= gfc_get_actual_arglist ();
5446 atail
->expr
= va_arg (ap
, gfc_expr
*);
5454 /* Check if an expression may appear in a variable definition context
5455 (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
5456 This is called from the various places when resolving
5457 the pieces that make up such a context.
5458 If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do
5459 variables), some checks are not performed.
5461 Optionally, a possible error message can be suppressed if context is NULL
5462 and just the return status (true / false) be requested. */
5465 gfc_check_vardef_context (gfc_expr
* e
, bool pointer
, bool alloc_obj
,
5466 bool own_scope
, const char* context
)
5468 gfc_symbol
* sym
= NULL
;
5470 bool check_intentin
;
5472 symbol_attribute attr
;
5476 if (e
->expr_type
== EXPR_VARIABLE
)
5478 gcc_assert (e
->symtree
);
5479 sym
= e
->symtree
->n
.sym
;
5481 else if (e
->expr_type
== EXPR_FUNCTION
)
5483 gcc_assert (e
->symtree
);
5484 sym
= e
->value
.function
.esym
? e
->value
.function
.esym
: e
->symtree
->n
.sym
;
5487 attr
= gfc_expr_attr (e
);
5488 if (!pointer
&& e
->expr_type
== EXPR_FUNCTION
&& attr
.pointer
)
5490 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
5493 gfc_error ("Fortran 2008: Pointer functions in variable definition"
5494 " context (%s) at %L", context
, &e
->where
);
5498 else if (e
->expr_type
!= EXPR_VARIABLE
)
5501 gfc_error ("Non-variable expression in variable definition context (%s)"
5502 " at %L", context
, &e
->where
);
5506 if (!pointer
&& sym
->attr
.flavor
== FL_PARAMETER
)
5509 gfc_error ("Named constant %qs in variable definition context (%s)"
5510 " at %L", sym
->name
, context
, &e
->where
);
5513 if (!pointer
&& sym
->attr
.flavor
!= FL_VARIABLE
5514 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
== sym
->result
)
5515 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc_pointer
))
5518 gfc_error ("%qs in variable definition context (%s) at %L is not"
5519 " a variable", sym
->name
, context
, &e
->where
);
5523 /* Find out whether the expr is a pointer; this also means following
5524 component references to the last one. */
5525 is_pointer
= (attr
.pointer
|| attr
.proc_pointer
);
5526 if (pointer
&& !is_pointer
)
5529 gfc_error ("Non-POINTER in pointer association context (%s)"
5530 " at %L", context
, &e
->where
);
5534 if (e
->ts
.type
== BT_DERIVED
5535 && e
->ts
.u
.derived
== NULL
)
5538 gfc_error ("Type inaccessible in variable definition context (%s) "
5539 "at %L", context
, &e
->where
);
5546 || (e
->ts
.type
== BT_DERIVED
5547 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5548 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)))
5551 gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
5552 context
, &e
->where
);
5556 /* TS18508, C702/C203. */
5559 || (e
->ts
.type
== BT_DERIVED
5560 && e
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
5561 && e
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)))
5564 gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
5565 context
, &e
->where
);
5569 /* INTENT(IN) dummy argument. Check this, unless the object itself is the
5570 component of sub-component of a pointer; we need to distinguish
5571 assignment to a pointer component from pointer-assignment to a pointer
5572 component. Note that (normal) assignment to procedure pointers is not
5574 check_intentin
= !own_scope
;
5575 ptr_component
= (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
5576 && CLASS_DATA (sym
))
5577 ? CLASS_DATA (sym
)->attr
.class_pointer
: sym
->attr
.pointer
;
5578 for (ref
= e
->ref
; ref
&& check_intentin
; ref
= ref
->next
)
5580 if (ptr_component
&& ref
->type
== REF_COMPONENT
)
5581 check_intentin
= false;
5582 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
5584 ptr_component
= true;
5586 check_intentin
= false;
5589 if (check_intentin
&& sym
->attr
.intent
== INTENT_IN
)
5591 if (pointer
&& is_pointer
)
5594 gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
5595 " association context (%s) at %L",
5596 sym
->name
, context
, &e
->where
);
5599 if (!pointer
&& !is_pointer
&& !sym
->attr
.pointer
)
5602 gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
5603 " definition context (%s) at %L",
5604 sym
->name
, context
, &e
->where
);
5609 /* PROTECTED and use-associated. */
5610 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
&& check_intentin
)
5612 if (pointer
&& is_pointer
)
5615 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5616 " pointer association context (%s) at %L",
5617 sym
->name
, context
, &e
->where
);
5620 if (!pointer
&& !is_pointer
)
5623 gfc_error ("Variable %qs is PROTECTED and can not appear in a"
5624 " variable definition context (%s) at %L",
5625 sym
->name
, context
, &e
->where
);
5630 /* Variable not assignable from a PURE procedure but appears in
5631 variable definition context. */
5632 if (!pointer
&& !own_scope
&& gfc_pure (NULL
) && gfc_impure_variable (sym
))
5635 gfc_error ("Variable %qs can not appear in a variable definition"
5636 " context (%s) at %L in PURE procedure",
5637 sym
->name
, context
, &e
->where
);
5641 if (!pointer
&& context
&& gfc_implicit_pure (NULL
)
5642 && gfc_impure_variable (sym
))
5647 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
5649 sym
= ns
->proc_name
;
5652 if (sym
->attr
.flavor
== FL_PROCEDURE
)
5654 sym
->attr
.implicit_pure
= 0;
5659 /* Check variable definition context for associate-names. */
5660 if (!pointer
&& sym
->assoc
)
5663 gfc_association_list
* assoc
;
5665 gcc_assert (sym
->assoc
->target
);
5667 /* If this is a SELECT TYPE temporary (the association is used internally
5668 for SELECT TYPE), silently go over to the target. */
5669 if (sym
->attr
.select_type_temporary
)
5671 gfc_expr
* t
= sym
->assoc
->target
;
5673 gcc_assert (t
->expr_type
== EXPR_VARIABLE
);
5674 name
= t
->symtree
->name
;
5676 if (t
->symtree
->n
.sym
->assoc
)
5677 assoc
= t
->symtree
->n
.sym
->assoc
;
5686 gcc_assert (name
&& assoc
);
5688 /* Is association to a valid variable? */
5689 if (!assoc
->variable
)
5693 if (assoc
->target
->expr_type
== EXPR_VARIABLE
)
5694 gfc_error ("%qs at %L associated to vector-indexed target can"
5695 " not be used in a variable definition context (%s)",
5696 name
, &e
->where
, context
);
5698 gfc_error ("%qs at %L associated to expression can"
5699 " not be used in a variable definition context (%s)",
5700 name
, &e
->where
, context
);
5705 /* Target must be allowed to appear in a variable definition context. */
5706 if (!gfc_check_vardef_context (assoc
->target
, pointer
, false, false, NULL
))
5709 gfc_error ("Associate-name %qs can not appear in a variable"
5710 " definition context (%s) at %L because its target"
5711 " at %L can not, either",
5712 name
, context
, &e
->where
,
5713 &assoc
->target
->where
);
5718 /* Check for same value in vector expression subscript. */
5721 for (ref
= e
->ref
; ref
!= NULL
; ref
= ref
->next
)
5722 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
5723 for (i
= 0; i
< GFC_MAX_DIMENSIONS
5724 && ref
->u
.ar
.dimen_type
[i
] != 0; i
++)
5725 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5727 gfc_expr
*arr
= ref
->u
.ar
.start
[i
];
5728 if (arr
->expr_type
== EXPR_ARRAY
)
5730 gfc_constructor
*c
, *n
;
5733 for (c
= gfc_constructor_first (arr
->value
.constructor
);
5734 c
!= NULL
; c
= gfc_constructor_next (c
))
5736 if (c
== NULL
|| c
->iterator
!= NULL
)
5741 for (n
= gfc_constructor_next (c
); n
!= NULL
;
5742 n
= gfc_constructor_next (n
))
5744 if (n
->iterator
!= NULL
)
5748 if (gfc_dep_compare_expr (ec
, en
) == 0)
5751 gfc_error_now ("Elements with the same value "
5752 "at %L and %L in vector "
5753 "subscript in a variable "
5754 "definition context (%s)",
5755 &(ec
->where
), &(en
->where
),