1 /* Primary expression subroutines
2 Copyright (C) 2000-2021 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"
29 #include "constructor.h"
31 int matching_actual_arglist
= 0;
33 /* Matches a kind-parameter expression, which is either a named
34 symbolic constant or a nonnegative integer constant. If
35 successful, sets the kind value to the correct integer.
36 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
37 symbol like e.g. 'c_int'. */
40 match_kind_param (int *kind
, int *is_iso_c
)
42 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
48 m
= gfc_match_small_literal_int (kind
, NULL
);
52 m
= gfc_match_name (name
);
56 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
62 *is_iso_c
= sym
->attr
.is_iso_c
;
64 if (sym
->attr
.flavor
!= FL_PARAMETER
)
67 if (sym
->value
== NULL
)
70 if (gfc_extract_int (sym
->value
, kind
))
73 gfc_set_sym_referenced (sym
);
82 /* Get a trailing kind-specification for non-character variables.
84 * the integer kind value or
85 * -1 if an error was generated,
86 * -2 if no kind was found.
87 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
88 symbol like e.g. 'c_int'. */
91 get_kind (int *is_iso_c
)
98 if (gfc_match_char ('_') != MATCH_YES
)
101 m
= match_kind_param (&kind
, is_iso_c
);
103 gfc_error ("Missing kind-parameter at %C");
105 return (m
== MATCH_YES
) ? kind
: -1;
109 /* Given a character and a radix, see if the character is a valid
110 digit in that radix. */
113 gfc_check_digit (char c
, int radix
)
120 r
= ('0' <= c
&& c
<= '1');
124 r
= ('0' <= c
&& c
<= '7');
128 r
= ('0' <= c
&& c
<= '9');
136 gfc_internal_error ("gfc_check_digit(): bad radix");
143 /* Match the digit string part of an integer if signflag is not set,
144 the signed digit string part if signflag is set. If the buffer
145 is NULL, we just count characters for the resolution pass. Returns
146 the number of characters matched, -1 for no match. */
149 match_digits (int signflag
, int radix
, char *buffer
)
156 c
= gfc_next_ascii_char ();
158 if (signflag
&& (c
== '+' || c
== '-'))
162 gfc_gobble_whitespace ();
163 c
= gfc_next_ascii_char ();
167 if (!gfc_check_digit (c
, radix
))
176 old_loc
= gfc_current_locus
;
177 c
= gfc_next_ascii_char ();
179 if (!gfc_check_digit (c
, radix
))
187 gfc_current_locus
= old_loc
;
192 /* Convert an integer string to an expression node. */
195 convert_integer (const char *buffer
, int kind
, int radix
, locus
*where
)
200 e
= gfc_get_constant_expr (BT_INTEGER
, kind
, where
);
201 /* A leading plus is allowed, but not by mpz_set_str. */
202 if (buffer
[0] == '+')
206 mpz_set_str (e
->value
.integer
, t
, radix
);
212 /* Convert a real string to an expression node. */
215 convert_real (const char *buffer
, int kind
, locus
*where
)
219 e
= gfc_get_constant_expr (BT_REAL
, kind
, where
);
220 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
226 /* Convert a pair of real, constant expression nodes to a single
227 complex expression node. */
230 convert_complex (gfc_expr
*real
, gfc_expr
*imag
, int kind
)
234 e
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &real
->where
);
235 mpc_set_fr_fr (e
->value
.complex, real
->value
.real
, imag
->value
.real
,
242 /* Match an integer (digit string and optional kind).
243 A sign will be accepted if signflag is set. */
246 match_integer_constant (gfc_expr
**result
, int signflag
)
248 int length
, kind
, is_iso_c
;
253 old_loc
= gfc_current_locus
;
254 gfc_gobble_whitespace ();
256 length
= match_digits (signflag
, 10, NULL
);
257 gfc_current_locus
= old_loc
;
261 buffer
= (char *) alloca (length
+ 1);
262 memset (buffer
, '\0', length
+ 1);
264 gfc_gobble_whitespace ();
266 match_digits (signflag
, 10, buffer
);
268 kind
= get_kind (&is_iso_c
);
270 kind
= gfc_default_integer_kind
;
274 if (kind
== 4 && flag_integer4_kind
== 8)
277 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
279 gfc_error ("Integer kind %d at %C not available", kind
);
283 e
= convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
284 e
->ts
.is_c_interop
= is_iso_c
;
286 if (gfc_range_check (e
) != ARITH_OK
)
288 gfc_error ("Integer too big for its kind at %C. This check can be "
289 "disabled with the option %<-fno-range-check%>");
300 /* Match a Hollerith constant. */
303 match_hollerith_constant (gfc_expr
**result
)
310 old_loc
= gfc_current_locus
;
311 gfc_gobble_whitespace ();
313 if (match_integer_constant (&e
, 0) == MATCH_YES
314 && gfc_match_char ('h') == MATCH_YES
)
316 if (!gfc_notify_std (GFC_STD_LEGACY
, "Hollerith constant at %C"))
319 if (gfc_extract_int (e
, &num
, 1))
323 gfc_error ("Invalid Hollerith constant: %L must contain at least "
324 "one character", &old_loc
);
327 if (e
->ts
.kind
!= gfc_default_integer_kind
)
329 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
330 "should be default", &old_loc
);
336 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
339 /* Calculate padding needed to fit default integer memory. */
340 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
342 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
344 for (i
= 0; i
< num
; i
++)
346 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
347 if (! gfc_wide_fits_in_byte (c
))
349 gfc_error ("Invalid Hollerith constant at %L contains a "
350 "wide character", &old_loc
);
354 e
->representation
.string
[i
] = (unsigned char) c
;
357 /* Now pad with blanks and end with a null char. */
358 for (i
= 0; i
< pad
; i
++)
359 e
->representation
.string
[num
+ i
] = ' ';
361 e
->representation
.string
[num
+ i
] = '\0';
362 e
->representation
.length
= num
+ pad
;
371 gfc_current_locus
= old_loc
;
380 /* Match a binary, octal or hexadecimal constant that can be found in
381 a DATA statement. The standard permits b'010...', o'73...', and
382 z'a1...' where b, o, and z can be capital letters. This function
383 also accepts postfixed forms of the constants: '01...'b, '73...'o,
384 and 'a1...'z. An additional extension is the use of x for z. */
387 match_boz_constant (gfc_expr
**result
)
389 int radix
, length
, x_hex
;
390 locus old_loc
, start_loc
;
391 char *buffer
, post
, delim
;
394 start_loc
= old_loc
= gfc_current_locus
;
395 gfc_gobble_whitespace ();
398 switch (post
= gfc_next_ascii_char ())
420 radix
= 16; /* Set to accept any valid digit string. */
426 /* No whitespace allowed here. */
429 delim
= gfc_next_ascii_char ();
431 if (delim
!= '\'' && delim
!= '\"')
435 && gfc_invalid_boz (G_("Hexadecimal constant at %L uses "
436 "nonstandard X instead of Z"), &gfc_current_locus
))
439 old_loc
= gfc_current_locus
;
441 length
= match_digits (0, radix
, NULL
);
444 gfc_error ("Empty set of digits in BOZ constant at %C");
448 if (gfc_next_ascii_char () != delim
)
450 gfc_error ("Illegal character in BOZ constant at %C");
456 switch (gfc_next_ascii_char ())
473 if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix "
474 "syntax"), &gfc_current_locus
))
478 gfc_current_locus
= old_loc
;
480 buffer
= (char *) alloca (length
+ 1);
481 memset (buffer
, '\0', length
+ 1);
483 match_digits (0, radix
, buffer
);
484 gfc_next_ascii_char (); /* Eat delimiter. */
486 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
489 e
->expr_type
= EXPR_CONSTANT
;
491 e
->where
= gfc_current_locus
;
494 e
->boz
.str
= XCNEWVEC (char, length
+ 1);
495 strncpy (e
->boz
.str
, buffer
, length
);
497 if (!gfc_in_match_data ()
498 && (!gfc_notify_std(GFC_STD_F2003
, "BOZ used outside a DATA "
499 "statement at %L", &e
->where
)))
506 gfc_current_locus
= start_loc
;
511 /* Match a real constant of some sort. Allow a signed constant if signflag
515 match_real_constant (gfc_expr
**result
, int signflag
)
517 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
, default_exponent
;
518 locus old_loc
, temp_loc
;
519 char *p
, *buffer
, c
, exp_char
;
523 old_loc
= gfc_current_locus
;
524 gfc_gobble_whitespace ();
528 default_exponent
= 0;
535 c
= gfc_next_ascii_char ();
536 if (signflag
&& (c
== '+' || c
== '-'))
541 gfc_gobble_whitespace ();
542 c
= gfc_next_ascii_char ();
545 /* Scan significand. */
546 for (;; c
= gfc_next_ascii_char (), count
++)
553 /* Check to see if "." goes with a following operator like
555 temp_loc
= gfc_current_locus
;
556 c
= gfc_next_ascii_char ();
558 if (c
== 'e' || c
== 'd' || c
== 'q')
560 c
= gfc_next_ascii_char ();
562 goto done
; /* Operator named .e. or .d. */
566 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
568 gfc_current_locus
= temp_loc
;
582 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
589 if (!gfc_notify_std (GFC_STD_GNU
, "exponent-letter 'q' in "
590 "real-literal-constant at %C"))
592 else if (warn_real_q_constant
)
593 gfc_warning (OPT_Wreal_q_constant
,
594 "Extension: exponent-letter %<q%> in real-literal-constant "
599 c
= gfc_next_ascii_char ();
602 if (c
== '+' || c
== '-')
603 { /* optional sign */
604 c
= gfc_next_ascii_char ();
610 /* With -fdec, default exponent to 0 instead of complaining. */
612 default_exponent
= 1;
615 gfc_error ("Missing exponent in real number at %C");
622 c
= gfc_next_ascii_char ();
627 /* Check that we have a numeric constant. */
628 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
630 gfc_current_locus
= old_loc
;
634 /* Convert the number. */
635 gfc_current_locus
= old_loc
;
636 gfc_gobble_whitespace ();
638 buffer
= (char *) alloca (count
+ default_exponent
+ 1);
639 memset (buffer
, '\0', count
+ default_exponent
+ 1);
642 c
= gfc_next_ascii_char ();
643 if (c
== '+' || c
== '-')
645 gfc_gobble_whitespace ();
646 c
= gfc_next_ascii_char ();
649 /* Hack for mpfr_set_str(). */
652 if (c
== 'd' || c
== 'q')
660 c
= gfc_next_ascii_char ();
662 if (default_exponent
)
665 kind
= get_kind (&is_iso_c
);
671 if (flag_real4_kind
== 8)
673 if (flag_real4_kind
== 10)
675 if (flag_real4_kind
== 16)
680 if (flag_real8_kind
== 4)
682 if (flag_real8_kind
== 10)
684 if (flag_real8_kind
== 16)
693 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
697 kind
= gfc_default_double_kind
;
703 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
708 /* The maximum possible real kind type parameter is 16. First, try
709 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
710 extended precision. If neither value works, just given up. */
712 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
715 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
717 gfc_error ("Invalid exponent-letter %<q%> in "
718 "real-literal-constant at %C");
726 kind
= gfc_default_real_kind
;
728 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
730 gfc_error ("Invalid real kind %d at %C", kind
);
735 e
= convert_real (buffer
, kind
, &gfc_current_locus
);
737 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
738 e
->ts
.is_c_interop
= is_iso_c
;
740 switch (gfc_range_check (e
))
745 gfc_error ("Real constant overflows its kind at %C");
748 case ARITH_UNDERFLOW
:
750 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
751 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
755 gfc_internal_error ("gfc_range_check() returned bad value");
758 /* Warn about trailing digits which suggest the user added too many
759 trailing digits, which may cause the appearance of higher pecision
760 than the kind kan support.
762 This is done by replacing the rightmost non-zero digit with zero
763 and comparing with the original value. If these are equal, we
764 assume the user supplied more digits than intended (or forgot to
765 convert to the correct kind).
768 if (warn_conversion_extra
)
774 c1
= strchr (buffer
, 'e');
776 c1
= buffer
+ strlen(buffer
);
779 for (p
= c1
; p
> buffer
;)
796 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
798 mpfr_neg (r
, r
, GFC_RND_MODE
);
800 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
802 if (mpfr_cmp_ui (r
, 0) == 0)
803 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
804 "in %qs number at %C, maybe incorrect KIND",
805 gfc_typename (&e
->ts
));
820 /* Match a substring reference. */
823 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
, bool deferred
)
825 gfc_expr
*start
, *end
;
833 old_loc
= gfc_current_locus
;
835 m
= gfc_match_char ('(');
839 if (gfc_match_char (':') != MATCH_YES
)
842 m
= gfc_match_init_expr (&start
);
844 m
= gfc_match_expr (&start
);
852 m
= gfc_match_char (':');
857 if (gfc_match_char (')') != MATCH_YES
)
860 m
= gfc_match_init_expr (&end
);
862 m
= gfc_match_expr (&end
);
866 if (m
== MATCH_ERROR
)
869 m
= gfc_match_char (')');
874 /* Optimize away the (:) reference. */
875 if (start
== NULL
&& end
== NULL
&& !deferred
)
879 ref
= gfc_get_ref ();
881 ref
->type
= REF_SUBSTRING
;
883 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
884 ref
->u
.ss
.start
= start
;
885 if (end
== NULL
&& cl
)
886 end
= gfc_copy_expr (cl
->length
);
888 ref
->u
.ss
.length
= cl
;
895 gfc_error ("Syntax error in SUBSTRING specification at %C");
899 gfc_free_expr (start
);
902 gfc_current_locus
= old_loc
;
907 /* Reads the next character of a string constant, taking care to
908 return doubled delimiters on the input as a single instance of
911 Special return values for "ret" argument are:
912 -1 End of the string, as determined by the delimiter
913 -2 Unterminated string detected
915 Backslash codes are also expanded at this time. */
918 next_string_char (gfc_char_t delimiter
, int *ret
)
923 c
= gfc_next_char_literal (INSTRING_WARN
);
932 if (flag_backslash
&& c
== '\\')
934 old_locus
= gfc_current_locus
;
936 if (gfc_match_special_char (&c
) == MATCH_NO
)
937 gfc_current_locus
= old_locus
;
939 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
940 gfc_warning (0, "Extension: backslash character at %C");
946 old_locus
= gfc_current_locus
;
947 c
= gfc_next_char_literal (NONSTRING
);
951 gfc_current_locus
= old_locus
;
958 /* Special case of gfc_match_name() that matches a parameter kind name
959 before a string constant. This takes case of the weird but legal
964 where kind____ is a parameter. gfc_match_name() will happily slurp
965 up all the underscores, which leads to problems. If we return
966 MATCH_YES, the parse pointer points to the final underscore, which
967 is not part of the name. We never return MATCH_ERROR-- errors in
968 the name will be detected later. */
971 match_charkind_name (char *name
)
977 gfc_gobble_whitespace ();
978 c
= gfc_next_ascii_char ();
987 old_loc
= gfc_current_locus
;
988 c
= gfc_next_ascii_char ();
992 peek
= gfc_peek_ascii_char ();
994 if (peek
== '\'' || peek
== '\"')
996 gfc_current_locus
= old_loc
;
1004 && (c
!= '$' || !flag_dollar_ok
))
1008 if (++len
> GFC_MAX_SYMBOL_LEN
)
1016 /* See if the current input matches a character constant. Lots of
1017 contortions have to be done to match the kind parameter which comes
1018 before the actual string. The main consideration is that we don't
1019 want to error out too quickly. For example, we don't actually do
1020 any validation of the kinds until we have actually seen a legal
1021 delimiter. Using match_kind_param() generates errors too quickly. */
1024 match_string_constant (gfc_expr
**result
)
1026 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1028 int kind
,save_warn_ampersand
, ret
;
1029 locus old_locus
, start_locus
;
1033 gfc_char_t c
, delimiter
, *p
;
1035 old_locus
= gfc_current_locus
;
1037 gfc_gobble_whitespace ();
1039 c
= gfc_next_char ();
1040 if (c
== '\'' || c
== '"')
1042 kind
= gfc_default_character_kind
;
1043 start_locus
= gfc_current_locus
;
1047 if (gfc_wide_is_digit (c
))
1051 while (gfc_wide_is_digit (c
))
1053 kind
= kind
* 10 + c
- '0';
1056 c
= gfc_next_char ();
1062 gfc_current_locus
= old_locus
;
1064 m
= match_charkind_name (name
);
1068 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1070 || sym
->attr
.flavor
!= FL_PARAMETER
)
1074 c
= gfc_next_char ();
1079 gfc_gobble_whitespace ();
1080 c
= gfc_next_char ();
1086 gfc_gobble_whitespace ();
1088 c
= gfc_next_char ();
1089 if (c
!= '\'' && c
!= '"')
1092 start_locus
= gfc_current_locus
;
1096 if (gfc_extract_int (sym
->value
, &kind
, 1))
1098 gfc_set_sym_referenced (sym
);
1101 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1103 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1108 /* Scan the string into a block of memory by first figuring out how
1109 long it is, allocating the structure, then re-reading it. This
1110 isn't particularly efficient, but string constants aren't that
1111 common in most code. TODO: Use obstacks? */
1118 c
= next_string_char (delimiter
, &ret
);
1123 gfc_current_locus
= start_locus
;
1124 gfc_error ("Unterminated character constant beginning at %C");
1131 /* Peek at the next character to see if it is a b, o, z, or x for the
1132 postfixed BOZ literal constants. */
1133 peek
= gfc_peek_ascii_char ();
1134 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1137 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1139 gfc_current_locus
= start_locus
;
1141 /* We disable the warning for the following loop as the warning has already
1142 been printed in the loop above. */
1143 save_warn_ampersand
= warn_ampersand
;
1144 warn_ampersand
= false;
1146 p
= e
->value
.character
.string
;
1147 for (size_t i
= 0; i
< length
; i
++)
1149 c
= next_string_char (delimiter
, &ret
);
1151 if (!gfc_check_character_range (c
, kind
))
1154 gfc_error ("Character %qs in string at %C is not representable "
1155 "in character kind %d", gfc_print_wide_char (c
), kind
);
1162 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1163 warn_ampersand
= save_warn_ampersand
;
1165 next_string_char (delimiter
, &ret
);
1167 gfc_internal_error ("match_string_constant(): Delimiter not found");
1169 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1170 e
->expr_type
= EXPR_SUBSTRING
;
1172 /* Substrings with constant starting and ending points are eligible as
1173 designators (F2018, section 9.1). Simplify substrings to make them usable
1174 e.g. in data statements. */
1175 if (e
->expr_type
== EXPR_SUBSTRING
1176 && e
->ref
&& e
->ref
->type
== REF_SUBSTRING
1177 && e
->ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1178 && (e
->ref
->u
.ss
.end
== NULL
1179 || e
->ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
))
1182 ptrdiff_t istart
, iend
;
1184 bool equal_length
= false;
1186 /* Basic checks on substring starting and ending indices. */
1187 if (!gfc_resolve_substring (e
->ref
, &equal_length
))
1190 length
= e
->value
.character
.length
;
1191 istart
= gfc_mpz_get_hwi (e
->ref
->u
.ss
.start
->value
.integer
);
1192 if (e
->ref
->u
.ss
.end
== NULL
)
1195 iend
= gfc_mpz_get_hwi (e
->ref
->u
.ss
.end
->value
.integer
);
1201 gfc_error ("Substring start index (%ld) at %L below 1",
1202 (long) istart
, &e
->ref
->u
.ss
.start
->where
);
1205 if (iend
> (ssize_t
) length
)
1207 gfc_error ("Substring end index (%ld) at %L exceeds string "
1208 "length", (long) iend
, &e
->ref
->u
.ss
.end
->where
);
1211 length
= iend
- istart
+ 1;
1216 res
= gfc_get_constant_expr (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
1217 res
->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1218 res
->value
.character
.length
= length
;
1220 memcpy (res
->value
.character
.string
,
1221 &e
->value
.character
.string
[istart
- 1],
1222 length
* sizeof (gfc_char_t
));
1223 res
->value
.character
.string
[length
] = '\0';
1232 gfc_current_locus
= old_locus
;
1237 /* Match a .true. or .false. Returns 1 if a .true. was found,
1238 0 if a .false. was found, and -1 otherwise. */
1240 match_logical_constant_string (void)
1242 locus orig_loc
= gfc_current_locus
;
1244 gfc_gobble_whitespace ();
1245 if (gfc_next_ascii_char () == '.')
1247 char ch
= gfc_next_ascii_char ();
1250 if (gfc_next_ascii_char () == 'a'
1251 && gfc_next_ascii_char () == 'l'
1252 && gfc_next_ascii_char () == 's'
1253 && gfc_next_ascii_char () == 'e'
1254 && gfc_next_ascii_char () == '.')
1255 /* Matched ".false.". */
1260 if (gfc_next_ascii_char () == 'r'
1261 && gfc_next_ascii_char () == 'u'
1262 && gfc_next_ascii_char () == 'e'
1263 && gfc_next_ascii_char () == '.')
1264 /* Matched ".true.". */
1268 gfc_current_locus
= orig_loc
;
1272 /* Match a .true. or .false. */
1275 match_logical_constant (gfc_expr
**result
)
1278 int i
, kind
, is_iso_c
;
1280 i
= match_logical_constant_string ();
1284 kind
= get_kind (&is_iso_c
);
1288 kind
= gfc_default_logical_kind
;
1290 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1292 gfc_error ("Bad kind for logical constant at %C");
1296 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1297 e
->ts
.is_c_interop
= is_iso_c
;
1304 /* Match a real or imaginary part of a complex constant that is a
1305 symbolic constant. */
1308 match_sym_complex_part (gfc_expr
**result
)
1310 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1315 m
= gfc_match_name (name
);
1319 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1322 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1324 /* Give the matcher for implied do-loops a chance to run. This yields
1325 a much saner error message for "write(*,*) (i, i=1, 6" where the
1326 right parenthesis is missing. */
1328 gfc_gobble_whitespace ();
1329 c
= gfc_peek_ascii_char ();
1330 if (c
== '=' || c
== ',')
1336 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1345 if (!gfc_numeric_ts (&sym
->value
->ts
))
1347 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1351 if (sym
->value
->rank
!= 0)
1353 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1357 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1358 "complex constant at %C"))
1361 switch (sym
->value
->ts
.type
)
1364 e
= gfc_copy_expr (sym
->value
);
1368 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1374 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1380 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1383 *result
= e
; /* e is a scalar, real, constant expression. */
1387 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1392 /* Match a real or imaginary part of a complex number. */
1395 match_complex_part (gfc_expr
**result
)
1399 m
= match_sym_complex_part (result
);
1403 m
= match_real_constant (result
, 1);
1407 return match_integer_constant (result
, 1);
1411 /* Try to match a complex constant. */
1414 match_complex_constant (gfc_expr
**result
)
1416 gfc_expr
*e
, *real
, *imag
;
1417 gfc_error_buffer old_error
;
1418 gfc_typespec target
;
1423 old_loc
= gfc_current_locus
;
1424 real
= imag
= e
= NULL
;
1426 m
= gfc_match_char ('(');
1430 gfc_push_error (&old_error
);
1432 m
= match_complex_part (&real
);
1435 gfc_free_error (&old_error
);
1439 if (gfc_match_char (',') == MATCH_NO
)
1441 /* It is possible that gfc_int2real issued a warning when
1442 converting an integer to real. Throw this away here. */
1444 gfc_clear_warning ();
1445 gfc_pop_error (&old_error
);
1450 /* If m is error, then something was wrong with the real part and we
1451 assume we have a complex constant because we've seen the ','. An
1452 ambiguous case here is the start of an iterator list of some
1453 sort. These sort of lists are matched prior to coming here. */
1455 if (m
== MATCH_ERROR
)
1457 gfc_free_error (&old_error
);
1460 gfc_pop_error (&old_error
);
1462 m
= match_complex_part (&imag
);
1465 if (m
== MATCH_ERROR
)
1468 m
= gfc_match_char (')');
1471 /* Give the matcher for implied do-loops a chance to run. This
1472 yields a much saner error message for (/ (i, 4=i, 6) /). */
1473 if (gfc_peek_ascii_char () == '=')
1482 if (m
== MATCH_ERROR
)
1485 /* Decide on the kind of this complex number. */
1486 if (real
->ts
.type
== BT_REAL
)
1488 if (imag
->ts
.type
== BT_REAL
)
1489 kind
= gfc_kind_max (real
, imag
);
1491 kind
= real
->ts
.kind
;
1495 if (imag
->ts
.type
== BT_REAL
)
1496 kind
= imag
->ts
.kind
;
1498 kind
= gfc_default_real_kind
;
1500 gfc_clear_ts (&target
);
1501 target
.type
= BT_REAL
;
1504 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1505 gfc_convert_type (real
, &target
, 2);
1506 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1507 gfc_convert_type (imag
, &target
, 2);
1509 e
= convert_complex (real
, imag
, kind
);
1510 e
->where
= gfc_current_locus
;
1512 gfc_free_expr (real
);
1513 gfc_free_expr (imag
);
1519 gfc_error ("Syntax error in COMPLEX constant at %C");
1524 gfc_free_expr (real
);
1525 gfc_free_expr (imag
);
1526 gfc_current_locus
= old_loc
;
1532 /* Match constants in any of several forms. Returns nonzero for a
1533 match, zero for no match. */
1536 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1540 m
= match_complex_constant (result
);
1544 m
= match_string_constant (result
);
1548 m
= match_boz_constant (result
);
1552 m
= match_real_constant (result
, signflag
);
1556 m
= match_hollerith_constant (result
);
1560 m
= match_integer_constant (result
, signflag
);
1564 m
= match_logical_constant (result
);
1572 /* This checks if a symbol is the return value of an encompassing function.
1573 Function nesting can be maximally two levels deep, but we may have
1574 additional local namespaces like BLOCK etc. */
1577 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1579 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1583 if (ns
->proc_name
== sym
)
1591 /* Match a single actual argument value. An actual argument is
1592 usually an expression, but can also be a procedure name. If the
1593 argument is a single name, it is not always possible to tell
1594 whether the name is a dummy procedure or not. We treat these cases
1595 by creating an argument that looks like a dummy procedure and
1596 fixing things later during resolution. */
1599 match_actual_arg (gfc_expr
**result
)
1601 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1602 gfc_symtree
*symtree
;
1607 gfc_gobble_whitespace ();
1608 where
= gfc_current_locus
;
1610 switch (gfc_match_name (name
))
1619 w
= gfc_current_locus
;
1620 gfc_gobble_whitespace ();
1621 c
= gfc_next_ascii_char ();
1622 gfc_current_locus
= w
;
1624 if (c
!= ',' && c
!= ')')
1627 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1629 /* Handle error elsewhere. */
1631 /* Eliminate a couple of common cases where we know we don't
1632 have a function argument. */
1633 if (symtree
== NULL
)
1635 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1636 gfc_set_sym_referenced (symtree
->n
.sym
);
1642 sym
= symtree
->n
.sym
;
1643 gfc_set_sym_referenced (sym
);
1644 if (sym
->attr
.flavor
== FL_NAMELIST
)
1646 gfc_error ("Namelist %qs cannot be an argument at %L",
1650 if (sym
->attr
.flavor
!= FL_PROCEDURE
1651 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1654 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1656 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1657 sym
->name
, &sym
->declared_at
))
1662 /* If the symbol is a function with itself as the result and
1663 is being defined, then we have a variable. */
1664 if (sym
->attr
.function
&& sym
->result
== sym
)
1666 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1670 && (sym
->ns
== gfc_current_ns
1671 || sym
->ns
== gfc_current_ns
->parent
))
1673 gfc_entry_list
*el
= NULL
;
1675 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1685 e
= gfc_get_expr (); /* Leave it unknown for now */
1686 e
->symtree
= symtree
;
1687 e
->expr_type
= EXPR_VARIABLE
;
1688 e
->ts
.type
= BT_PROCEDURE
;
1695 gfc_current_locus
= where
;
1696 return gfc_match_expr (result
);
1700 /* Match a keyword argument or type parameter spec list.. */
1703 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
, bool pdt
)
1705 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1706 gfc_actual_arglist
*a
;
1710 name_locus
= gfc_current_locus
;
1711 m
= gfc_match_name (name
);
1715 if (gfc_match_char ('=') != MATCH_YES
)
1723 if (gfc_match_char ('*') == MATCH_YES
)
1725 actual
->spec_type
= SPEC_ASSUMED
;
1728 else if (gfc_match_char (':') == MATCH_YES
)
1730 actual
->spec_type
= SPEC_DEFERRED
;
1734 actual
->spec_type
= SPEC_EXPLICIT
;
1737 m
= match_actual_arg (&actual
->expr
);
1741 /* Make sure this name has not appeared yet. */
1743 if (name
[0] != '\0')
1745 for (a
= base
; a
; a
= a
->next
)
1746 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1748 gfc_error ("Keyword %qs at %C has already appeared in the "
1749 "current argument list", name
);
1754 actual
->name
= gfc_get_string ("%s", name
);
1758 gfc_current_locus
= name_locus
;
1763 /* Match an argument list function, such as %VAL. */
1766 match_arg_list_function (gfc_actual_arglist
*result
)
1768 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1772 old_locus
= gfc_current_locus
;
1774 if (gfc_match_char ('%') != MATCH_YES
)
1780 m
= gfc_match ("%n (", name
);
1784 if (name
[0] != '\0')
1789 if (startswith (name
, "loc"))
1791 result
->name
= "%LOC";
1796 if (startswith (name
, "ref"))
1798 result
->name
= "%REF";
1803 if (startswith (name
, "val"))
1805 result
->name
= "%VAL";
1815 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1821 m
= match_actual_arg (&result
->expr
);
1825 if (gfc_match_char (')') != MATCH_YES
)
1834 gfc_current_locus
= old_locus
;
1839 /* Matches an actual argument list of a function or subroutine, from
1840 the opening parenthesis to the closing parenthesis. The argument
1841 list is assumed to allow keyword arguments because we don't know if
1842 the symbol associated with the procedure has an implicit interface
1843 or not. We make sure keywords are unique. If sub_flag is set,
1844 we're matching the argument list of a subroutine.
1846 NOTE: An alternative use for this function is to match type parameter
1847 spec lists, which are so similar to actual argument lists that the
1848 machinery can be reused. This use is flagged by the optional argument
1852 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
, bool pdt
)
1854 gfc_actual_arglist
*head
, *tail
;
1856 gfc_st_label
*label
;
1860 *argp
= tail
= NULL
;
1861 old_loc
= gfc_current_locus
;
1865 if (gfc_match_char ('(') == MATCH_NO
)
1866 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1868 if (gfc_match_char (')') == MATCH_YES
)
1873 matching_actual_arglist
++;
1878 head
= tail
= gfc_get_actual_arglist ();
1881 tail
->next
= gfc_get_actual_arglist ();
1885 if (sub_flag
&& !pdt
&& gfc_match_char ('*') == MATCH_YES
)
1887 m
= gfc_match_st_label (&label
);
1889 gfc_error ("Expected alternate return label at %C");
1893 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1897 tail
->label
= label
;
1901 if (pdt
&& !seen_keyword
)
1903 if (gfc_match_char (':') == MATCH_YES
)
1905 tail
->spec_type
= SPEC_DEFERRED
;
1908 else if (gfc_match_char ('*') == MATCH_YES
)
1910 tail
->spec_type
= SPEC_ASSUMED
;
1914 tail
->spec_type
= SPEC_EXPLICIT
;
1916 m
= match_keyword_arg (tail
, head
, pdt
);
1922 if (m
== MATCH_ERROR
)
1926 /* After the first keyword argument is seen, the following
1927 arguments must also have keywords. */
1930 m
= match_keyword_arg (tail
, head
, pdt
);
1932 if (m
== MATCH_ERROR
)
1936 gfc_error ("Missing keyword name in actual argument list at %C");
1943 /* Try an argument list function, like %VAL. */
1944 m
= match_arg_list_function (tail
);
1945 if (m
== MATCH_ERROR
)
1948 /* See if we have the first keyword argument. */
1951 m
= match_keyword_arg (tail
, head
, false);
1954 if (m
== MATCH_ERROR
)
1960 /* Try for a non-keyword argument. */
1961 m
= match_actual_arg (&tail
->expr
);
1962 if (m
== MATCH_ERROR
)
1971 if (gfc_match_char (')') == MATCH_YES
)
1973 if (gfc_match_char (',') != MATCH_YES
)
1978 matching_actual_arglist
--;
1982 gfc_error ("Syntax error in argument list at %C");
1985 gfc_free_actual_arglist (head
);
1986 gfc_current_locus
= old_loc
;
1987 matching_actual_arglist
--;
1992 /* Used by gfc_match_varspec() to extend the reference list by one
1996 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1998 if (primary
->ref
== NULL
)
1999 primary
->ref
= tail
= gfc_get_ref ();
2003 gfc_internal_error ("extend_ref(): Bad tail");
2004 tail
->next
= gfc_get_ref ();
2012 /* Used by gfc_match_varspec() to match an inquiry reference. */
2015 is_inquiry_ref (const char *name
, gfc_ref
**ref
)
2022 if (ref
) *ref
= NULL
;
2024 if (strcmp (name
, "re") == 0)
2026 else if (strcmp (name
, "im") == 0)
2028 else if (strcmp (name
, "kind") == 0)
2029 type
= INQUIRY_KIND
;
2030 else if (strcmp (name
, "len") == 0)
2037 *ref
= gfc_get_ref ();
2038 (*ref
)->type
= REF_INQUIRY
;
2046 /* Match any additional specifications associated with the current
2047 variable like member references or substrings. If equiv_flag is
2048 set we only match stuff that is allowed inside an EQUIVALENCE
2049 statement. sub_flag tells whether we expect a type-bound procedure found
2050 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
2051 components, 'ppc_arg' determines whether the PPC may be called (with an
2052 argument list), or whether it may just be referred to as a pointer. */
2055 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
2058 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2059 gfc_ref
*substring
, *tail
, *tmp
;
2060 gfc_component
*component
= NULL
;
2061 gfc_component
*previous
= NULL
;
2062 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
2063 gfc_expr
*tgt_expr
= NULL
;
2073 gfc_gobble_whitespace ();
2075 if (gfc_peek_ascii_char () == '[')
2077 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
2078 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2079 && CLASS_DATA (sym
)->attr
.dimension
))
2081 gfc_error ("Array section designator, e.g. '(:)', is required "
2082 "besides the coarray designator '[...]' at %C");
2085 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
2086 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2087 && !CLASS_DATA (sym
)->attr
.codimension
))
2089 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2095 if (sym
->assoc
&& sym
->assoc
->target
)
2096 tgt_expr
= sym
->assoc
->target
;
2098 /* For associate names, we may not yet know whether they are arrays or not.
2099 If the selector expression is unambiguously an array; eg. a full array
2100 or an array section, then the associate name must be an array and we can
2101 fix it now. Otherwise, if parentheses follow and it is not a character
2102 type, we have to assume that it actually is one for now. The final
2103 decision will be made at resolution, of course. */
2105 && gfc_peek_ascii_char () == '('
2106 && sym
->ts
.type
!= BT_CLASS
2107 && !sym
->attr
.dimension
)
2109 gfc_ref
*ref
= NULL
;
2111 if (!sym
->assoc
->dangling
&& tgt_expr
)
2113 if (tgt_expr
->expr_type
== EXPR_VARIABLE
)
2114 gfc_resolve_expr (tgt_expr
);
2116 ref
= tgt_expr
->ref
;
2117 for (; ref
; ref
= ref
->next
)
2118 if (ref
->type
== REF_ARRAY
2119 && (ref
->u
.ar
.type
== AR_FULL
2120 || ref
->u
.ar
.type
== AR_SECTION
))
2124 if (ref
|| (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
2126 && sym
->assoc
->st
->n
.sym
2127 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
2129 sym
->attr
.dimension
= 1;
2132 && sym
->assoc
->st
->n
.sym
2133 && sym
->assoc
->st
->n
.sym
->as
)
2134 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
2137 else if (sym
->ts
.type
== BT_CLASS
2139 && tgt_expr
->expr_type
== EXPR_VARIABLE
2140 && sym
->ts
.u
.derived
!= tgt_expr
->ts
.u
.derived
)
2142 gfc_resolve_expr (tgt_expr
);
2144 sym
->ts
.u
.derived
= tgt_expr
->ts
.u
.derived
;
2147 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
2148 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
2149 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
2150 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
2151 && !(gfc_matching_procptr_assignment
2152 && sym
->attr
.flavor
== FL_PROCEDURE
))
2153 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2154 && (CLASS_DATA (sym
)->attr
.dimension
2155 || CLASS_DATA (sym
)->attr
.codimension
)))
2159 tail
= extend_ref (primary
, tail
);
2160 tail
->type
= REF_ARRAY
;
2162 /* In EQUIVALENCE, we don't know yet whether we are seeing
2163 an array, character variable or array of character
2164 variables. We'll leave the decision till resolve time. */
2168 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2169 as
= CLASS_DATA (sym
)->as
;
2173 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
2174 as
? as
->corank
: 0);
2178 gfc_gobble_whitespace ();
2179 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
2181 tail
= extend_ref (primary
, tail
);
2182 tail
->type
= REF_ARRAY
;
2184 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2190 primary
->ts
= sym
->ts
;
2195 /* With DEC extensions, member separator may be '.' or '%'. */
2196 sep
= gfc_peek_ascii_char ();
2197 m
= gfc_match_member_sep (sym
);
2198 if (m
== MATCH_ERROR
)
2202 if (m
== MATCH_YES
&& sep
== '%'
2203 && primary
->ts
.type
!= BT_CLASS
2204 && primary
->ts
.type
!= BT_DERIVED
)
2207 old_loc
= gfc_current_locus
;
2208 mm
= gfc_match_name (name
);
2209 if (mm
== MATCH_YES
&& is_inquiry_ref (name
, &tmp
))
2211 gfc_current_locus
= old_loc
;
2214 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2215 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2216 gfc_set_default_type (sym
, 0, sym
->ns
);
2218 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2219 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2223 /* These target expressions can be resolved at any time. */
2224 permissible
= tgt_expr
&& tgt_expr
->symtree
&& tgt_expr
->symtree
->n
.sym
2225 && (tgt_expr
->symtree
->n
.sym
->attr
.use_assoc
2226 || tgt_expr
->symtree
->n
.sym
->attr
.host_assoc
2227 || tgt_expr
->symtree
->n
.sym
->attr
.if_source
2229 permissible
= permissible
2230 || (tgt_expr
&& tgt_expr
->expr_type
== EXPR_OP
);
2234 gfc_resolve_expr (tgt_expr
);
2235 sym
->ts
= tgt_expr
->ts
;
2238 if (sym
->ts
.type
== BT_UNKNOWN
)
2240 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2244 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2245 && m
== MATCH_YES
&& !inquiry
)
2247 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2252 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
&& !inquiry
)
2254 goto check_substring
;
2257 sym
= sym
->ts
.u
.derived
;
2266 m
= gfc_match_name (name
);
2268 gfc_error ("Expected structure component name at %C");
2273 if (primary
->ts
.type
!= BT_CLASS
&& primary
->ts
.type
!= BT_DERIVED
)
2275 inquiry
= is_inquiry_ref (name
, &tmp
);
2287 if (!gfc_notify_std (GFC_STD_F2008
,
2288 "RE or IM part_ref at %C"))
2293 if (!gfc_notify_std (GFC_STD_F2003
,
2294 "KIND part_ref at %C"))
2299 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2304 if ((tmp
->u
.i
== INQUIRY_RE
|| tmp
->u
.i
== INQUIRY_IM
)
2305 && primary
->ts
.type
!= BT_COMPLEX
)
2307 gfc_error ("The RE or IM part_ref at %C must be "
2308 "applied to a COMPLEX expression");
2311 else if (tmp
->u
.i
== INQUIRY_LEN
2312 && primary
->ts
.type
!= BT_CHARACTER
)
2314 gfc_error ("The LEN part_ref at %C must be applied "
2315 "to a CHARACTER expression");
2319 if (primary
->ts
.type
!= BT_UNKNOWN
)
2326 if (sym
&& sym
->f2k_derived
)
2327 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2333 gfc_symbol
* tbp_sym
;
2338 gcc_assert (!tail
|| !tail
->next
);
2340 if (!(primary
->expr_type
== EXPR_VARIABLE
2341 || (primary
->expr_type
== EXPR_STRUCTURE
2342 && primary
->symtree
&& primary
->symtree
->n
.sym
2343 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2346 if (tbp
->n
.tb
->is_generic
)
2349 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2351 primary
->expr_type
= EXPR_COMPCALL
;
2352 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2353 primary
->value
.compcall
.name
= tbp
->name
;
2354 primary
->value
.compcall
.ignore_pass
= 0;
2355 primary
->value
.compcall
.assign
= 0;
2356 primary
->value
.compcall
.base_object
= NULL
;
2357 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2359 primary
->ts
= tbp_sym
->ts
;
2361 gfc_clear_ts (&primary
->ts
);
2363 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2364 &primary
->value
.compcall
.actual
);
2365 if (m
== MATCH_ERROR
)
2370 primary
->value
.compcall
.actual
= NULL
;
2373 gfc_error ("Expected argument list at %C");
2381 previous
= component
;
2383 if (!inquiry
&& !intrinsic
)
2384 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2388 if (intrinsic
&& !inquiry
)
2391 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2392 "type component %qs", name
, previous
->name
);
2394 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2395 "type component", name
);
2398 else if (component
== NULL
&& !inquiry
)
2401 /* Extend the reference chain determined by gfc_find_component or
2403 if (primary
->ref
== NULL
)
2407 /* Set by the for loop below for the last component ref. */
2408 gcc_assert (tail
!= NULL
);
2412 /* The reference chain may be longer than one hop for union
2413 subcomponents; find the new tail. */
2414 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2417 if (tmp
&& tmp
->type
== REF_INQUIRY
)
2419 if (!primary
->where
.lb
|| !primary
->where
.nextc
)
2420 primary
->where
= gfc_current_locus
;
2421 gfc_simplify_expr (primary
, 0);
2423 if (primary
->expr_type
== EXPR_CONSTANT
)
2430 if (!gfc_notify_std (GFC_STD_F2008
, "RE or IM part_ref at %C"))
2433 if (primary
->ts
.type
!= BT_COMPLEX
)
2435 gfc_error ("The RE or IM part_ref at %C must be "
2436 "applied to a COMPLEX expression");
2439 primary
->ts
.type
= BT_REAL
;
2443 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2446 if (primary
->ts
.type
!= BT_CHARACTER
)
2448 gfc_error ("The LEN part_ref at %C must be applied "
2449 "to a CHARACTER expression");
2452 primary
->ts
.u
.cl
= NULL
;
2453 primary
->ts
.type
= BT_INTEGER
;
2454 primary
->ts
.kind
= gfc_default_integer_kind
;
2458 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
2461 if (primary
->ts
.type
== BT_CLASS
2462 || primary
->ts
.type
== BT_DERIVED
)
2464 gfc_error ("The KIND part_ref at %C must be applied "
2465 "to an expression of intrinsic type");
2468 primary
->ts
.type
= BT_INTEGER
;
2469 primary
->ts
.kind
= gfc_default_integer_kind
;
2479 primary
->ts
= component
->ts
;
2481 if (component
->attr
.proc_pointer
&& ppc_arg
)
2483 /* Procedure pointer component call: Look for argument list. */
2484 m
= gfc_match_actual_arglist (sub_flag
,
2485 &primary
->value
.compcall
.actual
);
2486 if (m
== MATCH_ERROR
)
2489 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2490 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2492 gfc_error ("Procedure pointer component %qs requires an "
2493 "argument list at %C", component
->name
);
2498 primary
->expr_type
= EXPR_PPC
;
2503 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2505 tail
= extend_ref (primary
, tail
);
2506 tail
->type
= REF_ARRAY
;
2508 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2509 component
->as
->corank
);
2513 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2514 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2516 tail
= extend_ref (primary
, tail
);
2517 tail
->type
= REF_ARRAY
;
2519 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2521 CLASS_DATA (component
)->as
->corank
);
2527 /* In principle, we could have eg. expr%re%kind so we must allow for
2528 this possibility. */
2529 if (gfc_match_char ('%') == MATCH_YES
)
2531 if (component
&& (component
->ts
.type
== BT_DERIVED
2532 || component
->ts
.type
== BT_CLASS
))
2533 sym
= component
->ts
.u
.derived
;
2539 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2540 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2543 if (component
->ts
.type
== BT_DERIVED
|| component
->ts
.type
== BT_CLASS
)
2544 sym
= component
->ts
.u
.derived
;
2549 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2551 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2553 gfc_set_default_type (sym
, 0, sym
->ns
);
2554 primary
->ts
= sym
->ts
;
2559 if (primary
->ts
.type
== BT_CHARACTER
)
2561 bool def
= primary
->ts
.deferred
== 1;
2562 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2566 primary
->ref
= substring
;
2568 tail
->next
= substring
;
2570 if (primary
->expr_type
== EXPR_CONSTANT
)
2571 primary
->expr_type
= EXPR_SUBSTRING
;
2574 primary
->ts
.u
.cl
= NULL
;
2581 gfc_clear_ts (&primary
->ts
);
2582 gfc_clear_ts (&sym
->ts
);
2592 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2593 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2595 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2600 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2602 gfc_error ("Coindexed procedure-pointer component at %C");
2610 /* Given an expression that is a variable, figure out what the
2611 ultimate variable's type and attribute is, traversing the reference
2612 structures if necessary.
2614 This subroutine is trickier than it looks. We start at the base
2615 symbol and store the attribute. Component references load a
2616 completely new attribute.
2618 A couple of rules come into play. Subobjects of targets are always
2619 targets themselves. If we see a component that goes through a
2620 pointer, then the expression must also be a target, since the
2621 pointer is associated with something (if it isn't core will soon be
2622 dumped). If we see a full part or section of an array, the
2623 expression is also an array.
2625 We can have at most one full array reference. */
2628 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2630 int dimension
, codimension
, pointer
, allocatable
, target
;
2631 symbol_attribute attr
;
2634 gfc_component
*comp
;
2635 bool has_inquiry_part
;
2637 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2638 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2640 sym
= expr
->symtree
->n
.sym
;
2643 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& sym
->ts
.u
.derived
)
2645 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2646 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2647 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2648 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2652 dimension
= attr
.dimension
;
2653 codimension
= attr
.codimension
;
2654 pointer
= attr
.pointer
;
2655 allocatable
= attr
.allocatable
;
2658 target
= attr
.target
;
2659 if (pointer
|| attr
.proc_pointer
)
2662 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2665 has_inquiry_part
= false;
2666 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2667 if (ref
->type
== REF_INQUIRY
)
2669 has_inquiry_part
= true;
2673 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2678 switch (ref
->u
.ar
.type
)
2685 allocatable
= pointer
= 0;
2690 /* Handle coarrays. */
2691 if (ref
->u
.ar
.dimen
> 0)
2692 allocatable
= pointer
= 0;
2696 /* For standard conforming code, AR_UNKNOWN should not happen.
2697 For nonconforming code, gfortran can end up here. Treat it
2705 comp
= ref
->u
.c
.component
;
2707 if (ts
!= NULL
&& !has_inquiry_part
)
2710 /* Don't set the string length if a substring reference
2712 if (ts
->type
== BT_CHARACTER
2713 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2717 if (comp
->ts
.type
== BT_CLASS
)
2719 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2720 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2721 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2725 codimension
= comp
->attr
.codimension
;
2726 pointer
= comp
->attr
.pointer
;
2727 allocatable
= comp
->attr
.allocatable
;
2729 if (pointer
|| attr
.proc_pointer
)
2736 allocatable
= pointer
= 0;
2740 attr
.dimension
= dimension
;
2741 attr
.codimension
= codimension
;
2742 attr
.pointer
= pointer
;
2743 attr
.allocatable
= allocatable
;
2744 attr
.target
= target
;
2745 attr
.save
= sym
->attr
.save
;
2751 /* Return the attribute from a general expression. */
2754 gfc_expr_attr (gfc_expr
*e
)
2756 symbol_attribute attr
;
2758 switch (e
->expr_type
)
2761 attr
= gfc_variable_attr (e
, NULL
);
2765 gfc_clear_attr (&attr
);
2767 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2769 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2771 if (sym
->ts
.type
== BT_CLASS
)
2773 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2774 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2775 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2778 else if (e
->value
.function
.isym
2779 && e
->value
.function
.isym
->transformational
2780 && e
->ts
.type
== BT_CLASS
)
2781 attr
= CLASS_DATA (e
)->attr
;
2782 else if (e
->symtree
)
2783 attr
= gfc_variable_attr (e
, NULL
);
2785 /* TODO: NULL() returns pointers. May have to take care of this
2791 gfc_clear_attr (&attr
);
2799 /* Given an expression, figure out what the ultimate expression
2800 attribute is. This routine is similar to gfc_variable_attr with
2801 parts of gfc_expr_attr, but focuses more on the needs of
2802 coarrays. For coarrays a codimension attribute is kind of
2803 "infectious" being propagated once set and never cleared.
2804 The coarray_comp is only set, when the expression refs a coarray
2805 component. REFS_COMP is set when present to true only, when this EXPR
2806 refs a (non-_data) component. To check whether EXPR refs an allocatable
2807 component in a derived type coarray *refs_comp needs to be set and
2808 coarray_comp has to false. */
2810 static symbol_attribute
2811 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2813 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2814 symbol_attribute attr
;
2817 gfc_component
*comp
;
2819 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2820 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2822 sym
= expr
->symtree
->n
.sym
;
2823 gfc_clear_attr (&attr
);
2828 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2830 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2831 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2832 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2833 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2834 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2835 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2839 dimension
= sym
->attr
.dimension
;
2840 codimension
= sym
->attr
.codimension
;
2841 pointer
= sym
->attr
.pointer
;
2842 allocatable
= sym
->attr
.allocatable
;
2843 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2844 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2845 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2846 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2849 target
= coarray_comp
= 0;
2850 if (pointer
|| attr
.proc_pointer
)
2853 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2858 switch (ref
->u
.ar
.type
)
2866 /* Handle coarrays. */
2867 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2868 allocatable
= pointer
= 0;
2872 /* If any of start, end or stride is not integer, there will
2873 already have been an error issued. */
2875 gfc_get_errors (NULL
, &errors
);
2877 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2883 comp
= ref
->u
.c
.component
;
2885 if (comp
->ts
.type
== BT_CLASS
)
2887 /* Set coarray_comp only, when this component introduces the
2889 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2890 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2891 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2892 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2896 /* Set coarray_comp only, when this component introduces the
2898 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2899 codimension
|= comp
->attr
.codimension
;
2900 pointer
= comp
->attr
.pointer
;
2901 allocatable
= comp
->attr
.allocatable
;
2904 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2905 && (ref
->next
== NULL
2906 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2909 if (pointer
|| attr
.proc_pointer
)
2916 allocatable
= pointer
= 0;
2920 attr
.dimension
= dimension
;
2921 attr
.codimension
= codimension
;
2922 attr
.pointer
= pointer
;
2923 attr
.allocatable
= allocatable
;
2924 attr
.target
= target
;
2925 attr
.save
= sym
->attr
.save
;
2926 attr
.coarray_comp
= coarray_comp
;
2933 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2935 symbol_attribute attr
;
2937 switch (e
->expr_type
)
2940 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2944 gfc_clear_attr (&attr
);
2946 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2948 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2950 if (sym
->ts
.type
== BT_CLASS
)
2952 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2953 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2954 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2955 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2956 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2957 ->attr
.pointer_comp
;
2960 else if (e
->symtree
)
2961 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2963 gfc_clear_attr (&attr
);
2967 gfc_clear_attr (&attr
);
2975 /* Match a structure constructor. The initial symbol has already been
2978 typedef struct gfc_structure_ctor_component
2983 struct gfc_structure_ctor_component
* next
;
2985 gfc_structure_ctor_component
;
2987 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2990 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2993 gfc_free_expr (comp
->val
);
2998 /* Translate the component list into the actual constructor by sorting it in
2999 the order required; this also checks along the way that each and every
3000 component actually has an initializer and handles default initializers
3001 for components without explicit value given. */
3003 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
3004 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
3006 gfc_structure_ctor_component
*comp_iter
;
3007 gfc_component
*comp
;
3009 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
3011 gfc_structure_ctor_component
**next_ptr
;
3012 gfc_expr
*value
= NULL
;
3014 /* Try to find the initializer for the current component by name. */
3015 next_ptr
= comp_head
;
3016 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3018 if (!strcmp (comp_iter
->name
, comp
->name
))
3020 next_ptr
= &comp_iter
->next
;
3023 /* If an extension, try building the parent derived type by building
3024 a value expression for the parent derived type and calling self. */
3025 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
3027 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
3029 &gfc_current_locus
);
3030 value
->ts
= comp
->ts
;
3032 if (!build_actual_constructor (comp_head
,
3033 &value
->value
.constructor
,
3034 comp
->ts
.u
.derived
))
3036 gfc_free_expr (value
);
3040 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3044 /* If it was not found, apply NULL expression to set the component as
3045 unallocated. Then try the default initializer if there's any;
3046 otherwise, it's an error unless this is a deferred parameter. */
3049 /* F2018 7.5.10: If an allocatable component has no corresponding
3050 component-data-source, then that component has an allocation
3051 status of unallocated.... */
3052 if (comp
->attr
.allocatable
3053 || (comp
->ts
.type
== BT_CLASS
3054 && CLASS_DATA (comp
)->attr
.allocatable
))
3056 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
3057 "allocatable component %qs given in the "
3058 "structure constructor at %C", comp
->name
))
3060 value
= gfc_get_null_expr (&gfc_current_locus
);
3062 /* ....(Preceeding sentence) If a component with default
3063 initialization has no corresponding component-data-source, then
3064 the default initialization is applied to that component. */
3065 else if (comp
->initializer
)
3067 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
3068 "with missing optional arguments at %C"))
3070 value
= gfc_copy_expr (comp
->initializer
);
3072 /* Do not trap components such as the string length for deferred
3073 length character components. */
3074 else if (!comp
->attr
.artificial
)
3076 gfc_error ("No initializer for component %qs given in the"
3077 " structure constructor at %C", comp
->name
);
3082 value
= comp_iter
->val
;
3084 /* Add the value to the constructor chain built. */
3085 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3087 /* Remove the entry from the component list. We don't want the expression
3088 value to be free'd, so set it to NULL. */
3091 *next_ptr
= comp_iter
->next
;
3092 comp_iter
->val
= NULL
;
3093 gfc_free_structure_ctor_component (comp_iter
);
3101 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
3102 gfc_actual_arglist
**arglist
,
3105 gfc_actual_arglist
*actual
;
3106 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
3107 gfc_constructor_base ctor_head
= NULL
;
3108 gfc_component
*comp
; /* Is set NULL when named component is first seen */
3109 const char* last_name
= NULL
;
3113 expr
= parent
? *cexpr
: e
;
3114 old_locus
= gfc_current_locus
;
3116 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3118 gfc_current_locus
= expr
->where
;
3120 comp_tail
= comp_head
= NULL
;
3122 if (!parent
&& sym
->attr
.abstract
)
3124 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3125 sym
->name
, &expr
->where
);
3129 comp
= sym
->components
;
3130 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
3133 gfc_component
*this_comp
= NULL
;
3136 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
3139 comp_tail
->next
= gfc_get_structure_ctor_component ();
3140 comp_tail
= comp_tail
->next
;
3144 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
3145 " constructor with named arguments at %C"))
3148 comp_tail
->name
= xstrdup (actual
->name
);
3149 last_name
= comp_tail
->name
;
3154 /* Components without name are not allowed after the first named
3155 component initializer! */
3156 if (!comp
|| comp
->attr
.artificial
)
3159 gfc_error ("Component initializer without name after component"
3160 " named %s at %L", last_name
,
3161 actual
->expr
? &actual
->expr
->where
3162 : &gfc_current_locus
);
3164 gfc_error ("Too many components in structure constructor at "
3165 "%L", actual
->expr
? &actual
->expr
->where
3166 : &gfc_current_locus
);
3170 comp_tail
->name
= xstrdup (comp
->name
);
3173 /* Find the current component in the structure definition and check
3174 its access is not private. */
3176 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
3179 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
3180 false, false, NULL
);
3181 comp
= NULL
; /* Reset needed! */
3184 /* Here we can check if a component name is given which does not
3185 correspond to any component of the defined structure. */
3189 /* For a constant string constructor, make sure the length is
3190 correct; truncate of fill with blanks if needed. */
3191 if (this_comp
->ts
.type
== BT_CHARACTER
&& !this_comp
->attr
.allocatable
3192 && this_comp
->ts
.u
.cl
&& this_comp
->ts
.u
.cl
->length
3193 && this_comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3194 && actual
->expr
->ts
.type
== BT_CHARACTER
3195 && actual
->expr
->expr_type
== EXPR_CONSTANT
)
3198 c
= gfc_mpz_get_hwi (this_comp
->ts
.u
.cl
->length
->value
.integer
);
3199 e1
= actual
->expr
->value
.character
.length
;
3205 dest
= gfc_get_wide_string (c
+ 1);
3207 to
= e1
< c
? e1
: c
;
3208 for (i
= 0; i
< to
; i
++)
3209 dest
[i
] = actual
->expr
->value
.character
.string
[i
];
3211 for (i
= e1
; i
< c
; i
++)
3215 free (actual
->expr
->value
.character
.string
);
3217 actual
->expr
->value
.character
.length
= c
;
3218 actual
->expr
->value
.character
.string
= dest
;
3220 if (warn_line_truncation
&& c
< e1
)
3221 gfc_warning_now (OPT_Wcharacter_truncation
,
3222 "CHARACTER expression will be truncated "
3223 "in constructor (%ld/%ld) at %L", (long int) c
,
3224 (long int) e1
, &actual
->expr
->where
);
3228 comp_tail
->val
= actual
->expr
;
3229 if (actual
->expr
!= NULL
)
3230 comp_tail
->where
= actual
->expr
->where
;
3231 actual
->expr
= NULL
;
3233 /* Check if this component is already given a value. */
3234 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
3235 comp_iter
= comp_iter
->next
)
3237 gcc_assert (comp_iter
);
3238 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
3240 gfc_error ("Component %qs is initialized twice in the structure"
3241 " constructor at %L", comp_tail
->name
,
3242 comp_tail
->val
? &comp_tail
->where
3243 : &gfc_current_locus
);
3248 /* F2008, R457/C725, for PURE C1283. */
3249 if (this_comp
->attr
.pointer
&& comp_tail
->val
3250 && gfc_is_coindexed (comp_tail
->val
))
3252 gfc_error ("Coindexed expression to pointer component %qs in "
3253 "structure constructor at %L", comp_tail
->name
,
3258 /* If not explicitly a parent constructor, gather up the components
3260 if (comp
&& comp
== sym
->components
3261 && sym
->attr
.extension
3263 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
3265 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
3268 gfc_actual_arglist
*arg_null
= NULL
;
3270 actual
->expr
= comp_tail
->val
;
3271 comp_tail
->val
= NULL
;
3273 m
= gfc_convert_to_structure_constructor (NULL
,
3274 comp
->ts
.u
.derived
, &comp_tail
->val
,
3275 comp
->ts
.u
.derived
->attr
.zero_comp
3276 ? &arg_null
: &actual
, true);
3280 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
3289 if (parent
&& !comp
)
3293 actual
= actual
->next
;
3296 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
3299 /* No component should be left, as this should have caused an error in the
3300 loop constructing the component-list (name that does not correspond to any
3301 component in the structure definition). */
3302 if (comp_head
&& sym
->attr
.extension
)
3304 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3306 gfc_error ("component %qs at %L has already been set by a "
3307 "parent derived type constructor", comp_iter
->name
,
3313 gcc_assert (!comp_head
);
3317 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
3318 expr
->ts
.u
.derived
= sym
;
3319 expr
->value
.constructor
= ctor_head
;
3324 expr
->ts
.u
.derived
= sym
;
3326 expr
->ts
.type
= BT_DERIVED
;
3327 expr
->value
.constructor
= ctor_head
;
3328 expr
->expr_type
= EXPR_STRUCTURE
;
3331 gfc_current_locus
= old_locus
;
3337 gfc_current_locus
= old_locus
;
3339 for (comp_iter
= comp_head
; comp_iter
; )
3341 gfc_structure_ctor_component
*next
= comp_iter
->next
;
3342 gfc_free_structure_ctor_component (comp_iter
);
3345 gfc_constructor_free (ctor_head
);
3352 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
3356 gfc_symtree
*symtree
;
3358 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
3360 e
= gfc_get_expr ();
3361 e
->symtree
= symtree
;
3362 e
->expr_type
= EXPR_FUNCTION
;
3363 e
->where
= gfc_current_locus
;
3365 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
3366 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
3367 e
->value
.function
.esym
= sym
;
3368 e
->symtree
->n
.sym
->attr
.generic
= 1;
3370 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3377 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
3383 /* If a structure constructor is in a DATA statement, then each entity
3384 in the structure constructor must be a constant. Try to reduce the
3386 if (gfc_in_match_data ())
3387 gfc_reduce_init_expr (e
);
3394 /* If the symbol is an implicit do loop index and implicitly typed,
3395 it should not be host associated. Provide a symtree from the
3396 current namespace. */
3398 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
3400 if ((*sym
)->attr
.flavor
== FL_VARIABLE
3401 && (*sym
)->ns
!= gfc_current_ns
3402 && (*sym
)->attr
.implied_index
3403 && (*sym
)->attr
.implicit_type
3404 && !(*sym
)->attr
.use_assoc
)
3407 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
3410 *sym
= (*st
)->n
.sym
;
3416 /* Procedure pointer as function result: Replace the function symbol by the
3417 auto-generated hidden result variable named "ppr@". */
3420 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
3422 /* Check for procedure pointer result variable. */
3423 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
3424 && (*sym
)->result
&& (*sym
)->result
!= *sym
3425 && (*sym
)->result
->attr
.proc_pointer
3426 && (*sym
) == gfc_current_ns
->proc_name
3427 && (*sym
) == (*sym
)->result
->ns
->proc_name
3428 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3430 /* Automatic replacement with "hidden" result variable. */
3431 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3432 *sym
= (*sym
)->result
;
3433 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3440 /* Matches a variable name followed by anything that might follow it--
3441 array reference, argument list of a function, etc. */
3444 gfc_match_rvalue (gfc_expr
**result
)
3446 gfc_actual_arglist
*actual_arglist
;
3447 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3450 gfc_symtree
*symtree
;
3451 locus where
, old_loc
;
3459 m
= gfc_match ("%%loc");
3462 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3464 strncpy (name
, "loc", 4);
3469 m
= gfc_match_name (name
);
3474 /* Check if the symbol exists. */
3475 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3478 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3479 type. For derived types we create a generic symbol which links to the
3480 derived type symbol; STRUCTUREs are simpler and must not conflict with
3483 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3485 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3487 if (gfc_find_state (COMP_INTERFACE
)
3488 && !gfc_current_ns
->has_import_set
)
3489 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3491 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3497 sym
= symtree
->n
.sym
;
3499 where
= gfc_current_locus
;
3501 replace_hidden_procptr_result (&sym
, &symtree
);
3503 /* If this is an implicit do loop index and implicitly typed,
3504 it should not be host associated. */
3505 m
= check_for_implicit_index (&symtree
, &sym
);
3509 gfc_set_sym_referenced (sym
);
3510 sym
->attr
.implied_index
= 0;
3512 if (sym
->attr
.function
&& sym
->result
== sym
)
3514 /* See if this is a directly recursive function call. */
3515 gfc_gobble_whitespace ();
3516 if (sym
->attr
.recursive
3517 && gfc_peek_ascii_char () == '('
3518 && gfc_current_ns
->proc_name
== sym
3519 && !sym
->attr
.dimension
)
3521 gfc_error ("%qs at %C is the name of a recursive function "
3522 "and so refers to the result variable. Use an "
3523 "explicit RESULT variable for direct recursion "
3524 "(12.5.2.1)", sym
->name
);
3528 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3532 && (sym
->ns
== gfc_current_ns
3533 || sym
->ns
== gfc_current_ns
->parent
))
3535 gfc_entry_list
*el
= NULL
;
3537 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3543 if (gfc_matching_procptr_assignment
)
3545 /* It can be a procedure or a derived-type procedure or a not-yet-known
3547 if (sym
->attr
.flavor
!= FL_UNKNOWN
3548 && sym
->attr
.flavor
!= FL_PROCEDURE
3549 && sym
->attr
.flavor
!= FL_PARAMETER
3550 && sym
->attr
.flavor
!= FL_VARIABLE
)
3552 gfc_error ("Symbol at %C is not appropriate for an expression");
3558 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3561 if (sym
->attr
.generic
)
3562 goto generic_function
;
3564 switch (sym
->attr
.flavor
)
3568 e
= gfc_get_expr ();
3570 e
->expr_type
= EXPR_VARIABLE
;
3571 e
->symtree
= symtree
;
3573 m
= gfc_match_varspec (e
, 0, false, true);
3577 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3578 end up here. Unfortunately, sym->value->expr_type is set to
3579 EXPR_CONSTANT, and so the if () branch would be followed without
3580 the !sym->as check. */
3581 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3582 e
= gfc_copy_expr (sym
->value
);
3585 e
= gfc_get_expr ();
3586 e
->expr_type
= EXPR_VARIABLE
;
3589 e
->symtree
= symtree
;
3590 m
= gfc_match_varspec (e
, 0, false, true);
3592 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3595 /* Variable array references to derived type parameters cause
3596 all sorts of headaches in simplification. Treating such
3597 expressions as variable works just fine for all array
3599 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3601 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3602 if (ref
->type
== REF_ARRAY
)
3605 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3611 e
= gfc_get_expr ();
3612 e
->expr_type
= EXPR_VARIABLE
;
3613 e
->symtree
= symtree
;
3621 sym
= gfc_use_derived (sym
);
3625 goto generic_function
;
3628 /* If we're here, then the name is known to be the name of a
3629 procedure, yet it is not sure to be the name of a function. */
3632 /* Procedure Pointer Assignments. */
3634 if (gfc_matching_procptr_assignment
)
3636 gfc_gobble_whitespace ();
3637 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3638 /* Parse functions returning a procptr. */
3641 e
= gfc_get_expr ();
3642 e
->expr_type
= EXPR_VARIABLE
;
3643 e
->symtree
= symtree
;
3644 m
= gfc_match_varspec (e
, 0, false, true);
3645 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3646 && sym
->ts
.type
== BT_UNKNOWN
3647 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3655 if (sym
->attr
.subroutine
)
3657 gfc_error ("Unexpected use of subroutine name %qs at %C",
3663 /* At this point, the name has to be a non-statement function.
3664 If the name is the same as the current function being
3665 compiled, then we have a variable reference (to the function
3666 result) if the name is non-recursive. */
3668 st
= gfc_enclosing_unit (NULL
);
3671 && st
->state
== COMP_FUNCTION
3673 && !sym
->attr
.recursive
)
3675 e
= gfc_get_expr ();
3676 e
->symtree
= symtree
;
3677 e
->expr_type
= EXPR_VARIABLE
;
3679 m
= gfc_match_varspec (e
, 0, false, true);
3683 /* Match a function reference. */
3685 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3688 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3689 gfc_error ("Statement function %qs requires argument list at %C",
3692 gfc_error ("Function %qs requires an argument list at %C",
3705 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3706 sym
= symtree
->n
.sym
;
3708 replace_hidden_procptr_result (&sym
, &symtree
);
3710 e
= gfc_get_expr ();
3711 e
->symtree
= symtree
;
3712 e
->expr_type
= EXPR_FUNCTION
;
3713 e
->value
.function
.actual
= actual_arglist
;
3714 e
->where
= gfc_current_locus
;
3716 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3717 && CLASS_DATA (sym
)->as
)
3718 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3719 else if (sym
->as
!= NULL
)
3720 e
->rank
= sym
->as
->rank
;
3722 if (!sym
->attr
.function
3723 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3729 /* Check here for the existence of at least one argument for the
3730 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3731 argument(s) given will be checked in gfc_iso_c_func_interface,
3732 during resolution of the function call. */
3733 if (sym
->attr
.is_iso_c
== 1
3734 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3735 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3736 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3737 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3739 /* make sure we were given a param */
3740 if (actual_arglist
== NULL
)
3742 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3748 if (sym
->result
== NULL
)
3751 gfc_gobble_whitespace ();
3753 if (gfc_peek_ascii_char() == '%')
3755 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3756 "function reference at %C");
3766 /* Special case for derived type variables that get their types
3767 via an IMPLICIT statement. This can't wait for the
3768 resolution phase. */
3770 old_loc
= gfc_current_locus
;
3771 if (gfc_match_member_sep (sym
) == MATCH_YES
3772 && sym
->ts
.type
== BT_UNKNOWN
3773 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3774 gfc_set_default_type (sym
, 0, sym
->ns
);
3775 gfc_current_locus
= old_loc
;
3777 /* If the symbol has a (co)dimension attribute, the expression is a
3780 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3782 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3788 e
= gfc_get_expr ();
3789 e
->symtree
= symtree
;
3790 e
->expr_type
= EXPR_VARIABLE
;
3791 m
= gfc_match_varspec (e
, 0, false, true);
3795 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3796 && (CLASS_DATA (sym
)->attr
.dimension
3797 || CLASS_DATA (sym
)->attr
.codimension
))
3799 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3805 e
= gfc_get_expr ();
3806 e
->symtree
= symtree
;
3807 e
->expr_type
= EXPR_VARIABLE
;
3808 m
= gfc_match_varspec (e
, 0, false, true);
3812 /* Name is not an array, so we peek to see if a '(' implies a
3813 function call or a substring reference. Otherwise the
3814 variable is just a scalar. */
3816 gfc_gobble_whitespace ();
3817 if (gfc_peek_ascii_char () != '(')
3819 /* Assume a scalar variable */
3820 e
= gfc_get_expr ();
3821 e
->symtree
= symtree
;
3822 e
->expr_type
= EXPR_VARIABLE
;
3824 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3830 /*FIXME:??? gfc_match_varspec does set this for us: */
3832 m
= gfc_match_varspec (e
, 0, false, true);
3836 /* See if this is a function reference with a keyword argument
3837 as first argument. We do this because otherwise a spurious
3838 symbol would end up in the symbol table. */
3840 old_loc
= gfc_current_locus
;
3841 m2
= gfc_match (" ( %n =", argname
);
3842 gfc_current_locus
= old_loc
;
3844 e
= gfc_get_expr ();
3845 e
->symtree
= symtree
;
3847 if (m2
!= MATCH_YES
)
3849 /* Try to figure out whether we're dealing with a character type.
3850 We're peeking ahead here, because we don't want to call
3851 match_substring if we're dealing with an implicitly typed
3852 non-character variable. */
3853 implicit_char
= false;
3854 if (sym
->ts
.type
== BT_UNKNOWN
)
3856 ts
= gfc_get_default_type (sym
->name
, NULL
);
3857 if (ts
->type
== BT_CHARACTER
)
3858 implicit_char
= true;
3861 /* See if this could possibly be a substring reference of a name
3862 that we're not sure is a variable yet. */
3864 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3865 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3868 e
->expr_type
= EXPR_VARIABLE
;
3870 if (sym
->attr
.flavor
!= FL_VARIABLE
3871 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3878 if (sym
->ts
.type
== BT_UNKNOWN
3879 && !gfc_set_default_type (sym
, 1, NULL
))
3893 /* Give up, assume we have a function. */
3895 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3896 sym
= symtree
->n
.sym
;
3897 e
->expr_type
= EXPR_FUNCTION
;
3899 if (!sym
->attr
.function
3900 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3908 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3910 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3918 /* If our new function returns a character, array or structure
3919 type, it might have subsequent references. */
3921 m
= gfc_match_varspec (e
, 0, false, true);
3928 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3929 specially. Creates a generic symbol for derived types. */
3930 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3932 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3933 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3934 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3936 e
= gfc_get_expr ();
3937 e
->symtree
= symtree
;
3938 e
->expr_type
= EXPR_FUNCTION
;
3940 if (gfc_fl_struct (sym
->attr
.flavor
))
3942 e
->value
.function
.esym
= sym
;
3943 e
->symtree
->n
.sym
->attr
.generic
= 1;
3946 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3954 gfc_error ("Symbol at %C is not appropriate for an expression");
3970 /* Match a variable, i.e. something that can be assigned to. This
3971 starts as a symbol, can be a structure component or an array
3972 reference. It can be a function if the function doesn't have a
3973 separate RESULT variable. If the symbol has not been previously
3974 seen, we assume it is a variable.
3976 This function is called by two interface functions:
3977 gfc_match_variable, which has host_flag = 1, and
3978 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3979 match of the symbol to the local scope. */
3982 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3984 gfc_symbol
*sym
, *dt_sym
;
3987 locus where
, old_loc
;
3990 /* Since nothing has any business being an lvalue in a module
3991 specification block, an interface block or a contains section,
3992 we force the changed_symbols mechanism to work by setting
3993 host_flag to 0. This prevents valid symbols that have the name
3994 of keywords, such as 'end', being turned into variables by
3995 failed matching to assignments for, e.g., END INTERFACE. */
3996 if (gfc_current_state () == COMP_MODULE
3997 || gfc_current_state () == COMP_SUBMODULE
3998 || gfc_current_state () == COMP_INTERFACE
3999 || gfc_current_state () == COMP_CONTAINS
)
4002 where
= gfc_current_locus
;
4003 m
= gfc_match_sym_tree (&st
, host_flag
);
4009 /* If this is an implicit do loop index and implicitly typed,
4010 it should not be host associated. */
4011 m
= check_for_implicit_index (&st
, &sym
);
4015 sym
->attr
.implied_index
= 0;
4017 gfc_set_sym_referenced (sym
);
4019 /* STRUCTUREs may share names with variables, but derived types may not. */
4020 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
4021 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
4023 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
4024 gfc_error ("Derived type %qs cannot be used as a variable at %C",
4029 switch (sym
->attr
.flavor
)
4032 /* Everything is alright. */
4037 sym_flavor flavor
= FL_UNKNOWN
;
4039 gfc_gobble_whitespace ();
4041 if (sym
->attr
.external
|| sym
->attr
.procedure
4042 || sym
->attr
.function
|| sym
->attr
.subroutine
)
4043 flavor
= FL_PROCEDURE
;
4045 /* If it is not a procedure, is not typed and is host associated,
4046 we cannot give it a flavor yet. */
4047 else if (sym
->ns
== gfc_current_ns
->parent
4048 && sym
->ts
.type
== BT_UNKNOWN
)
4051 /* These are definitive indicators that this is a variable. */
4052 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
4053 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
4054 flavor
= FL_VARIABLE
;
4056 if (flavor
!= FL_UNKNOWN
4057 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
4065 gfc_error ("Named constant at %C in an EQUIVALENCE");
4068 /* Otherwise this is checked for and an error given in the
4069 variable definition context checks. */
4073 /* Check for a nonrecursive function result variable. */
4074 if (sym
->attr
.function
4075 && !sym
->attr
.external
4076 && sym
->result
== sym
4077 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
4079 && sym
->ns
== gfc_current_ns
)
4081 && sym
->ns
== gfc_current_ns
->parent
)))
4083 /* If a function result is a derived type, then the derived
4084 type may still have to be resolved. */
4086 if (sym
->ts
.type
== BT_DERIVED
4087 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
4092 if (sym
->attr
.proc_pointer
4093 || replace_hidden_procptr_result (&sym
, &st
))
4096 /* Fall through to error */
4100 gfc_error ("%qs at %C is not a variable", sym
->name
);
4104 /* Special case for derived type variables that get their types
4105 via an IMPLICIT statement. This can't wait for the
4106 resolution phase. */
4109 gfc_namespace
* implicit_ns
;
4111 if (gfc_current_ns
->proc_name
== sym
)
4112 implicit_ns
= gfc_current_ns
;
4114 implicit_ns
= sym
->ns
;
4116 old_loc
= gfc_current_locus
;
4117 if (gfc_match_member_sep (sym
) == MATCH_YES
4118 && sym
->ts
.type
== BT_UNKNOWN
4119 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
4120 gfc_set_default_type (sym
, 0, implicit_ns
);
4121 gfc_current_locus
= old_loc
;
4124 expr
= gfc_get_expr ();
4126 expr
->expr_type
= EXPR_VARIABLE
;
4129 expr
->where
= where
;
4131 /* Now see if we have to do more. */
4132 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
4135 gfc_free_expr (expr
);
4145 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
4147 return match_variable (result
, equiv_flag
, 1);
4152 gfc_match_equiv_variable (gfc_expr
**result
)
4154 return match_variable (result
, 1, 0);