1 /* Primary expression subroutines
2 Copyright (C) 2000-2020 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 ("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 ("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
);
674 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
678 kind
= gfc_default_double_kind
;
682 if (flag_real4_kind
== 8)
684 if (flag_real4_kind
== 10)
686 if (flag_real4_kind
== 16)
692 if (flag_real8_kind
== 4)
694 if (flag_real8_kind
== 10)
696 if (flag_real8_kind
== 16)
704 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
709 /* The maximum possible real kind type parameter is 16. First, try
710 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
711 extended precision. If neither value works, just given up. */
713 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
716 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
718 gfc_error ("Invalid exponent-letter %<q%> in "
719 "real-literal-constant at %C");
727 kind
= gfc_default_real_kind
;
731 if (flag_real4_kind
== 8)
733 if (flag_real4_kind
== 10)
735 if (flag_real4_kind
== 16)
741 if (flag_real8_kind
== 4)
743 if (flag_real8_kind
== 10)
745 if (flag_real8_kind
== 16)
749 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
751 gfc_error ("Invalid real kind %d at %C", kind
);
756 e
= convert_real (buffer
, kind
, &gfc_current_locus
);
758 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
759 e
->ts
.is_c_interop
= is_iso_c
;
761 switch (gfc_range_check (e
))
766 gfc_error ("Real constant overflows its kind at %C");
769 case ARITH_UNDERFLOW
:
771 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
772 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
776 gfc_internal_error ("gfc_range_check() returned bad value");
779 /* Warn about trailing digits which suggest the user added too many
780 trailing digits, which may cause the appearance of higher pecision
781 than the kind kan support.
783 This is done by replacing the rightmost non-zero digit with zero
784 and comparing with the original value. If these are equal, we
785 assume the user supplied more digits than intended (or forgot to
786 convert to the correct kind).
789 if (warn_conversion_extra
)
795 c1
= strchr (buffer
, 'e');
797 c1
= buffer
+ strlen(buffer
);
800 for (p
= c1
; p
> buffer
;)
817 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
819 mpfr_neg (r
, r
, GFC_RND_MODE
);
821 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
823 if (mpfr_cmp_ui (r
, 0) == 0)
824 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
825 "in %qs number at %C, maybe incorrect KIND",
826 gfc_typename (&e
->ts
));
841 /* Match a substring reference. */
844 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
, bool deferred
)
846 gfc_expr
*start
, *end
;
854 old_loc
= gfc_current_locus
;
856 m
= gfc_match_char ('(');
860 if (gfc_match_char (':') != MATCH_YES
)
863 m
= gfc_match_init_expr (&start
);
865 m
= gfc_match_expr (&start
);
873 m
= gfc_match_char (':');
878 if (gfc_match_char (')') != MATCH_YES
)
881 m
= gfc_match_init_expr (&end
);
883 m
= gfc_match_expr (&end
);
887 if (m
== MATCH_ERROR
)
890 m
= gfc_match_char (')');
895 /* Optimize away the (:) reference. */
896 if (start
== NULL
&& end
== NULL
&& !deferred
)
900 ref
= gfc_get_ref ();
902 ref
->type
= REF_SUBSTRING
;
904 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
905 ref
->u
.ss
.start
= start
;
906 if (end
== NULL
&& cl
)
907 end
= gfc_copy_expr (cl
->length
);
909 ref
->u
.ss
.length
= cl
;
916 gfc_error ("Syntax error in SUBSTRING specification at %C");
920 gfc_free_expr (start
);
923 gfc_current_locus
= old_loc
;
928 /* Reads the next character of a string constant, taking care to
929 return doubled delimiters on the input as a single instance of
932 Special return values for "ret" argument are:
933 -1 End of the string, as determined by the delimiter
934 -2 Unterminated string detected
936 Backslash codes are also expanded at this time. */
939 next_string_char (gfc_char_t delimiter
, int *ret
)
944 c
= gfc_next_char_literal (INSTRING_WARN
);
953 if (flag_backslash
&& c
== '\\')
955 old_locus
= gfc_current_locus
;
957 if (gfc_match_special_char (&c
) == MATCH_NO
)
958 gfc_current_locus
= old_locus
;
960 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
961 gfc_warning (0, "Extension: backslash character at %C");
967 old_locus
= gfc_current_locus
;
968 c
= gfc_next_char_literal (NONSTRING
);
972 gfc_current_locus
= old_locus
;
979 /* Special case of gfc_match_name() that matches a parameter kind name
980 before a string constant. This takes case of the weird but legal
985 where kind____ is a parameter. gfc_match_name() will happily slurp
986 up all the underscores, which leads to problems. If we return
987 MATCH_YES, the parse pointer points to the final underscore, which
988 is not part of the name. We never return MATCH_ERROR-- errors in
989 the name will be detected later. */
992 match_charkind_name (char *name
)
998 gfc_gobble_whitespace ();
999 c
= gfc_next_ascii_char ();
1008 old_loc
= gfc_current_locus
;
1009 c
= gfc_next_ascii_char ();
1013 peek
= gfc_peek_ascii_char ();
1015 if (peek
== '\'' || peek
== '\"')
1017 gfc_current_locus
= old_loc
;
1025 && (c
!= '$' || !flag_dollar_ok
))
1029 if (++len
> GFC_MAX_SYMBOL_LEN
)
1037 /* See if the current input matches a character constant. Lots of
1038 contortions have to be done to match the kind parameter which comes
1039 before the actual string. The main consideration is that we don't
1040 want to error out too quickly. For example, we don't actually do
1041 any validation of the kinds until we have actually seen a legal
1042 delimiter. Using match_kind_param() generates errors too quickly. */
1045 match_string_constant (gfc_expr
**result
)
1047 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1049 int kind
,save_warn_ampersand
, ret
;
1050 locus old_locus
, start_locus
;
1054 gfc_char_t c
, delimiter
, *p
;
1056 old_locus
= gfc_current_locus
;
1058 gfc_gobble_whitespace ();
1060 c
= gfc_next_char ();
1061 if (c
== '\'' || c
== '"')
1063 kind
= gfc_default_character_kind
;
1064 start_locus
= gfc_current_locus
;
1068 if (gfc_wide_is_digit (c
))
1072 while (gfc_wide_is_digit (c
))
1074 kind
= kind
* 10 + c
- '0';
1077 c
= gfc_next_char ();
1083 gfc_current_locus
= old_locus
;
1085 m
= match_charkind_name (name
);
1089 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1091 || sym
->attr
.flavor
!= FL_PARAMETER
)
1095 c
= gfc_next_char ();
1100 gfc_gobble_whitespace ();
1101 c
= gfc_next_char ();
1107 gfc_gobble_whitespace ();
1109 c
= gfc_next_char ();
1110 if (c
!= '\'' && c
!= '"')
1113 start_locus
= gfc_current_locus
;
1117 if (gfc_extract_int (sym
->value
, &kind
, 1))
1119 gfc_set_sym_referenced (sym
);
1122 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1124 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1129 /* Scan the string into a block of memory by first figuring out how
1130 long it is, allocating the structure, then re-reading it. This
1131 isn't particularly efficient, but string constants aren't that
1132 common in most code. TODO: Use obstacks? */
1139 c
= next_string_char (delimiter
, &ret
);
1144 gfc_current_locus
= start_locus
;
1145 gfc_error ("Unterminated character constant beginning at %C");
1152 /* Peek at the next character to see if it is a b, o, z, or x for the
1153 postfixed BOZ literal constants. */
1154 peek
= gfc_peek_ascii_char ();
1155 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1158 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1160 gfc_current_locus
= start_locus
;
1162 /* We disable the warning for the following loop as the warning has already
1163 been printed in the loop above. */
1164 save_warn_ampersand
= warn_ampersand
;
1165 warn_ampersand
= false;
1167 p
= e
->value
.character
.string
;
1168 for (size_t i
= 0; i
< length
; i
++)
1170 c
= next_string_char (delimiter
, &ret
);
1172 if (!gfc_check_character_range (c
, kind
))
1175 gfc_error ("Character %qs in string at %C is not representable "
1176 "in character kind %d", gfc_print_wide_char (c
), kind
);
1183 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1184 warn_ampersand
= save_warn_ampersand
;
1186 next_string_char (delimiter
, &ret
);
1188 gfc_internal_error ("match_string_constant(): Delimiter not found");
1190 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1191 e
->expr_type
= EXPR_SUBSTRING
;
1198 gfc_current_locus
= old_locus
;
1203 /* Match a .true. or .false. Returns 1 if a .true. was found,
1204 0 if a .false. was found, and -1 otherwise. */
1206 match_logical_constant_string (void)
1208 locus orig_loc
= gfc_current_locus
;
1210 gfc_gobble_whitespace ();
1211 if (gfc_next_ascii_char () == '.')
1213 char ch
= gfc_next_ascii_char ();
1216 if (gfc_next_ascii_char () == 'a'
1217 && gfc_next_ascii_char () == 'l'
1218 && gfc_next_ascii_char () == 's'
1219 && gfc_next_ascii_char () == 'e'
1220 && gfc_next_ascii_char () == '.')
1221 /* Matched ".false.". */
1226 if (gfc_next_ascii_char () == 'r'
1227 && gfc_next_ascii_char () == 'u'
1228 && gfc_next_ascii_char () == 'e'
1229 && gfc_next_ascii_char () == '.')
1230 /* Matched ".true.". */
1234 gfc_current_locus
= orig_loc
;
1238 /* Match a .true. or .false. */
1241 match_logical_constant (gfc_expr
**result
)
1244 int i
, kind
, is_iso_c
;
1246 i
= match_logical_constant_string ();
1250 kind
= get_kind (&is_iso_c
);
1254 kind
= gfc_default_logical_kind
;
1256 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1258 gfc_error ("Bad kind for logical constant at %C");
1262 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1263 e
->ts
.is_c_interop
= is_iso_c
;
1270 /* Match a real or imaginary part of a complex constant that is a
1271 symbolic constant. */
1274 match_sym_complex_part (gfc_expr
**result
)
1276 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1281 m
= gfc_match_name (name
);
1285 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1288 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1290 /* Give the matcher for implied do-loops a chance to run. This yields
1291 a much saner error message for "write(*,*) (i, i=1, 6" where the
1292 right parenthesis is missing. */
1294 gfc_gobble_whitespace ();
1295 c
= gfc_peek_ascii_char ();
1296 if (c
== '=' || c
== ',')
1302 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1311 if (!gfc_numeric_ts (&sym
->value
->ts
))
1313 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1317 if (sym
->value
->rank
!= 0)
1319 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1323 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1324 "complex constant at %C"))
1327 switch (sym
->value
->ts
.type
)
1330 e
= gfc_copy_expr (sym
->value
);
1334 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1340 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1346 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1349 *result
= e
; /* e is a scalar, real, constant expression. */
1353 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1358 /* Match a real or imaginary part of a complex number. */
1361 match_complex_part (gfc_expr
**result
)
1365 m
= match_sym_complex_part (result
);
1369 m
= match_real_constant (result
, 1);
1373 return match_integer_constant (result
, 1);
1377 /* Try to match a complex constant. */
1380 match_complex_constant (gfc_expr
**result
)
1382 gfc_expr
*e
, *real
, *imag
;
1383 gfc_error_buffer old_error
;
1384 gfc_typespec target
;
1389 old_loc
= gfc_current_locus
;
1390 real
= imag
= e
= NULL
;
1392 m
= gfc_match_char ('(');
1396 gfc_push_error (&old_error
);
1398 m
= match_complex_part (&real
);
1401 gfc_free_error (&old_error
);
1405 if (gfc_match_char (',') == MATCH_NO
)
1407 /* It is possible that gfc_int2real issued a warning when
1408 converting an integer to real. Throw this away here. */
1410 gfc_clear_warning ();
1411 gfc_pop_error (&old_error
);
1416 /* If m is error, then something was wrong with the real part and we
1417 assume we have a complex constant because we've seen the ','. An
1418 ambiguous case here is the start of an iterator list of some
1419 sort. These sort of lists are matched prior to coming here. */
1421 if (m
== MATCH_ERROR
)
1423 gfc_free_error (&old_error
);
1426 gfc_pop_error (&old_error
);
1428 m
= match_complex_part (&imag
);
1431 if (m
== MATCH_ERROR
)
1434 m
= gfc_match_char (')');
1437 /* Give the matcher for implied do-loops a chance to run. This
1438 yields a much saner error message for (/ (i, 4=i, 6) /). */
1439 if (gfc_peek_ascii_char () == '=')
1448 if (m
== MATCH_ERROR
)
1451 /* Decide on the kind of this complex number. */
1452 if (real
->ts
.type
== BT_REAL
)
1454 if (imag
->ts
.type
== BT_REAL
)
1455 kind
= gfc_kind_max (real
, imag
);
1457 kind
= real
->ts
.kind
;
1461 if (imag
->ts
.type
== BT_REAL
)
1462 kind
= imag
->ts
.kind
;
1464 kind
= gfc_default_real_kind
;
1466 gfc_clear_ts (&target
);
1467 target
.type
= BT_REAL
;
1470 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1471 gfc_convert_type (real
, &target
, 2);
1472 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1473 gfc_convert_type (imag
, &target
, 2);
1475 e
= convert_complex (real
, imag
, kind
);
1476 e
->where
= gfc_current_locus
;
1478 gfc_free_expr (real
);
1479 gfc_free_expr (imag
);
1485 gfc_error ("Syntax error in COMPLEX constant at %C");
1490 gfc_free_expr (real
);
1491 gfc_free_expr (imag
);
1492 gfc_current_locus
= old_loc
;
1498 /* Match constants in any of several forms. Returns nonzero for a
1499 match, zero for no match. */
1502 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1506 m
= match_complex_constant (result
);
1510 m
= match_string_constant (result
);
1514 m
= match_boz_constant (result
);
1518 m
= match_real_constant (result
, signflag
);
1522 m
= match_hollerith_constant (result
);
1526 m
= match_integer_constant (result
, signflag
);
1530 m
= match_logical_constant (result
);
1538 /* This checks if a symbol is the return value of an encompassing function.
1539 Function nesting can be maximally two levels deep, but we may have
1540 additional local namespaces like BLOCK etc. */
1543 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1545 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1549 if (ns
->proc_name
== sym
)
1557 /* Match a single actual argument value. An actual argument is
1558 usually an expression, but can also be a procedure name. If the
1559 argument is a single name, it is not always possible to tell
1560 whether the name is a dummy procedure or not. We treat these cases
1561 by creating an argument that looks like a dummy procedure and
1562 fixing things later during resolution. */
1565 match_actual_arg (gfc_expr
**result
)
1567 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1568 gfc_symtree
*symtree
;
1573 gfc_gobble_whitespace ();
1574 where
= gfc_current_locus
;
1576 switch (gfc_match_name (name
))
1585 w
= gfc_current_locus
;
1586 gfc_gobble_whitespace ();
1587 c
= gfc_next_ascii_char ();
1588 gfc_current_locus
= w
;
1590 if (c
!= ',' && c
!= ')')
1593 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1595 /* Handle error elsewhere. */
1597 /* Eliminate a couple of common cases where we know we don't
1598 have a function argument. */
1599 if (symtree
== NULL
)
1601 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1602 gfc_set_sym_referenced (symtree
->n
.sym
);
1608 sym
= symtree
->n
.sym
;
1609 gfc_set_sym_referenced (sym
);
1610 if (sym
->attr
.flavor
== FL_NAMELIST
)
1612 gfc_error ("Namelist %qs cannot be an argument at %L",
1616 if (sym
->attr
.flavor
!= FL_PROCEDURE
1617 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1620 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1622 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1623 sym
->name
, &sym
->declared_at
))
1628 /* If the symbol is a function with itself as the result and
1629 is being defined, then we have a variable. */
1630 if (sym
->attr
.function
&& sym
->result
== sym
)
1632 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1636 && (sym
->ns
== gfc_current_ns
1637 || sym
->ns
== gfc_current_ns
->parent
))
1639 gfc_entry_list
*el
= NULL
;
1641 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1651 e
= gfc_get_expr (); /* Leave it unknown for now */
1652 e
->symtree
= symtree
;
1653 e
->expr_type
= EXPR_VARIABLE
;
1654 e
->ts
.type
= BT_PROCEDURE
;
1661 gfc_current_locus
= where
;
1662 return gfc_match_expr (result
);
1666 /* Match a keyword argument or type parameter spec list.. */
1669 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
, bool pdt
)
1671 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1672 gfc_actual_arglist
*a
;
1676 name_locus
= gfc_current_locus
;
1677 m
= gfc_match_name (name
);
1681 if (gfc_match_char ('=') != MATCH_YES
)
1689 if (gfc_match_char ('*') == MATCH_YES
)
1691 actual
->spec_type
= SPEC_ASSUMED
;
1694 else if (gfc_match_char (':') == MATCH_YES
)
1696 actual
->spec_type
= SPEC_DEFERRED
;
1700 actual
->spec_type
= SPEC_EXPLICIT
;
1703 m
= match_actual_arg (&actual
->expr
);
1707 /* Make sure this name has not appeared yet. */
1709 if (name
[0] != '\0')
1711 for (a
= base
; a
; a
= a
->next
)
1712 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1714 gfc_error ("Keyword %qs at %C has already appeared in the "
1715 "current argument list", name
);
1720 actual
->name
= gfc_get_string ("%s", name
);
1724 gfc_current_locus
= name_locus
;
1729 /* Match an argument list function, such as %VAL. */
1732 match_arg_list_function (gfc_actual_arglist
*result
)
1734 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1738 old_locus
= gfc_current_locus
;
1740 if (gfc_match_char ('%') != MATCH_YES
)
1746 m
= gfc_match ("%n (", name
);
1750 if (name
[0] != '\0')
1755 if (gfc_str_startswith (name
, "loc"))
1757 result
->name
= "%LOC";
1762 if (gfc_str_startswith (name
, "ref"))
1764 result
->name
= "%REF";
1769 if (gfc_str_startswith (name
, "val"))
1771 result
->name
= "%VAL";
1781 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1787 m
= match_actual_arg (&result
->expr
);
1791 if (gfc_match_char (')') != MATCH_YES
)
1800 gfc_current_locus
= old_locus
;
1805 /* Matches an actual argument list of a function or subroutine, from
1806 the opening parenthesis to the closing parenthesis. The argument
1807 list is assumed to allow keyword arguments because we don't know if
1808 the symbol associated with the procedure has an implicit interface
1809 or not. We make sure keywords are unique. If sub_flag is set,
1810 we're matching the argument list of a subroutine.
1812 NOTE: An alternative use for this function is to match type parameter
1813 spec lists, which are so similar to actual argument lists that the
1814 machinery can be reused. This use is flagged by the optional argument
1818 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
, bool pdt
)
1820 gfc_actual_arglist
*head
, *tail
;
1822 gfc_st_label
*label
;
1826 *argp
= tail
= NULL
;
1827 old_loc
= gfc_current_locus
;
1831 if (gfc_match_char ('(') == MATCH_NO
)
1832 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1834 if (gfc_match_char (')') == MATCH_YES
)
1839 matching_actual_arglist
++;
1844 head
= tail
= gfc_get_actual_arglist ();
1847 tail
->next
= gfc_get_actual_arglist ();
1851 if (sub_flag
&& !pdt
&& gfc_match_char ('*') == MATCH_YES
)
1853 m
= gfc_match_st_label (&label
);
1855 gfc_error ("Expected alternate return label at %C");
1859 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1863 tail
->label
= label
;
1867 if (pdt
&& !seen_keyword
)
1869 if (gfc_match_char (':') == MATCH_YES
)
1871 tail
->spec_type
= SPEC_DEFERRED
;
1874 else if (gfc_match_char ('*') == MATCH_YES
)
1876 tail
->spec_type
= SPEC_ASSUMED
;
1880 tail
->spec_type
= SPEC_EXPLICIT
;
1882 m
= match_keyword_arg (tail
, head
, pdt
);
1888 if (m
== MATCH_ERROR
)
1892 /* After the first keyword argument is seen, the following
1893 arguments must also have keywords. */
1896 m
= match_keyword_arg (tail
, head
, pdt
);
1898 if (m
== MATCH_ERROR
)
1902 gfc_error ("Missing keyword name in actual argument list at %C");
1909 /* Try an argument list function, like %VAL. */
1910 m
= match_arg_list_function (tail
);
1911 if (m
== MATCH_ERROR
)
1914 /* See if we have the first keyword argument. */
1917 m
= match_keyword_arg (tail
, head
, false);
1920 if (m
== MATCH_ERROR
)
1926 /* Try for a non-keyword argument. */
1927 m
= match_actual_arg (&tail
->expr
);
1928 if (m
== MATCH_ERROR
)
1937 if (gfc_match_char (')') == MATCH_YES
)
1939 if (gfc_match_char (',') != MATCH_YES
)
1944 matching_actual_arglist
--;
1948 gfc_error ("Syntax error in argument list at %C");
1951 gfc_free_actual_arglist (head
);
1952 gfc_current_locus
= old_loc
;
1953 matching_actual_arglist
--;
1958 /* Used by gfc_match_varspec() to extend the reference list by one
1962 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1964 if (primary
->ref
== NULL
)
1965 primary
->ref
= tail
= gfc_get_ref ();
1969 gfc_internal_error ("extend_ref(): Bad tail");
1970 tail
->next
= gfc_get_ref ();
1978 /* Used by gfc_match_varspec() to match an inquiry reference. */
1981 is_inquiry_ref (const char *name
, gfc_ref
**ref
)
1988 if (ref
) *ref
= NULL
;
1990 if (strcmp (name
, "re") == 0)
1992 else if (strcmp (name
, "im") == 0)
1994 else if (strcmp (name
, "kind") == 0)
1995 type
= INQUIRY_KIND
;
1996 else if (strcmp (name
, "len") == 0)
2005 if (!gfc_notify_std (GFC_STD_F2008
, "RE or IM part_ref at %C"))
2010 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
2015 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2025 *ref
= gfc_get_ref ();
2026 (*ref
)->type
= REF_INQUIRY
;
2034 /* Match any additional specifications associated with the current
2035 variable like member references or substrings. If equiv_flag is
2036 set we only match stuff that is allowed inside an EQUIVALENCE
2037 statement. sub_flag tells whether we expect a type-bound procedure found
2038 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
2039 components, 'ppc_arg' determines whether the PPC may be called (with an
2040 argument list), or whether it may just be referred to as a pointer. */
2043 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
2046 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2047 gfc_ref
*substring
, *tail
, *tmp
;
2048 gfc_component
*component
;
2049 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
2050 gfc_expr
*tgt_expr
= NULL
;
2060 gfc_gobble_whitespace ();
2062 if (gfc_peek_ascii_char () == '[')
2064 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
2065 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2066 && CLASS_DATA (sym
)->attr
.dimension
))
2068 gfc_error ("Array section designator, e.g. '(:)', is required "
2069 "besides the coarray designator '[...]' at %C");
2072 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
2073 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2074 && !CLASS_DATA (sym
)->attr
.codimension
))
2076 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2082 if (sym
->assoc
&& sym
->assoc
->target
)
2083 tgt_expr
= sym
->assoc
->target
;
2085 /* For associate names, we may not yet know whether they are arrays or not.
2086 If the selector expression is unambiguously an array; eg. a full array
2087 or an array section, then the associate name must be an array and we can
2088 fix it now. Otherwise, if parentheses follow and it is not a character
2089 type, we have to assume that it actually is one for now. The final
2090 decision will be made at resolution, of course. */
2092 && gfc_peek_ascii_char () == '('
2093 && sym
->ts
.type
!= BT_CLASS
2094 && !sym
->attr
.dimension
)
2096 gfc_ref
*ref
= NULL
;
2098 if (!sym
->assoc
->dangling
&& tgt_expr
)
2100 if (tgt_expr
->expr_type
== EXPR_VARIABLE
)
2101 gfc_resolve_expr (tgt_expr
);
2103 ref
= tgt_expr
->ref
;
2104 for (; ref
; ref
= ref
->next
)
2105 if (ref
->type
== REF_ARRAY
2106 && (ref
->u
.ar
.type
== AR_FULL
2107 || ref
->u
.ar
.type
== AR_SECTION
))
2111 if (ref
|| (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
2113 && sym
->assoc
->st
->n
.sym
2114 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
2116 sym
->attr
.dimension
= 1;
2119 && sym
->assoc
->st
->n
.sym
2120 && sym
->assoc
->st
->n
.sym
->as
)
2121 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
2124 else if (sym
->ts
.type
== BT_CLASS
2126 && tgt_expr
->expr_type
== EXPR_VARIABLE
2127 && sym
->ts
.u
.derived
!= tgt_expr
->ts
.u
.derived
)
2129 gfc_resolve_expr (tgt_expr
);
2131 sym
->ts
.u
.derived
= tgt_expr
->ts
.u
.derived
;
2134 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
2135 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
2136 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
2137 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
2138 && !(gfc_matching_procptr_assignment
2139 && sym
->attr
.flavor
== FL_PROCEDURE
))
2140 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2141 && (CLASS_DATA (sym
)->attr
.dimension
2142 || CLASS_DATA (sym
)->attr
.codimension
)))
2146 tail
= extend_ref (primary
, tail
);
2147 tail
->type
= REF_ARRAY
;
2149 /* In EQUIVALENCE, we don't know yet whether we are seeing
2150 an array, character variable or array of character
2151 variables. We'll leave the decision till resolve time. */
2155 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2156 as
= CLASS_DATA (sym
)->as
;
2160 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
2161 as
? as
->corank
: 0);
2165 gfc_gobble_whitespace ();
2166 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
2168 tail
= extend_ref (primary
, tail
);
2169 tail
->type
= REF_ARRAY
;
2171 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2177 primary
->ts
= sym
->ts
;
2182 /* With DEC extensions, member separator may be '.' or '%'. */
2183 sep
= gfc_peek_ascii_char ();
2184 m
= gfc_match_member_sep (sym
);
2185 if (m
== MATCH_ERROR
)
2189 if (m
== MATCH_YES
&& sep
== '%'
2190 && primary
->ts
.type
!= BT_CLASS
2191 && primary
->ts
.type
!= BT_DERIVED
)
2194 old_loc
= gfc_current_locus
;
2195 mm
= gfc_match_name (name
);
2196 if (mm
== MATCH_YES
&& is_inquiry_ref (name
, &tmp
))
2198 gfc_current_locus
= old_loc
;
2201 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2202 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2203 gfc_set_default_type (sym
, 0, sym
->ns
);
2205 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2206 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2210 /* These target expressions can be resolved at any time. */
2211 permissible
= tgt_expr
&& tgt_expr
->symtree
&& tgt_expr
->symtree
->n
.sym
2212 && (tgt_expr
->symtree
->n
.sym
->attr
.use_assoc
2213 || tgt_expr
->symtree
->n
.sym
->attr
.host_assoc
2214 || tgt_expr
->symtree
->n
.sym
->attr
.if_source
2216 permissible
= permissible
2217 || (tgt_expr
&& tgt_expr
->expr_type
== EXPR_OP
);
2221 gfc_resolve_expr (tgt_expr
);
2222 sym
->ts
= tgt_expr
->ts
;
2225 if (sym
->ts
.type
== BT_UNKNOWN
)
2227 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2231 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2232 && m
== MATCH_YES
&& !inquiry
)
2234 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2239 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
&& !inquiry
)
2241 goto check_substring
;
2244 sym
= sym
->ts
.u
.derived
;
2253 m
= gfc_match_name (name
);
2255 gfc_error ("Expected structure component name at %C");
2260 if (primary
->ts
.type
!= BT_CLASS
&& primary
->ts
.type
!= BT_DERIVED
)
2262 inquiry
= is_inquiry_ref (name
, &tmp
);
2270 if ((tmp
->u
.i
== INQUIRY_RE
|| tmp
->u
.i
== INQUIRY_IM
)
2271 && primary
->ts
.type
!= BT_COMPLEX
)
2273 gfc_error ("The RE or IM part_ref at %C must be "
2274 "applied to a COMPLEX expression");
2277 else if (tmp
->u
.i
== INQUIRY_LEN
2278 && primary
->ts
.type
!= BT_CHARACTER
)
2280 gfc_error ("The LEN part_ref at %C must be applied "
2281 "to a CHARACTER expression");
2285 if (primary
->ts
.type
!= BT_UNKNOWN
)
2292 if (sym
&& sym
->f2k_derived
)
2293 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2299 gfc_symbol
* tbp_sym
;
2304 gcc_assert (!tail
|| !tail
->next
);
2306 if (!(primary
->expr_type
== EXPR_VARIABLE
2307 || (primary
->expr_type
== EXPR_STRUCTURE
2308 && primary
->symtree
&& primary
->symtree
->n
.sym
2309 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2312 if (tbp
->n
.tb
->is_generic
)
2315 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2317 primary
->expr_type
= EXPR_COMPCALL
;
2318 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2319 primary
->value
.compcall
.name
= tbp
->name
;
2320 primary
->value
.compcall
.ignore_pass
= 0;
2321 primary
->value
.compcall
.assign
= 0;
2322 primary
->value
.compcall
.base_object
= NULL
;
2323 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2325 primary
->ts
= tbp_sym
->ts
;
2327 gfc_clear_ts (&primary
->ts
);
2329 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2330 &primary
->value
.compcall
.actual
);
2331 if (m
== MATCH_ERROR
)
2336 primary
->value
.compcall
.actual
= NULL
;
2339 gfc_error ("Expected argument list at %C");
2347 if (!inquiry
&& !intrinsic
)
2348 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2352 /* In some cases, returning MATCH_NO gives a better error message. Most
2353 cases return "Unclassifiable statement at..." */
2354 if (intrinsic
&& !inquiry
)
2356 else if (component
== NULL
&& !inquiry
)
2359 /* Extend the reference chain determined by gfc_find_component or
2361 if (primary
->ref
== NULL
)
2365 /* Set by the for loop below for the last component ref. */
2366 gcc_assert (tail
!= NULL
);
2370 /* The reference chain may be longer than one hop for union
2371 subcomponents; find the new tail. */
2372 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2375 if (tmp
&& tmp
->type
== REF_INQUIRY
)
2377 if (!primary
->where
.lb
|| !primary
->where
.nextc
)
2378 primary
->where
= gfc_current_locus
;
2379 gfc_simplify_expr (primary
, 0);
2381 if (primary
->expr_type
== EXPR_CONSTANT
)
2388 if (!gfc_notify_std (GFC_STD_F2008
, "RE or IM part_ref at %C"))
2391 if (primary
->ts
.type
!= BT_COMPLEX
)
2393 gfc_error ("The RE or IM part_ref at %C must be "
2394 "applied to a COMPLEX expression");
2397 primary
->ts
.type
= BT_REAL
;
2401 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2404 if (primary
->ts
.type
!= BT_CHARACTER
)
2406 gfc_error ("The LEN part_ref at %C must be applied "
2407 "to a CHARACTER expression");
2410 primary
->ts
.u
.cl
= NULL
;
2411 primary
->ts
.type
= BT_INTEGER
;
2412 primary
->ts
.kind
= gfc_default_integer_kind
;
2416 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
2419 if (primary
->ts
.type
== BT_CLASS
2420 || primary
->ts
.type
== BT_DERIVED
)
2422 gfc_error ("The KIND part_ref at %C must be applied "
2423 "to an expression of intrinsic type");
2426 primary
->ts
.type
= BT_INTEGER
;
2427 primary
->ts
.kind
= gfc_default_integer_kind
;
2437 primary
->ts
= component
->ts
;
2439 if (component
->attr
.proc_pointer
&& ppc_arg
)
2441 /* Procedure pointer component call: Look for argument list. */
2442 m
= gfc_match_actual_arglist (sub_flag
,
2443 &primary
->value
.compcall
.actual
);
2444 if (m
== MATCH_ERROR
)
2447 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2448 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2450 gfc_error ("Procedure pointer component %qs requires an "
2451 "argument list at %C", component
->name
);
2456 primary
->expr_type
= EXPR_PPC
;
2461 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2463 tail
= extend_ref (primary
, tail
);
2464 tail
->type
= REF_ARRAY
;
2466 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2467 component
->as
->corank
);
2471 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2472 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2474 tail
= extend_ref (primary
, tail
);
2475 tail
->type
= REF_ARRAY
;
2477 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2479 CLASS_DATA (component
)->as
->corank
);
2485 /* In principle, we could have eg. expr%re%kind so we must allow for
2486 this possibility. */
2487 if (gfc_match_char ('%') == MATCH_YES
)
2489 if (component
&& (component
->ts
.type
== BT_DERIVED
2490 || component
->ts
.type
== BT_CLASS
))
2491 sym
= component
->ts
.u
.derived
;
2497 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2498 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2501 if (component
->ts
.type
== BT_DERIVED
|| component
->ts
.type
== BT_CLASS
)
2502 sym
= component
->ts
.u
.derived
;
2507 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2509 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2511 gfc_set_default_type (sym
, 0, sym
->ns
);
2512 primary
->ts
= sym
->ts
;
2517 if (primary
->ts
.type
== BT_CHARACTER
)
2519 bool def
= primary
->ts
.deferred
== 1;
2520 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2524 primary
->ref
= substring
;
2526 tail
->next
= substring
;
2528 if (primary
->expr_type
== EXPR_CONSTANT
)
2529 primary
->expr_type
= EXPR_SUBSTRING
;
2532 primary
->ts
.u
.cl
= NULL
;
2539 gfc_clear_ts (&primary
->ts
);
2540 gfc_clear_ts (&sym
->ts
);
2550 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2551 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2553 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2558 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2560 gfc_error ("Coindexed procedure-pointer component at %C");
2568 /* Given an expression that is a variable, figure out what the
2569 ultimate variable's type and attribute is, traversing the reference
2570 structures if necessary.
2572 This subroutine is trickier than it looks. We start at the base
2573 symbol and store the attribute. Component references load a
2574 completely new attribute.
2576 A couple of rules come into play. Subobjects of targets are always
2577 targets themselves. If we see a component that goes through a
2578 pointer, then the expression must also be a target, since the
2579 pointer is associated with something (if it isn't core will soon be
2580 dumped). If we see a full part or section of an array, the
2581 expression is also an array.
2583 We can have at most one full array reference. */
2586 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2588 int dimension
, codimension
, pointer
, allocatable
, target
;
2589 symbol_attribute attr
;
2592 gfc_component
*comp
;
2593 bool has_inquiry_part
;
2595 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2596 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2598 sym
= expr
->symtree
->n
.sym
;
2601 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2603 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2604 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2605 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2606 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2610 dimension
= attr
.dimension
;
2611 codimension
= attr
.codimension
;
2612 pointer
= attr
.pointer
;
2613 allocatable
= attr
.allocatable
;
2616 target
= attr
.target
;
2617 if (pointer
|| attr
.proc_pointer
)
2620 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2623 has_inquiry_part
= false;
2624 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2625 if (ref
->type
== REF_INQUIRY
)
2627 has_inquiry_part
= true;
2631 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2636 switch (ref
->u
.ar
.type
)
2643 allocatable
= pointer
= 0;
2648 /* Handle coarrays. */
2649 if (ref
->u
.ar
.dimen
> 0)
2650 allocatable
= pointer
= 0;
2654 /* For standard conforming code, AR_UNKNOWN should not happen.
2655 For nonconforming code, gfortran can end up here. Treat it
2663 comp
= ref
->u
.c
.component
;
2665 if (ts
!= NULL
&& !has_inquiry_part
)
2668 /* Don't set the string length if a substring reference
2670 if (ts
->type
== BT_CHARACTER
2671 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2675 if (comp
->ts
.type
== BT_CLASS
)
2677 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2678 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2679 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2683 codimension
= comp
->attr
.codimension
;
2684 pointer
= comp
->attr
.pointer
;
2685 allocatable
= comp
->attr
.allocatable
;
2687 if (pointer
|| attr
.proc_pointer
)
2694 allocatable
= pointer
= 0;
2698 attr
.dimension
= dimension
;
2699 attr
.codimension
= codimension
;
2700 attr
.pointer
= pointer
;
2701 attr
.allocatable
= allocatable
;
2702 attr
.target
= target
;
2703 attr
.save
= sym
->attr
.save
;
2709 /* Return the attribute from a general expression. */
2712 gfc_expr_attr (gfc_expr
*e
)
2714 symbol_attribute attr
;
2716 switch (e
->expr_type
)
2719 attr
= gfc_variable_attr (e
, NULL
);
2723 gfc_clear_attr (&attr
);
2725 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2727 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2729 if (sym
->ts
.type
== BT_CLASS
)
2731 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2732 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2733 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2736 else if (e
->value
.function
.isym
2737 && e
->value
.function
.isym
->transformational
2738 && e
->ts
.type
== BT_CLASS
)
2739 attr
= CLASS_DATA (e
)->attr
;
2741 attr
= gfc_variable_attr (e
, NULL
);
2743 /* TODO: NULL() returns pointers. May have to take care of this
2749 gfc_clear_attr (&attr
);
2757 /* Given an expression, figure out what the ultimate expression
2758 attribute is. This routine is similar to gfc_variable_attr with
2759 parts of gfc_expr_attr, but focuses more on the needs of
2760 coarrays. For coarrays a codimension attribute is kind of
2761 "infectious" being propagated once set and never cleared.
2762 The coarray_comp is only set, when the expression refs a coarray
2763 component. REFS_COMP is set when present to true only, when this EXPR
2764 refs a (non-_data) component. To check whether EXPR refs an allocatable
2765 component in a derived type coarray *refs_comp needs to be set and
2766 coarray_comp has to false. */
2768 static symbol_attribute
2769 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2771 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2772 symbol_attribute attr
;
2775 gfc_component
*comp
;
2777 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2778 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2780 sym
= expr
->symtree
->n
.sym
;
2781 gfc_clear_attr (&attr
);
2786 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2788 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2789 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2790 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2791 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2792 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2793 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2797 dimension
= sym
->attr
.dimension
;
2798 codimension
= sym
->attr
.codimension
;
2799 pointer
= sym
->attr
.pointer
;
2800 allocatable
= sym
->attr
.allocatable
;
2801 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2802 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2803 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2804 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2807 target
= coarray_comp
= 0;
2808 if (pointer
|| attr
.proc_pointer
)
2811 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2816 switch (ref
->u
.ar
.type
)
2824 /* Handle coarrays. */
2825 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2826 allocatable
= pointer
= 0;
2830 /* If any of start, end or stride is not integer, there will
2831 already have been an error issued. */
2833 gfc_get_errors (NULL
, &errors
);
2835 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2841 comp
= ref
->u
.c
.component
;
2843 if (comp
->ts
.type
== BT_CLASS
)
2845 /* Set coarray_comp only, when this component introduces the
2847 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2848 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2849 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2850 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2854 /* Set coarray_comp only, when this component introduces the
2856 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2857 codimension
|= comp
->attr
.codimension
;
2858 pointer
= comp
->attr
.pointer
;
2859 allocatable
= comp
->attr
.allocatable
;
2862 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2863 && (ref
->next
== NULL
2864 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2867 if (pointer
|| attr
.proc_pointer
)
2874 allocatable
= pointer
= 0;
2878 attr
.dimension
= dimension
;
2879 attr
.codimension
= codimension
;
2880 attr
.pointer
= pointer
;
2881 attr
.allocatable
= allocatable
;
2882 attr
.target
= target
;
2883 attr
.save
= sym
->attr
.save
;
2884 attr
.coarray_comp
= coarray_comp
;
2891 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2893 symbol_attribute attr
;
2895 switch (e
->expr_type
)
2898 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2902 gfc_clear_attr (&attr
);
2904 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2906 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2908 if (sym
->ts
.type
== BT_CLASS
)
2910 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2911 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2912 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2913 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2914 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2915 ->attr
.pointer_comp
;
2918 else if (e
->symtree
)
2919 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2921 gfc_clear_attr (&attr
);
2925 gfc_clear_attr (&attr
);
2933 /* Match a structure constructor. The initial symbol has already been
2936 typedef struct gfc_structure_ctor_component
2941 struct gfc_structure_ctor_component
* next
;
2943 gfc_structure_ctor_component
;
2945 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2948 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2951 gfc_free_expr (comp
->val
);
2956 /* Translate the component list into the actual constructor by sorting it in
2957 the order required; this also checks along the way that each and every
2958 component actually has an initializer and handles default initializers
2959 for components without explicit value given. */
2961 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2962 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2964 gfc_structure_ctor_component
*comp_iter
;
2965 gfc_component
*comp
;
2967 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2969 gfc_structure_ctor_component
**next_ptr
;
2970 gfc_expr
*value
= NULL
;
2972 /* Try to find the initializer for the current component by name. */
2973 next_ptr
= comp_head
;
2974 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2976 if (!strcmp (comp_iter
->name
, comp
->name
))
2978 next_ptr
= &comp_iter
->next
;
2981 /* If an extension, try building the parent derived type by building
2982 a value expression for the parent derived type and calling self. */
2983 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2985 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2987 &gfc_current_locus
);
2988 value
->ts
= comp
->ts
;
2990 if (!build_actual_constructor (comp_head
,
2991 &value
->value
.constructor
,
2992 comp
->ts
.u
.derived
))
2994 gfc_free_expr (value
);
2998 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3002 /* If it was not found, try the default initializer if there's any;
3003 otherwise, it's an error unless this is a deferred parameter. */
3006 if (comp
->initializer
)
3008 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
3009 "with missing optional arguments at %C"))
3011 value
= gfc_copy_expr (comp
->initializer
);
3013 else if (comp
->attr
.allocatable
3014 || (comp
->ts
.type
== BT_CLASS
3015 && CLASS_DATA (comp
)->attr
.allocatable
))
3017 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
3018 "allocatable component %qs given in the "
3019 "structure constructor at %C", comp
->name
))
3022 else if (!comp
->attr
.artificial
)
3024 gfc_error ("No initializer for component %qs given in the"
3025 " structure constructor at %C", comp
->name
);
3030 value
= comp_iter
->val
;
3032 /* Add the value to the constructor chain built. */
3033 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3035 /* Remove the entry from the component list. We don't want the expression
3036 value to be free'd, so set it to NULL. */
3039 *next_ptr
= comp_iter
->next
;
3040 comp_iter
->val
= NULL
;
3041 gfc_free_structure_ctor_component (comp_iter
);
3049 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
3050 gfc_actual_arglist
**arglist
,
3053 gfc_actual_arglist
*actual
;
3054 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
3055 gfc_constructor_base ctor_head
= NULL
;
3056 gfc_component
*comp
; /* Is set NULL when named component is first seen */
3057 const char* last_name
= NULL
;
3061 expr
= parent
? *cexpr
: e
;
3062 old_locus
= gfc_current_locus
;
3064 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3066 gfc_current_locus
= expr
->where
;
3068 comp_tail
= comp_head
= NULL
;
3070 if (!parent
&& sym
->attr
.abstract
)
3072 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3073 sym
->name
, &expr
->where
);
3077 comp
= sym
->components
;
3078 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
3081 gfc_component
*this_comp
= NULL
;
3084 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
3087 comp_tail
->next
= gfc_get_structure_ctor_component ();
3088 comp_tail
= comp_tail
->next
;
3092 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
3093 " constructor with named arguments at %C"))
3096 comp_tail
->name
= xstrdup (actual
->name
);
3097 last_name
= comp_tail
->name
;
3102 /* Components without name are not allowed after the first named
3103 component initializer! */
3104 if (!comp
|| comp
->attr
.artificial
)
3107 gfc_error ("Component initializer without name after component"
3108 " named %s at %L", last_name
,
3109 actual
->expr
? &actual
->expr
->where
3110 : &gfc_current_locus
);
3112 gfc_error ("Too many components in structure constructor at "
3113 "%L", actual
->expr
? &actual
->expr
->where
3114 : &gfc_current_locus
);
3118 comp_tail
->name
= xstrdup (comp
->name
);
3121 /* Find the current component in the structure definition and check
3122 its access is not private. */
3124 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
3127 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
3128 false, false, NULL
);
3129 comp
= NULL
; /* Reset needed! */
3132 /* Here we can check if a component name is given which does not
3133 correspond to any component of the defined structure. */
3137 /* For a constant string constructor, make sure the length is
3138 correct; truncate of fill with blanks if needed. */
3139 if (this_comp
->ts
.type
== BT_CHARACTER
&& !this_comp
->attr
.allocatable
3140 && this_comp
->ts
.u
.cl
&& this_comp
->ts
.u
.cl
->length
3141 && this_comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3142 && actual
->expr
->ts
.type
== BT_CHARACTER
3143 && actual
->expr
->expr_type
== EXPR_CONSTANT
)
3146 c
= gfc_mpz_get_hwi (this_comp
->ts
.u
.cl
->length
->value
.integer
);
3147 e1
= actual
->expr
->value
.character
.length
;
3153 dest
= gfc_get_wide_string (c
+ 1);
3155 to
= e1
< c
? e1
: c
;
3156 for (i
= 0; i
< to
; i
++)
3157 dest
[i
] = actual
->expr
->value
.character
.string
[i
];
3159 for (i
= e1
; i
< c
; i
++)
3163 free (actual
->expr
->value
.character
.string
);
3165 actual
->expr
->value
.character
.length
= c
;
3166 actual
->expr
->value
.character
.string
= dest
;
3168 if (warn_line_truncation
&& c
< e1
)
3169 gfc_warning_now (OPT_Wcharacter_truncation
,
3170 "CHARACTER expression will be truncated "
3171 "in constructor (%ld/%ld) at %L", (long int) c
,
3172 (long int) e1
, &actual
->expr
->where
);
3176 comp_tail
->val
= actual
->expr
;
3177 if (actual
->expr
!= NULL
)
3178 comp_tail
->where
= actual
->expr
->where
;
3179 actual
->expr
= NULL
;
3181 /* Check if this component is already given a value. */
3182 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
3183 comp_iter
= comp_iter
->next
)
3185 gcc_assert (comp_iter
);
3186 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
3188 gfc_error ("Component %qs is initialized twice in the structure"
3189 " constructor at %L", comp_tail
->name
,
3190 comp_tail
->val
? &comp_tail
->where
3191 : &gfc_current_locus
);
3196 /* F2008, R457/C725, for PURE C1283. */
3197 if (this_comp
->attr
.pointer
&& comp_tail
->val
3198 && gfc_is_coindexed (comp_tail
->val
))
3200 gfc_error ("Coindexed expression to pointer component %qs in "
3201 "structure constructor at %L", comp_tail
->name
,
3206 /* If not explicitly a parent constructor, gather up the components
3208 if (comp
&& comp
== sym
->components
3209 && sym
->attr
.extension
3211 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
3213 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
3216 gfc_actual_arglist
*arg_null
= NULL
;
3218 actual
->expr
= comp_tail
->val
;
3219 comp_tail
->val
= NULL
;
3221 m
= gfc_convert_to_structure_constructor (NULL
,
3222 comp
->ts
.u
.derived
, &comp_tail
->val
,
3223 comp
->ts
.u
.derived
->attr
.zero_comp
3224 ? &arg_null
: &actual
, true);
3228 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
3237 if (parent
&& !comp
)
3241 actual
= actual
->next
;
3244 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
3247 /* No component should be left, as this should have caused an error in the
3248 loop constructing the component-list (name that does not correspond to any
3249 component in the structure definition). */
3250 if (comp_head
&& sym
->attr
.extension
)
3252 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3254 gfc_error ("component %qs at %L has already been set by a "
3255 "parent derived type constructor", comp_iter
->name
,
3261 gcc_assert (!comp_head
);
3265 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
3266 expr
->ts
.u
.derived
= sym
;
3267 expr
->value
.constructor
= ctor_head
;
3272 expr
->ts
.u
.derived
= sym
;
3274 expr
->ts
.type
= BT_DERIVED
;
3275 expr
->value
.constructor
= ctor_head
;
3276 expr
->expr_type
= EXPR_STRUCTURE
;
3279 gfc_current_locus
= old_locus
;
3285 gfc_current_locus
= old_locus
;
3287 for (comp_iter
= comp_head
; comp_iter
; )
3289 gfc_structure_ctor_component
*next
= comp_iter
->next
;
3290 gfc_free_structure_ctor_component (comp_iter
);
3293 gfc_constructor_free (ctor_head
);
3300 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
3304 gfc_symtree
*symtree
;
3306 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
3308 e
= gfc_get_expr ();
3309 e
->symtree
= symtree
;
3310 e
->expr_type
= EXPR_FUNCTION
;
3311 e
->where
= gfc_current_locus
;
3313 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
3314 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
3315 e
->value
.function
.esym
= sym
;
3316 e
->symtree
->n
.sym
->attr
.generic
= 1;
3318 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3325 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
3331 /* If a structure constructor is in a DATA statement, then each entity
3332 in the structure constructor must be a constant. Try to reduce the
3334 if (gfc_in_match_data ())
3335 gfc_reduce_init_expr (e
);
3342 /* If the symbol is an implicit do loop index and implicitly typed,
3343 it should not be host associated. Provide a symtree from the
3344 current namespace. */
3346 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
3348 if ((*sym
)->attr
.flavor
== FL_VARIABLE
3349 && (*sym
)->ns
!= gfc_current_ns
3350 && (*sym
)->attr
.implied_index
3351 && (*sym
)->attr
.implicit_type
3352 && !(*sym
)->attr
.use_assoc
)
3355 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
3358 *sym
= (*st
)->n
.sym
;
3364 /* Procedure pointer as function result: Replace the function symbol by the
3365 auto-generated hidden result variable named "ppr@". */
3368 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
3370 /* Check for procedure pointer result variable. */
3371 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
3372 && (*sym
)->result
&& (*sym
)->result
!= *sym
3373 && (*sym
)->result
->attr
.proc_pointer
3374 && (*sym
) == gfc_current_ns
->proc_name
3375 && (*sym
) == (*sym
)->result
->ns
->proc_name
3376 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3378 /* Automatic replacement with "hidden" result variable. */
3379 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3380 *sym
= (*sym
)->result
;
3381 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3388 /* Matches a variable name followed by anything that might follow it--
3389 array reference, argument list of a function, etc. */
3392 gfc_match_rvalue (gfc_expr
**result
)
3394 gfc_actual_arglist
*actual_arglist
;
3395 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3398 gfc_symtree
*symtree
;
3399 locus where
, old_loc
;
3407 m
= gfc_match ("%%loc");
3410 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3412 strncpy (name
, "loc", 4);
3417 m
= gfc_match_name (name
);
3422 /* Check if the symbol exists. */
3423 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3426 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3427 type. For derived types we create a generic symbol which links to the
3428 derived type symbol; STRUCTUREs are simpler and must not conflict with
3431 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3433 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3435 if (gfc_find_state (COMP_INTERFACE
)
3436 && !gfc_current_ns
->has_import_set
)
3437 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3439 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3445 sym
= symtree
->n
.sym
;
3447 where
= gfc_current_locus
;
3449 replace_hidden_procptr_result (&sym
, &symtree
);
3451 /* If this is an implicit do loop index and implicitly typed,
3452 it should not be host associated. */
3453 m
= check_for_implicit_index (&symtree
, &sym
);
3457 gfc_set_sym_referenced (sym
);
3458 sym
->attr
.implied_index
= 0;
3460 if (sym
->attr
.function
&& sym
->result
== sym
)
3462 /* See if this is a directly recursive function call. */
3463 gfc_gobble_whitespace ();
3464 if (sym
->attr
.recursive
3465 && gfc_peek_ascii_char () == '('
3466 && gfc_current_ns
->proc_name
== sym
3467 && !sym
->attr
.dimension
)
3469 gfc_error ("%qs at %C is the name of a recursive function "
3470 "and so refers to the result variable. Use an "
3471 "explicit RESULT variable for direct recursion "
3472 "(12.5.2.1)", sym
->name
);
3476 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3480 && (sym
->ns
== gfc_current_ns
3481 || sym
->ns
== gfc_current_ns
->parent
))
3483 gfc_entry_list
*el
= NULL
;
3485 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3491 if (gfc_matching_procptr_assignment
)
3493 /* It can be a procedure or a derived-type procedure or a not-yet-known
3495 if (sym
->attr
.flavor
!= FL_UNKNOWN
3496 && sym
->attr
.flavor
!= FL_PROCEDURE
3497 && sym
->attr
.flavor
!= FL_PARAMETER
3498 && sym
->attr
.flavor
!= FL_VARIABLE
)
3500 gfc_error ("Symbol at %C is not appropriate for an expression");
3506 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3509 if (sym
->attr
.generic
)
3510 goto generic_function
;
3512 switch (sym
->attr
.flavor
)
3516 e
= gfc_get_expr ();
3518 e
->expr_type
= EXPR_VARIABLE
;
3519 e
->symtree
= symtree
;
3521 m
= gfc_match_varspec (e
, 0, false, true);
3525 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3526 end up here. Unfortunately, sym->value->expr_type is set to
3527 EXPR_CONSTANT, and so the if () branch would be followed without
3528 the !sym->as check. */
3529 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3530 e
= gfc_copy_expr (sym
->value
);
3533 e
= gfc_get_expr ();
3534 e
->expr_type
= EXPR_VARIABLE
;
3537 e
->symtree
= symtree
;
3538 m
= gfc_match_varspec (e
, 0, false, true);
3540 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3543 /* Variable array references to derived type parameters cause
3544 all sorts of headaches in simplification. Treating such
3545 expressions as variable works just fine for all array
3547 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3549 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3550 if (ref
->type
== REF_ARRAY
)
3553 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3559 e
= gfc_get_expr ();
3560 e
->expr_type
= EXPR_VARIABLE
;
3561 e
->symtree
= symtree
;
3569 sym
= gfc_use_derived (sym
);
3573 goto generic_function
;
3576 /* If we're here, then the name is known to be the name of a
3577 procedure, yet it is not sure to be the name of a function. */
3580 /* Procedure Pointer Assignments. */
3582 if (gfc_matching_procptr_assignment
)
3584 gfc_gobble_whitespace ();
3585 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3586 /* Parse functions returning a procptr. */
3589 e
= gfc_get_expr ();
3590 e
->expr_type
= EXPR_VARIABLE
;
3591 e
->symtree
= symtree
;
3592 m
= gfc_match_varspec (e
, 0, false, true);
3593 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3594 && sym
->ts
.type
== BT_UNKNOWN
3595 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3603 if (sym
->attr
.subroutine
)
3605 gfc_error ("Unexpected use of subroutine name %qs at %C",
3611 /* At this point, the name has to be a non-statement function.
3612 If the name is the same as the current function being
3613 compiled, then we have a variable reference (to the function
3614 result) if the name is non-recursive. */
3616 st
= gfc_enclosing_unit (NULL
);
3619 && st
->state
== COMP_FUNCTION
3621 && !sym
->attr
.recursive
)
3623 e
= gfc_get_expr ();
3624 e
->symtree
= symtree
;
3625 e
->expr_type
= EXPR_VARIABLE
;
3627 m
= gfc_match_varspec (e
, 0, false, true);
3631 /* Match a function reference. */
3633 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3636 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3637 gfc_error ("Statement function %qs requires argument list at %C",
3640 gfc_error ("Function %qs requires an argument list at %C",
3653 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3654 sym
= symtree
->n
.sym
;
3656 replace_hidden_procptr_result (&sym
, &symtree
);
3658 e
= gfc_get_expr ();
3659 e
->symtree
= symtree
;
3660 e
->expr_type
= EXPR_FUNCTION
;
3661 e
->value
.function
.actual
= actual_arglist
;
3662 e
->where
= gfc_current_locus
;
3664 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3665 && CLASS_DATA (sym
)->as
)
3666 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3667 else if (sym
->as
!= NULL
)
3668 e
->rank
= sym
->as
->rank
;
3670 if (!sym
->attr
.function
3671 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3677 /* Check here for the existence of at least one argument for the
3678 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3679 argument(s) given will be checked in gfc_iso_c_func_interface,
3680 during resolution of the function call. */
3681 if (sym
->attr
.is_iso_c
== 1
3682 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3683 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3684 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3685 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3687 /* make sure we were given a param */
3688 if (actual_arglist
== NULL
)
3690 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3696 if (sym
->result
== NULL
)
3699 gfc_gobble_whitespace ();
3701 if (gfc_peek_ascii_char() == '%')
3703 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3704 "function reference at %C");
3714 /* Special case for derived type variables that get their types
3715 via an IMPLICIT statement. This can't wait for the
3716 resolution phase. */
3718 old_loc
= gfc_current_locus
;
3719 if (gfc_match_member_sep (sym
) == MATCH_YES
3720 && sym
->ts
.type
== BT_UNKNOWN
3721 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3722 gfc_set_default_type (sym
, 0, sym
->ns
);
3723 gfc_current_locus
= old_loc
;
3725 /* If the symbol has a (co)dimension attribute, the expression is a
3728 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3730 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3736 e
= gfc_get_expr ();
3737 e
->symtree
= symtree
;
3738 e
->expr_type
= EXPR_VARIABLE
;
3739 m
= gfc_match_varspec (e
, 0, false, true);
3743 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3744 && (CLASS_DATA (sym
)->attr
.dimension
3745 || CLASS_DATA (sym
)->attr
.codimension
))
3747 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3753 e
= gfc_get_expr ();
3754 e
->symtree
= symtree
;
3755 e
->expr_type
= EXPR_VARIABLE
;
3756 m
= gfc_match_varspec (e
, 0, false, true);
3760 /* Name is not an array, so we peek to see if a '(' implies a
3761 function call or a substring reference. Otherwise the
3762 variable is just a scalar. */
3764 gfc_gobble_whitespace ();
3765 if (gfc_peek_ascii_char () != '(')
3767 /* Assume a scalar variable */
3768 e
= gfc_get_expr ();
3769 e
->symtree
= symtree
;
3770 e
->expr_type
= EXPR_VARIABLE
;
3772 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3778 /*FIXME:??? gfc_match_varspec does set this for us: */
3780 m
= gfc_match_varspec (e
, 0, false, true);
3784 /* See if this is a function reference with a keyword argument
3785 as first argument. We do this because otherwise a spurious
3786 symbol would end up in the symbol table. */
3788 old_loc
= gfc_current_locus
;
3789 m2
= gfc_match (" ( %n =", argname
);
3790 gfc_current_locus
= old_loc
;
3792 e
= gfc_get_expr ();
3793 e
->symtree
= symtree
;
3795 if (m2
!= MATCH_YES
)
3797 /* Try to figure out whether we're dealing with a character type.
3798 We're peeking ahead here, because we don't want to call
3799 match_substring if we're dealing with an implicitly typed
3800 non-character variable. */
3801 implicit_char
= false;
3802 if (sym
->ts
.type
== BT_UNKNOWN
)
3804 ts
= gfc_get_default_type (sym
->name
, NULL
);
3805 if (ts
->type
== BT_CHARACTER
)
3806 implicit_char
= true;
3809 /* See if this could possibly be a substring reference of a name
3810 that we're not sure is a variable yet. */
3812 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3813 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3816 e
->expr_type
= EXPR_VARIABLE
;
3818 if (sym
->attr
.flavor
!= FL_VARIABLE
3819 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3826 if (sym
->ts
.type
== BT_UNKNOWN
3827 && !gfc_set_default_type (sym
, 1, NULL
))
3841 /* Give up, assume we have a function. */
3843 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3844 sym
= symtree
->n
.sym
;
3845 e
->expr_type
= EXPR_FUNCTION
;
3847 if (!sym
->attr
.function
3848 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3856 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3858 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3866 /* If our new function returns a character, array or structure
3867 type, it might have subsequent references. */
3869 m
= gfc_match_varspec (e
, 0, false, true);
3876 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3877 specially. Creates a generic symbol for derived types. */
3878 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3880 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3881 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3882 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3884 e
= gfc_get_expr ();
3885 e
->symtree
= symtree
;
3886 e
->expr_type
= EXPR_FUNCTION
;
3888 if (gfc_fl_struct (sym
->attr
.flavor
))
3890 e
->value
.function
.esym
= sym
;
3891 e
->symtree
->n
.sym
->attr
.generic
= 1;
3894 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3902 gfc_error ("Symbol at %C is not appropriate for an expression");
3918 /* Match a variable, i.e. something that can be assigned to. This
3919 starts as a symbol, can be a structure component or an array
3920 reference. It can be a function if the function doesn't have a
3921 separate RESULT variable. If the symbol has not been previously
3922 seen, we assume it is a variable.
3924 This function is called by two interface functions:
3925 gfc_match_variable, which has host_flag = 1, and
3926 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3927 match of the symbol to the local scope. */
3930 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3932 gfc_symbol
*sym
, *dt_sym
;
3935 locus where
, old_loc
;
3938 /* Since nothing has any business being an lvalue in a module
3939 specification block, an interface block or a contains section,
3940 we force the changed_symbols mechanism to work by setting
3941 host_flag to 0. This prevents valid symbols that have the name
3942 of keywords, such as 'end', being turned into variables by
3943 failed matching to assignments for, e.g., END INTERFACE. */
3944 if (gfc_current_state () == COMP_MODULE
3945 || gfc_current_state () == COMP_SUBMODULE
3946 || gfc_current_state () == COMP_INTERFACE
3947 || gfc_current_state () == COMP_CONTAINS
)
3950 where
= gfc_current_locus
;
3951 m
= gfc_match_sym_tree (&st
, host_flag
);
3957 /* If this is an implicit do loop index and implicitly typed,
3958 it should not be host associated. */
3959 m
= check_for_implicit_index (&st
, &sym
);
3963 sym
->attr
.implied_index
= 0;
3965 gfc_set_sym_referenced (sym
);
3967 /* STRUCTUREs may share names with variables, but derived types may not. */
3968 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3969 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3971 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3972 gfc_error ("Derived type %qs cannot be used as a variable at %C",
3977 switch (sym
->attr
.flavor
)
3980 /* Everything is alright. */
3985 sym_flavor flavor
= FL_UNKNOWN
;
3987 gfc_gobble_whitespace ();
3989 if (sym
->attr
.external
|| sym
->attr
.procedure
3990 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3991 flavor
= FL_PROCEDURE
;
3993 /* If it is not a procedure, is not typed and is host associated,
3994 we cannot give it a flavor yet. */
3995 else if (sym
->ns
== gfc_current_ns
->parent
3996 && sym
->ts
.type
== BT_UNKNOWN
)
3999 /* These are definitive indicators that this is a variable. */
4000 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
4001 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
4002 flavor
= FL_VARIABLE
;
4004 if (flavor
!= FL_UNKNOWN
4005 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
4013 gfc_error ("Named constant at %C in an EQUIVALENCE");
4016 /* Otherwise this is checked for and an error given in the
4017 variable definition context checks. */
4021 /* Check for a nonrecursive function result variable. */
4022 if (sym
->attr
.function
4023 && !sym
->attr
.external
4024 && sym
->result
== sym
4025 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
4027 && sym
->ns
== gfc_current_ns
)
4029 && sym
->ns
== gfc_current_ns
->parent
)))
4031 /* If a function result is a derived type, then the derived
4032 type may still have to be resolved. */
4034 if (sym
->ts
.type
== BT_DERIVED
4035 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
4040 if (sym
->attr
.proc_pointer
4041 || replace_hidden_procptr_result (&sym
, &st
))
4044 /* Fall through to error */
4048 gfc_error ("%qs at %C is not a variable", sym
->name
);
4052 /* Special case for derived type variables that get their types
4053 via an IMPLICIT statement. This can't wait for the
4054 resolution phase. */
4057 gfc_namespace
* implicit_ns
;
4059 if (gfc_current_ns
->proc_name
== sym
)
4060 implicit_ns
= gfc_current_ns
;
4062 implicit_ns
= sym
->ns
;
4064 old_loc
= gfc_current_locus
;
4065 if (gfc_match_member_sep (sym
) == MATCH_YES
4066 && sym
->ts
.type
== BT_UNKNOWN
4067 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
4068 gfc_set_default_type (sym
, 0, implicit_ns
);
4069 gfc_current_locus
= old_loc
;
4072 expr
= gfc_get_expr ();
4074 expr
->expr_type
= EXPR_VARIABLE
;
4077 expr
->where
= where
;
4079 /* Now see if we have to do more. */
4080 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
4083 gfc_free_expr (expr
);
4093 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
4095 return match_variable (result
, equiv_flag
, 1);
4100 gfc_match_equiv_variable (gfc_expr
**result
)
4102 return match_variable (result
, 1, 0);