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)
2003 *ref
= gfc_get_ref ();
2004 (*ref
)->type
= REF_INQUIRY
;
2012 /* Match any additional specifications associated with the current
2013 variable like member references or substrings. If equiv_flag is
2014 set we only match stuff that is allowed inside an EQUIVALENCE
2015 statement. sub_flag tells whether we expect a type-bound procedure found
2016 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
2017 components, 'ppc_arg' determines whether the PPC may be called (with an
2018 argument list), or whether it may just be referred to as a pointer. */
2021 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
2024 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2025 gfc_ref
*substring
, *tail
, *tmp
;
2026 gfc_component
*component
;
2027 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
2028 gfc_expr
*tgt_expr
= NULL
;
2038 gfc_gobble_whitespace ();
2040 if (gfc_peek_ascii_char () == '[')
2042 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
2043 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2044 && CLASS_DATA (sym
)->attr
.dimension
))
2046 gfc_error ("Array section designator, e.g. '(:)', is required "
2047 "besides the coarray designator '[...]' at %C");
2050 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
2051 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2052 && !CLASS_DATA (sym
)->attr
.codimension
))
2054 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2060 if (sym
->assoc
&& sym
->assoc
->target
)
2061 tgt_expr
= sym
->assoc
->target
;
2063 /* For associate names, we may not yet know whether they are arrays or not.
2064 If the selector expression is unambiguously an array; eg. a full array
2065 or an array section, then the associate name must be an array and we can
2066 fix it now. Otherwise, if parentheses follow and it is not a character
2067 type, we have to assume that it actually is one for now. The final
2068 decision will be made at resolution, of course. */
2070 && gfc_peek_ascii_char () == '('
2071 && sym
->ts
.type
!= BT_CLASS
2072 && !sym
->attr
.dimension
)
2074 gfc_ref
*ref
= NULL
;
2076 if (!sym
->assoc
->dangling
&& tgt_expr
)
2078 if (tgt_expr
->expr_type
== EXPR_VARIABLE
)
2079 gfc_resolve_expr (tgt_expr
);
2081 ref
= tgt_expr
->ref
;
2082 for (; ref
; ref
= ref
->next
)
2083 if (ref
->type
== REF_ARRAY
2084 && (ref
->u
.ar
.type
== AR_FULL
2085 || ref
->u
.ar
.type
== AR_SECTION
))
2089 if (ref
|| (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
2091 && sym
->assoc
->st
->n
.sym
2092 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
2094 sym
->attr
.dimension
= 1;
2097 && sym
->assoc
->st
->n
.sym
2098 && sym
->assoc
->st
->n
.sym
->as
)
2099 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
2102 else if (sym
->ts
.type
== BT_CLASS
2104 && tgt_expr
->expr_type
== EXPR_VARIABLE
2105 && sym
->ts
.u
.derived
!= tgt_expr
->ts
.u
.derived
)
2107 gfc_resolve_expr (tgt_expr
);
2109 sym
->ts
.u
.derived
= tgt_expr
->ts
.u
.derived
;
2112 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
2113 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
2114 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
2115 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
2116 && !(gfc_matching_procptr_assignment
2117 && sym
->attr
.flavor
== FL_PROCEDURE
))
2118 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2119 && (CLASS_DATA (sym
)->attr
.dimension
2120 || CLASS_DATA (sym
)->attr
.codimension
)))
2124 tail
= extend_ref (primary
, tail
);
2125 tail
->type
= REF_ARRAY
;
2127 /* In EQUIVALENCE, we don't know yet whether we are seeing
2128 an array, character variable or array of character
2129 variables. We'll leave the decision till resolve time. */
2133 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2134 as
= CLASS_DATA (sym
)->as
;
2138 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
2139 as
? as
->corank
: 0);
2143 gfc_gobble_whitespace ();
2144 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
2146 tail
= extend_ref (primary
, tail
);
2147 tail
->type
= REF_ARRAY
;
2149 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2155 primary
->ts
= sym
->ts
;
2160 /* With DEC extensions, member separator may be '.' or '%'. */
2161 sep
= gfc_peek_ascii_char ();
2162 m
= gfc_match_member_sep (sym
);
2163 if (m
== MATCH_ERROR
)
2167 if (m
== MATCH_YES
&& sep
== '%'
2168 && primary
->ts
.type
!= BT_CLASS
2169 && primary
->ts
.type
!= BT_DERIVED
)
2172 old_loc
= gfc_current_locus
;
2173 mm
= gfc_match_name (name
);
2174 if (mm
== MATCH_YES
&& is_inquiry_ref (name
, &tmp
))
2176 gfc_current_locus
= old_loc
;
2179 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2180 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2181 gfc_set_default_type (sym
, 0, sym
->ns
);
2183 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2184 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2188 /* These target expressions can be resolved at any time. */
2189 permissible
= tgt_expr
&& tgt_expr
->symtree
&& tgt_expr
->symtree
->n
.sym
2190 && (tgt_expr
->symtree
->n
.sym
->attr
.use_assoc
2191 || tgt_expr
->symtree
->n
.sym
->attr
.host_assoc
2192 || tgt_expr
->symtree
->n
.sym
->attr
.if_source
2194 permissible
= permissible
2195 || (tgt_expr
&& tgt_expr
->expr_type
== EXPR_OP
);
2199 gfc_resolve_expr (tgt_expr
);
2200 sym
->ts
= tgt_expr
->ts
;
2203 if (sym
->ts
.type
== BT_UNKNOWN
)
2205 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2209 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2210 && m
== MATCH_YES
&& !inquiry
)
2212 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2217 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
&& !inquiry
)
2219 goto check_substring
;
2222 sym
= sym
->ts
.u
.derived
;
2231 m
= gfc_match_name (name
);
2233 gfc_error ("Expected structure component name at %C");
2238 if (primary
->ts
.type
!= BT_CLASS
&& primary
->ts
.type
!= BT_DERIVED
)
2240 inquiry
= is_inquiry_ref (name
, &tmp
);
2252 if (!gfc_notify_std (GFC_STD_F2008
,
2253 "RE or IM part_ref at %C"))
2258 if (!gfc_notify_std (GFC_STD_F2003
,
2259 "KIND part_ref at %C"))
2264 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2269 if ((tmp
->u
.i
== INQUIRY_RE
|| tmp
->u
.i
== INQUIRY_IM
)
2270 && primary
->ts
.type
!= BT_COMPLEX
)
2272 gfc_error ("The RE or IM part_ref at %C must be "
2273 "applied to a COMPLEX expression");
2276 else if (tmp
->u
.i
== INQUIRY_LEN
2277 && primary
->ts
.type
!= BT_CHARACTER
)
2279 gfc_error ("The LEN part_ref at %C must be applied "
2280 "to a CHARACTER expression");
2284 if (primary
->ts
.type
!= BT_UNKNOWN
)
2291 if (sym
&& sym
->f2k_derived
)
2292 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2298 gfc_symbol
* tbp_sym
;
2303 gcc_assert (!tail
|| !tail
->next
);
2305 if (!(primary
->expr_type
== EXPR_VARIABLE
2306 || (primary
->expr_type
== EXPR_STRUCTURE
2307 && primary
->symtree
&& primary
->symtree
->n
.sym
2308 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2311 if (tbp
->n
.tb
->is_generic
)
2314 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2316 primary
->expr_type
= EXPR_COMPCALL
;
2317 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2318 primary
->value
.compcall
.name
= tbp
->name
;
2319 primary
->value
.compcall
.ignore_pass
= 0;
2320 primary
->value
.compcall
.assign
= 0;
2321 primary
->value
.compcall
.base_object
= NULL
;
2322 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2324 primary
->ts
= tbp_sym
->ts
;
2326 gfc_clear_ts (&primary
->ts
);
2328 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2329 &primary
->value
.compcall
.actual
);
2330 if (m
== MATCH_ERROR
)
2335 primary
->value
.compcall
.actual
= NULL
;
2338 gfc_error ("Expected argument list at %C");
2346 if (!inquiry
&& !intrinsic
)
2347 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2351 /* In some cases, returning MATCH_NO gives a better error message. Most
2352 cases return "Unclassifiable statement at..." */
2353 if (intrinsic
&& !inquiry
)
2355 else if (component
== NULL
&& !inquiry
)
2358 /* Extend the reference chain determined by gfc_find_component or
2360 if (primary
->ref
== NULL
)
2364 /* Set by the for loop below for the last component ref. */
2365 gcc_assert (tail
!= NULL
);
2369 /* The reference chain may be longer than one hop for union
2370 subcomponents; find the new tail. */
2371 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2374 if (tmp
&& tmp
->type
== REF_INQUIRY
)
2376 if (!primary
->where
.lb
|| !primary
->where
.nextc
)
2377 primary
->where
= gfc_current_locus
;
2378 gfc_simplify_expr (primary
, 0);
2380 if (primary
->expr_type
== EXPR_CONSTANT
)
2387 if (!gfc_notify_std (GFC_STD_F2008
, "RE or IM part_ref at %C"))
2390 if (primary
->ts
.type
!= BT_COMPLEX
)
2392 gfc_error ("The RE or IM part_ref at %C must be "
2393 "applied to a COMPLEX expression");
2396 primary
->ts
.type
= BT_REAL
;
2400 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2403 if (primary
->ts
.type
!= BT_CHARACTER
)
2405 gfc_error ("The LEN part_ref at %C must be applied "
2406 "to a CHARACTER expression");
2409 primary
->ts
.u
.cl
= NULL
;
2410 primary
->ts
.type
= BT_INTEGER
;
2411 primary
->ts
.kind
= gfc_default_integer_kind
;
2415 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
2418 if (primary
->ts
.type
== BT_CLASS
2419 || primary
->ts
.type
== BT_DERIVED
)
2421 gfc_error ("The KIND part_ref at %C must be applied "
2422 "to an expression of intrinsic type");
2425 primary
->ts
.type
= BT_INTEGER
;
2426 primary
->ts
.kind
= gfc_default_integer_kind
;
2436 primary
->ts
= component
->ts
;
2438 if (component
->attr
.proc_pointer
&& ppc_arg
)
2440 /* Procedure pointer component call: Look for argument list. */
2441 m
= gfc_match_actual_arglist (sub_flag
,
2442 &primary
->value
.compcall
.actual
);
2443 if (m
== MATCH_ERROR
)
2446 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2447 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2449 gfc_error ("Procedure pointer component %qs requires an "
2450 "argument list at %C", component
->name
);
2455 primary
->expr_type
= EXPR_PPC
;
2460 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2462 tail
= extend_ref (primary
, tail
);
2463 tail
->type
= REF_ARRAY
;
2465 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2466 component
->as
->corank
);
2470 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2471 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2473 tail
= extend_ref (primary
, tail
);
2474 tail
->type
= REF_ARRAY
;
2476 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2478 CLASS_DATA (component
)->as
->corank
);
2484 /* In principle, we could have eg. expr%re%kind so we must allow for
2485 this possibility. */
2486 if (gfc_match_char ('%') == MATCH_YES
)
2488 if (component
&& (component
->ts
.type
== BT_DERIVED
2489 || component
->ts
.type
== BT_CLASS
))
2490 sym
= component
->ts
.u
.derived
;
2496 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2497 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2500 if (component
->ts
.type
== BT_DERIVED
|| component
->ts
.type
== BT_CLASS
)
2501 sym
= component
->ts
.u
.derived
;
2506 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2508 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2510 gfc_set_default_type (sym
, 0, sym
->ns
);
2511 primary
->ts
= sym
->ts
;
2516 if (primary
->ts
.type
== BT_CHARACTER
)
2518 bool def
= primary
->ts
.deferred
== 1;
2519 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2523 primary
->ref
= substring
;
2525 tail
->next
= substring
;
2527 if (primary
->expr_type
== EXPR_CONSTANT
)
2528 primary
->expr_type
= EXPR_SUBSTRING
;
2531 primary
->ts
.u
.cl
= NULL
;
2538 gfc_clear_ts (&primary
->ts
);
2539 gfc_clear_ts (&sym
->ts
);
2549 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2550 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2552 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2557 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2559 gfc_error ("Coindexed procedure-pointer component at %C");
2567 /* Given an expression that is a variable, figure out what the
2568 ultimate variable's type and attribute is, traversing the reference
2569 structures if necessary.
2571 This subroutine is trickier than it looks. We start at the base
2572 symbol and store the attribute. Component references load a
2573 completely new attribute.
2575 A couple of rules come into play. Subobjects of targets are always
2576 targets themselves. If we see a component that goes through a
2577 pointer, then the expression must also be a target, since the
2578 pointer is associated with something (if it isn't core will soon be
2579 dumped). If we see a full part or section of an array, the
2580 expression is also an array.
2582 We can have at most one full array reference. */
2585 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2587 int dimension
, codimension
, pointer
, allocatable
, target
;
2588 symbol_attribute attr
;
2591 gfc_component
*comp
;
2592 bool has_inquiry_part
;
2594 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2595 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2597 sym
= expr
->symtree
->n
.sym
;
2600 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2602 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2603 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2604 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2605 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2609 dimension
= attr
.dimension
;
2610 codimension
= attr
.codimension
;
2611 pointer
= attr
.pointer
;
2612 allocatable
= attr
.allocatable
;
2615 target
= attr
.target
;
2616 if (pointer
|| attr
.proc_pointer
)
2619 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2622 has_inquiry_part
= false;
2623 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2624 if (ref
->type
== REF_INQUIRY
)
2626 has_inquiry_part
= true;
2630 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2635 switch (ref
->u
.ar
.type
)
2642 allocatable
= pointer
= 0;
2647 /* Handle coarrays. */
2648 if (ref
->u
.ar
.dimen
> 0)
2649 allocatable
= pointer
= 0;
2653 /* For standard conforming code, AR_UNKNOWN should not happen.
2654 For nonconforming code, gfortran can end up here. Treat it
2662 comp
= ref
->u
.c
.component
;
2664 if (ts
!= NULL
&& !has_inquiry_part
)
2667 /* Don't set the string length if a substring reference
2669 if (ts
->type
== BT_CHARACTER
2670 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2674 if (comp
->ts
.type
== BT_CLASS
)
2676 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2677 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2678 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2682 codimension
= comp
->attr
.codimension
;
2683 pointer
= comp
->attr
.pointer
;
2684 allocatable
= comp
->attr
.allocatable
;
2686 if (pointer
|| attr
.proc_pointer
)
2693 allocatable
= pointer
= 0;
2697 attr
.dimension
= dimension
;
2698 attr
.codimension
= codimension
;
2699 attr
.pointer
= pointer
;
2700 attr
.allocatable
= allocatable
;
2701 attr
.target
= target
;
2702 attr
.save
= sym
->attr
.save
;
2708 /* Return the attribute from a general expression. */
2711 gfc_expr_attr (gfc_expr
*e
)
2713 symbol_attribute attr
;
2715 switch (e
->expr_type
)
2718 attr
= gfc_variable_attr (e
, NULL
);
2722 gfc_clear_attr (&attr
);
2724 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2726 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2728 if (sym
->ts
.type
== BT_CLASS
)
2730 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2731 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2732 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2735 else if (e
->value
.function
.isym
2736 && e
->value
.function
.isym
->transformational
2737 && e
->ts
.type
== BT_CLASS
)
2738 attr
= CLASS_DATA (e
)->attr
;
2740 attr
= gfc_variable_attr (e
, NULL
);
2742 /* TODO: NULL() returns pointers. May have to take care of this
2748 gfc_clear_attr (&attr
);
2756 /* Given an expression, figure out what the ultimate expression
2757 attribute is. This routine is similar to gfc_variable_attr with
2758 parts of gfc_expr_attr, but focuses more on the needs of
2759 coarrays. For coarrays a codimension attribute is kind of
2760 "infectious" being propagated once set and never cleared.
2761 The coarray_comp is only set, when the expression refs a coarray
2762 component. REFS_COMP is set when present to true only, when this EXPR
2763 refs a (non-_data) component. To check whether EXPR refs an allocatable
2764 component in a derived type coarray *refs_comp needs to be set and
2765 coarray_comp has to false. */
2767 static symbol_attribute
2768 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2770 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2771 symbol_attribute attr
;
2774 gfc_component
*comp
;
2776 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2777 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2779 sym
= expr
->symtree
->n
.sym
;
2780 gfc_clear_attr (&attr
);
2785 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2787 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2788 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2789 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2790 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2791 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2792 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2796 dimension
= sym
->attr
.dimension
;
2797 codimension
= sym
->attr
.codimension
;
2798 pointer
= sym
->attr
.pointer
;
2799 allocatable
= sym
->attr
.allocatable
;
2800 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2801 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2802 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2803 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2806 target
= coarray_comp
= 0;
2807 if (pointer
|| attr
.proc_pointer
)
2810 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2815 switch (ref
->u
.ar
.type
)
2823 /* Handle coarrays. */
2824 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2825 allocatable
= pointer
= 0;
2829 /* If any of start, end or stride is not integer, there will
2830 already have been an error issued. */
2832 gfc_get_errors (NULL
, &errors
);
2834 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2840 comp
= ref
->u
.c
.component
;
2842 if (comp
->ts
.type
== BT_CLASS
)
2844 /* Set coarray_comp only, when this component introduces the
2846 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2847 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2848 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2849 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2853 /* Set coarray_comp only, when this component introduces the
2855 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2856 codimension
|= comp
->attr
.codimension
;
2857 pointer
= comp
->attr
.pointer
;
2858 allocatable
= comp
->attr
.allocatable
;
2861 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2862 && (ref
->next
== NULL
2863 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2866 if (pointer
|| attr
.proc_pointer
)
2873 allocatable
= pointer
= 0;
2877 attr
.dimension
= dimension
;
2878 attr
.codimension
= codimension
;
2879 attr
.pointer
= pointer
;
2880 attr
.allocatable
= allocatable
;
2881 attr
.target
= target
;
2882 attr
.save
= sym
->attr
.save
;
2883 attr
.coarray_comp
= coarray_comp
;
2890 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2892 symbol_attribute attr
;
2894 switch (e
->expr_type
)
2897 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2901 gfc_clear_attr (&attr
);
2903 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2905 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2907 if (sym
->ts
.type
== BT_CLASS
)
2909 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2910 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2911 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2912 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2913 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2914 ->attr
.pointer_comp
;
2917 else if (e
->symtree
)
2918 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2920 gfc_clear_attr (&attr
);
2924 gfc_clear_attr (&attr
);
2932 /* Match a structure constructor. The initial symbol has already been
2935 typedef struct gfc_structure_ctor_component
2940 struct gfc_structure_ctor_component
* next
;
2942 gfc_structure_ctor_component
;
2944 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2947 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2950 gfc_free_expr (comp
->val
);
2955 /* Translate the component list into the actual constructor by sorting it in
2956 the order required; this also checks along the way that each and every
2957 component actually has an initializer and handles default initializers
2958 for components without explicit value given. */
2960 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2961 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2963 gfc_structure_ctor_component
*comp_iter
;
2964 gfc_component
*comp
;
2966 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2968 gfc_structure_ctor_component
**next_ptr
;
2969 gfc_expr
*value
= NULL
;
2971 /* Try to find the initializer for the current component by name. */
2972 next_ptr
= comp_head
;
2973 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2975 if (!strcmp (comp_iter
->name
, comp
->name
))
2977 next_ptr
= &comp_iter
->next
;
2980 /* If an extension, try building the parent derived type by building
2981 a value expression for the parent derived type and calling self. */
2982 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2984 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2986 &gfc_current_locus
);
2987 value
->ts
= comp
->ts
;
2989 if (!build_actual_constructor (comp_head
,
2990 &value
->value
.constructor
,
2991 comp
->ts
.u
.derived
))
2993 gfc_free_expr (value
);
2997 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3001 /* If it was not found, try the default initializer if there's any;
3002 otherwise, it's an error unless this is a deferred parameter. */
3005 if (comp
->initializer
)
3007 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
3008 "with missing optional arguments at %C"))
3010 value
= gfc_copy_expr (comp
->initializer
);
3012 else if (comp
->attr
.allocatable
3013 || (comp
->ts
.type
== BT_CLASS
3014 && CLASS_DATA (comp
)->attr
.allocatable
))
3016 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
3017 "allocatable component %qs given in the "
3018 "structure constructor at %C", comp
->name
))
3021 else if (!comp
->attr
.artificial
)
3023 gfc_error ("No initializer for component %qs given in the"
3024 " structure constructor at %C", comp
->name
);
3029 value
= comp_iter
->val
;
3031 /* Add the value to the constructor chain built. */
3032 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3034 /* Remove the entry from the component list. We don't want the expression
3035 value to be free'd, so set it to NULL. */
3038 *next_ptr
= comp_iter
->next
;
3039 comp_iter
->val
= NULL
;
3040 gfc_free_structure_ctor_component (comp_iter
);
3048 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
3049 gfc_actual_arglist
**arglist
,
3052 gfc_actual_arglist
*actual
;
3053 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
3054 gfc_constructor_base ctor_head
= NULL
;
3055 gfc_component
*comp
; /* Is set NULL when named component is first seen */
3056 const char* last_name
= NULL
;
3060 expr
= parent
? *cexpr
: e
;
3061 old_locus
= gfc_current_locus
;
3063 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3065 gfc_current_locus
= expr
->where
;
3067 comp_tail
= comp_head
= NULL
;
3069 if (!parent
&& sym
->attr
.abstract
)
3071 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3072 sym
->name
, &expr
->where
);
3076 comp
= sym
->components
;
3077 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
3080 gfc_component
*this_comp
= NULL
;
3083 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
3086 comp_tail
->next
= gfc_get_structure_ctor_component ();
3087 comp_tail
= comp_tail
->next
;
3091 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
3092 " constructor with named arguments at %C"))
3095 comp_tail
->name
= xstrdup (actual
->name
);
3096 last_name
= comp_tail
->name
;
3101 /* Components without name are not allowed after the first named
3102 component initializer! */
3103 if (!comp
|| comp
->attr
.artificial
)
3106 gfc_error ("Component initializer without name after component"
3107 " named %s at %L", last_name
,
3108 actual
->expr
? &actual
->expr
->where
3109 : &gfc_current_locus
);
3111 gfc_error ("Too many components in structure constructor at "
3112 "%L", actual
->expr
? &actual
->expr
->where
3113 : &gfc_current_locus
);
3117 comp_tail
->name
= xstrdup (comp
->name
);
3120 /* Find the current component in the structure definition and check
3121 its access is not private. */
3123 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
3126 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
3127 false, false, NULL
);
3128 comp
= NULL
; /* Reset needed! */
3131 /* Here we can check if a component name is given which does not
3132 correspond to any component of the defined structure. */
3136 /* For a constant string constructor, make sure the length is
3137 correct; truncate of fill with blanks if needed. */
3138 if (this_comp
->ts
.type
== BT_CHARACTER
&& !this_comp
->attr
.allocatable
3139 && this_comp
->ts
.u
.cl
&& this_comp
->ts
.u
.cl
->length
3140 && this_comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3141 && actual
->expr
->ts
.type
== BT_CHARACTER
3142 && actual
->expr
->expr_type
== EXPR_CONSTANT
)
3145 c
= gfc_mpz_get_hwi (this_comp
->ts
.u
.cl
->length
->value
.integer
);
3146 e1
= actual
->expr
->value
.character
.length
;
3152 dest
= gfc_get_wide_string (c
+ 1);
3154 to
= e1
< c
? e1
: c
;
3155 for (i
= 0; i
< to
; i
++)
3156 dest
[i
] = actual
->expr
->value
.character
.string
[i
];
3158 for (i
= e1
; i
< c
; i
++)
3162 free (actual
->expr
->value
.character
.string
);
3164 actual
->expr
->value
.character
.length
= c
;
3165 actual
->expr
->value
.character
.string
= dest
;
3167 if (warn_line_truncation
&& c
< e1
)
3168 gfc_warning_now (OPT_Wcharacter_truncation
,
3169 "CHARACTER expression will be truncated "
3170 "in constructor (%ld/%ld) at %L", (long int) c
,
3171 (long int) e1
, &actual
->expr
->where
);
3175 comp_tail
->val
= actual
->expr
;
3176 if (actual
->expr
!= NULL
)
3177 comp_tail
->where
= actual
->expr
->where
;
3178 actual
->expr
= NULL
;
3180 /* Check if this component is already given a value. */
3181 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
3182 comp_iter
= comp_iter
->next
)
3184 gcc_assert (comp_iter
);
3185 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
3187 gfc_error ("Component %qs is initialized twice in the structure"
3188 " constructor at %L", comp_tail
->name
,
3189 comp_tail
->val
? &comp_tail
->where
3190 : &gfc_current_locus
);
3195 /* F2008, R457/C725, for PURE C1283. */
3196 if (this_comp
->attr
.pointer
&& comp_tail
->val
3197 && gfc_is_coindexed (comp_tail
->val
))
3199 gfc_error ("Coindexed expression to pointer component %qs in "
3200 "structure constructor at %L", comp_tail
->name
,
3205 /* If not explicitly a parent constructor, gather up the components
3207 if (comp
&& comp
== sym
->components
3208 && sym
->attr
.extension
3210 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
3212 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
3215 gfc_actual_arglist
*arg_null
= NULL
;
3217 actual
->expr
= comp_tail
->val
;
3218 comp_tail
->val
= NULL
;
3220 m
= gfc_convert_to_structure_constructor (NULL
,
3221 comp
->ts
.u
.derived
, &comp_tail
->val
,
3222 comp
->ts
.u
.derived
->attr
.zero_comp
3223 ? &arg_null
: &actual
, true);
3227 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
3236 if (parent
&& !comp
)
3240 actual
= actual
->next
;
3243 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
3246 /* No component should be left, as this should have caused an error in the
3247 loop constructing the component-list (name that does not correspond to any
3248 component in the structure definition). */
3249 if (comp_head
&& sym
->attr
.extension
)
3251 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3253 gfc_error ("component %qs at %L has already been set by a "
3254 "parent derived type constructor", comp_iter
->name
,
3260 gcc_assert (!comp_head
);
3264 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
3265 expr
->ts
.u
.derived
= sym
;
3266 expr
->value
.constructor
= ctor_head
;
3271 expr
->ts
.u
.derived
= sym
;
3273 expr
->ts
.type
= BT_DERIVED
;
3274 expr
->value
.constructor
= ctor_head
;
3275 expr
->expr_type
= EXPR_STRUCTURE
;
3278 gfc_current_locus
= old_locus
;
3284 gfc_current_locus
= old_locus
;
3286 for (comp_iter
= comp_head
; comp_iter
; )
3288 gfc_structure_ctor_component
*next
= comp_iter
->next
;
3289 gfc_free_structure_ctor_component (comp_iter
);
3292 gfc_constructor_free (ctor_head
);
3299 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
3303 gfc_symtree
*symtree
;
3305 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
3307 e
= gfc_get_expr ();
3308 e
->symtree
= symtree
;
3309 e
->expr_type
= EXPR_FUNCTION
;
3310 e
->where
= gfc_current_locus
;
3312 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
3313 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
3314 e
->value
.function
.esym
= sym
;
3315 e
->symtree
->n
.sym
->attr
.generic
= 1;
3317 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3324 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
3330 /* If a structure constructor is in a DATA statement, then each entity
3331 in the structure constructor must be a constant. Try to reduce the
3333 if (gfc_in_match_data ())
3334 gfc_reduce_init_expr (e
);
3341 /* If the symbol is an implicit do loop index and implicitly typed,
3342 it should not be host associated. Provide a symtree from the
3343 current namespace. */
3345 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
3347 if ((*sym
)->attr
.flavor
== FL_VARIABLE
3348 && (*sym
)->ns
!= gfc_current_ns
3349 && (*sym
)->attr
.implied_index
3350 && (*sym
)->attr
.implicit_type
3351 && !(*sym
)->attr
.use_assoc
)
3354 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
3357 *sym
= (*st
)->n
.sym
;
3363 /* Procedure pointer as function result: Replace the function symbol by the
3364 auto-generated hidden result variable named "ppr@". */
3367 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
3369 /* Check for procedure pointer result variable. */
3370 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
3371 && (*sym
)->result
&& (*sym
)->result
!= *sym
3372 && (*sym
)->result
->attr
.proc_pointer
3373 && (*sym
) == gfc_current_ns
->proc_name
3374 && (*sym
) == (*sym
)->result
->ns
->proc_name
3375 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3377 /* Automatic replacement with "hidden" result variable. */
3378 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3379 *sym
= (*sym
)->result
;
3380 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3387 /* Matches a variable name followed by anything that might follow it--
3388 array reference, argument list of a function, etc. */
3391 gfc_match_rvalue (gfc_expr
**result
)
3393 gfc_actual_arglist
*actual_arglist
;
3394 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3397 gfc_symtree
*symtree
;
3398 locus where
, old_loc
;
3406 m
= gfc_match ("%%loc");
3409 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3411 strncpy (name
, "loc", 4);
3416 m
= gfc_match_name (name
);
3421 /* Check if the symbol exists. */
3422 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3425 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3426 type. For derived types we create a generic symbol which links to the
3427 derived type symbol; STRUCTUREs are simpler and must not conflict with
3430 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3432 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3434 if (gfc_find_state (COMP_INTERFACE
)
3435 && !gfc_current_ns
->has_import_set
)
3436 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3438 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3444 sym
= symtree
->n
.sym
;
3446 where
= gfc_current_locus
;
3448 replace_hidden_procptr_result (&sym
, &symtree
);
3450 /* If this is an implicit do loop index and implicitly typed,
3451 it should not be host associated. */
3452 m
= check_for_implicit_index (&symtree
, &sym
);
3456 gfc_set_sym_referenced (sym
);
3457 sym
->attr
.implied_index
= 0;
3459 if (sym
->attr
.function
&& sym
->result
== sym
)
3461 /* See if this is a directly recursive function call. */
3462 gfc_gobble_whitespace ();
3463 if (sym
->attr
.recursive
3464 && gfc_peek_ascii_char () == '('
3465 && gfc_current_ns
->proc_name
== sym
3466 && !sym
->attr
.dimension
)
3468 gfc_error ("%qs at %C is the name of a recursive function "
3469 "and so refers to the result variable. Use an "
3470 "explicit RESULT variable for direct recursion "
3471 "(12.5.2.1)", sym
->name
);
3475 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3479 && (sym
->ns
== gfc_current_ns
3480 || sym
->ns
== gfc_current_ns
->parent
))
3482 gfc_entry_list
*el
= NULL
;
3484 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3490 if (gfc_matching_procptr_assignment
)
3492 /* It can be a procedure or a derived-type procedure or a not-yet-known
3494 if (sym
->attr
.flavor
!= FL_UNKNOWN
3495 && sym
->attr
.flavor
!= FL_PROCEDURE
3496 && sym
->attr
.flavor
!= FL_PARAMETER
3497 && sym
->attr
.flavor
!= FL_VARIABLE
)
3499 gfc_error ("Symbol at %C is not appropriate for an expression");
3505 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3508 if (sym
->attr
.generic
)
3509 goto generic_function
;
3511 switch (sym
->attr
.flavor
)
3515 e
= gfc_get_expr ();
3517 e
->expr_type
= EXPR_VARIABLE
;
3518 e
->symtree
= symtree
;
3520 m
= gfc_match_varspec (e
, 0, false, true);
3524 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3525 end up here. Unfortunately, sym->value->expr_type is set to
3526 EXPR_CONSTANT, and so the if () branch would be followed without
3527 the !sym->as check. */
3528 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3529 e
= gfc_copy_expr (sym
->value
);
3532 e
= gfc_get_expr ();
3533 e
->expr_type
= EXPR_VARIABLE
;
3536 e
->symtree
= symtree
;
3537 m
= gfc_match_varspec (e
, 0, false, true);
3539 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3542 /* Variable array references to derived type parameters cause
3543 all sorts of headaches in simplification. Treating such
3544 expressions as variable works just fine for all array
3546 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3548 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3549 if (ref
->type
== REF_ARRAY
)
3552 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3558 e
= gfc_get_expr ();
3559 e
->expr_type
= EXPR_VARIABLE
;
3560 e
->symtree
= symtree
;
3568 sym
= gfc_use_derived (sym
);
3572 goto generic_function
;
3575 /* If we're here, then the name is known to be the name of a
3576 procedure, yet it is not sure to be the name of a function. */
3579 /* Procedure Pointer Assignments. */
3581 if (gfc_matching_procptr_assignment
)
3583 gfc_gobble_whitespace ();
3584 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3585 /* Parse functions returning a procptr. */
3588 e
= gfc_get_expr ();
3589 e
->expr_type
= EXPR_VARIABLE
;
3590 e
->symtree
= symtree
;
3591 m
= gfc_match_varspec (e
, 0, false, true);
3592 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3593 && sym
->ts
.type
== BT_UNKNOWN
3594 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3602 if (sym
->attr
.subroutine
)
3604 gfc_error ("Unexpected use of subroutine name %qs at %C",
3610 /* At this point, the name has to be a non-statement function.
3611 If the name is the same as the current function being
3612 compiled, then we have a variable reference (to the function
3613 result) if the name is non-recursive. */
3615 st
= gfc_enclosing_unit (NULL
);
3618 && st
->state
== COMP_FUNCTION
3620 && !sym
->attr
.recursive
)
3622 e
= gfc_get_expr ();
3623 e
->symtree
= symtree
;
3624 e
->expr_type
= EXPR_VARIABLE
;
3626 m
= gfc_match_varspec (e
, 0, false, true);
3630 /* Match a function reference. */
3632 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3635 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3636 gfc_error ("Statement function %qs requires argument list at %C",
3639 gfc_error ("Function %qs requires an argument list at %C",
3652 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3653 sym
= symtree
->n
.sym
;
3655 replace_hidden_procptr_result (&sym
, &symtree
);
3657 e
= gfc_get_expr ();
3658 e
->symtree
= symtree
;
3659 e
->expr_type
= EXPR_FUNCTION
;
3660 e
->value
.function
.actual
= actual_arglist
;
3661 e
->where
= gfc_current_locus
;
3663 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3664 && CLASS_DATA (sym
)->as
)
3665 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3666 else if (sym
->as
!= NULL
)
3667 e
->rank
= sym
->as
->rank
;
3669 if (!sym
->attr
.function
3670 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3676 /* Check here for the existence of at least one argument for the
3677 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3678 argument(s) given will be checked in gfc_iso_c_func_interface,
3679 during resolution of the function call. */
3680 if (sym
->attr
.is_iso_c
== 1
3681 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3682 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3683 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3684 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3686 /* make sure we were given a param */
3687 if (actual_arglist
== NULL
)
3689 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3695 if (sym
->result
== NULL
)
3698 gfc_gobble_whitespace ();
3700 if (gfc_peek_ascii_char() == '%')
3702 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3703 "function reference at %C");
3713 /* Special case for derived type variables that get their types
3714 via an IMPLICIT statement. This can't wait for the
3715 resolution phase. */
3717 old_loc
= gfc_current_locus
;
3718 if (gfc_match_member_sep (sym
) == MATCH_YES
3719 && sym
->ts
.type
== BT_UNKNOWN
3720 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3721 gfc_set_default_type (sym
, 0, sym
->ns
);
3722 gfc_current_locus
= old_loc
;
3724 /* If the symbol has a (co)dimension attribute, the expression is a
3727 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3729 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3735 e
= gfc_get_expr ();
3736 e
->symtree
= symtree
;
3737 e
->expr_type
= EXPR_VARIABLE
;
3738 m
= gfc_match_varspec (e
, 0, false, true);
3742 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3743 && (CLASS_DATA (sym
)->attr
.dimension
3744 || CLASS_DATA (sym
)->attr
.codimension
))
3746 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3752 e
= gfc_get_expr ();
3753 e
->symtree
= symtree
;
3754 e
->expr_type
= EXPR_VARIABLE
;
3755 m
= gfc_match_varspec (e
, 0, false, true);
3759 /* Name is not an array, so we peek to see if a '(' implies a
3760 function call or a substring reference. Otherwise the
3761 variable is just a scalar. */
3763 gfc_gobble_whitespace ();
3764 if (gfc_peek_ascii_char () != '(')
3766 /* Assume a scalar variable */
3767 e
= gfc_get_expr ();
3768 e
->symtree
= symtree
;
3769 e
->expr_type
= EXPR_VARIABLE
;
3771 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3777 /*FIXME:??? gfc_match_varspec does set this for us: */
3779 m
= gfc_match_varspec (e
, 0, false, true);
3783 /* See if this is a function reference with a keyword argument
3784 as first argument. We do this because otherwise a spurious
3785 symbol would end up in the symbol table. */
3787 old_loc
= gfc_current_locus
;
3788 m2
= gfc_match (" ( %n =", argname
);
3789 gfc_current_locus
= old_loc
;
3791 e
= gfc_get_expr ();
3792 e
->symtree
= symtree
;
3794 if (m2
!= MATCH_YES
)
3796 /* Try to figure out whether we're dealing with a character type.
3797 We're peeking ahead here, because we don't want to call
3798 match_substring if we're dealing with an implicitly typed
3799 non-character variable. */
3800 implicit_char
= false;
3801 if (sym
->ts
.type
== BT_UNKNOWN
)
3803 ts
= gfc_get_default_type (sym
->name
, NULL
);
3804 if (ts
->type
== BT_CHARACTER
)
3805 implicit_char
= true;
3808 /* See if this could possibly be a substring reference of a name
3809 that we're not sure is a variable yet. */
3811 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3812 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3815 e
->expr_type
= EXPR_VARIABLE
;
3817 if (sym
->attr
.flavor
!= FL_VARIABLE
3818 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3825 if (sym
->ts
.type
== BT_UNKNOWN
3826 && !gfc_set_default_type (sym
, 1, NULL
))
3840 /* Give up, assume we have a function. */
3842 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3843 sym
= symtree
->n
.sym
;
3844 e
->expr_type
= EXPR_FUNCTION
;
3846 if (!sym
->attr
.function
3847 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3855 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3857 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3865 /* If our new function returns a character, array or structure
3866 type, it might have subsequent references. */
3868 m
= gfc_match_varspec (e
, 0, false, true);
3875 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3876 specially. Creates a generic symbol for derived types. */
3877 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3879 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3880 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3881 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3883 e
= gfc_get_expr ();
3884 e
->symtree
= symtree
;
3885 e
->expr_type
= EXPR_FUNCTION
;
3887 if (gfc_fl_struct (sym
->attr
.flavor
))
3889 e
->value
.function
.esym
= sym
;
3890 e
->symtree
->n
.sym
->attr
.generic
= 1;
3893 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3901 gfc_error ("Symbol at %C is not appropriate for an expression");
3917 /* Match a variable, i.e. something that can be assigned to. This
3918 starts as a symbol, can be a structure component or an array
3919 reference. It can be a function if the function doesn't have a
3920 separate RESULT variable. If the symbol has not been previously
3921 seen, we assume it is a variable.
3923 This function is called by two interface functions:
3924 gfc_match_variable, which has host_flag = 1, and
3925 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3926 match of the symbol to the local scope. */
3929 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3931 gfc_symbol
*sym
, *dt_sym
;
3934 locus where
, old_loc
;
3937 /* Since nothing has any business being an lvalue in a module
3938 specification block, an interface block or a contains section,
3939 we force the changed_symbols mechanism to work by setting
3940 host_flag to 0. This prevents valid symbols that have the name
3941 of keywords, such as 'end', being turned into variables by
3942 failed matching to assignments for, e.g., END INTERFACE. */
3943 if (gfc_current_state () == COMP_MODULE
3944 || gfc_current_state () == COMP_SUBMODULE
3945 || gfc_current_state () == COMP_INTERFACE
3946 || gfc_current_state () == COMP_CONTAINS
)
3949 where
= gfc_current_locus
;
3950 m
= gfc_match_sym_tree (&st
, host_flag
);
3956 /* If this is an implicit do loop index and implicitly typed,
3957 it should not be host associated. */
3958 m
= check_for_implicit_index (&st
, &sym
);
3962 sym
->attr
.implied_index
= 0;
3964 gfc_set_sym_referenced (sym
);
3966 /* STRUCTUREs may share names with variables, but derived types may not. */
3967 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3968 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3970 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3971 gfc_error ("Derived type %qs cannot be used as a variable at %C",
3976 switch (sym
->attr
.flavor
)
3979 /* Everything is alright. */
3984 sym_flavor flavor
= FL_UNKNOWN
;
3986 gfc_gobble_whitespace ();
3988 if (sym
->attr
.external
|| sym
->attr
.procedure
3989 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3990 flavor
= FL_PROCEDURE
;
3992 /* If it is not a procedure, is not typed and is host associated,
3993 we cannot give it a flavor yet. */
3994 else if (sym
->ns
== gfc_current_ns
->parent
3995 && sym
->ts
.type
== BT_UNKNOWN
)
3998 /* These are definitive indicators that this is a variable. */
3999 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
4000 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
4001 flavor
= FL_VARIABLE
;
4003 if (flavor
!= FL_UNKNOWN
4004 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
4012 gfc_error ("Named constant at %C in an EQUIVALENCE");
4015 /* Otherwise this is checked for and an error given in the
4016 variable definition context checks. */
4020 /* Check for a nonrecursive function result variable. */
4021 if (sym
->attr
.function
4022 && !sym
->attr
.external
4023 && sym
->result
== sym
4024 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
4026 && sym
->ns
== gfc_current_ns
)
4028 && sym
->ns
== gfc_current_ns
->parent
)))
4030 /* If a function result is a derived type, then the derived
4031 type may still have to be resolved. */
4033 if (sym
->ts
.type
== BT_DERIVED
4034 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
4039 if (sym
->attr
.proc_pointer
4040 || replace_hidden_procptr_result (&sym
, &st
))
4043 /* Fall through to error */
4047 gfc_error ("%qs at %C is not a variable", sym
->name
);
4051 /* Special case for derived type variables that get their types
4052 via an IMPLICIT statement. This can't wait for the
4053 resolution phase. */
4056 gfc_namespace
* implicit_ns
;
4058 if (gfc_current_ns
->proc_name
== sym
)
4059 implicit_ns
= gfc_current_ns
;
4061 implicit_ns
= sym
->ns
;
4063 old_loc
= gfc_current_locus
;
4064 if (gfc_match_member_sep (sym
) == MATCH_YES
4065 && sym
->ts
.type
== BT_UNKNOWN
4066 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
4067 gfc_set_default_type (sym
, 0, implicit_ns
);
4068 gfc_current_locus
= old_loc
;
4071 expr
= gfc_get_expr ();
4073 expr
->expr_type
= EXPR_VARIABLE
;
4076 expr
->where
= where
;
4078 /* Now see if we have to do more. */
4079 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
4082 gfc_free_expr (expr
);
4092 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
4094 return match_variable (result
, equiv_flag
, 1);
4099 gfc_match_equiv_variable (gfc_expr
**result
)
4101 return match_variable (result
, 1, 0);