1 /* Primary expression subroutines
2 Copyright (C) 2000-2015 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];
49 m
= gfc_match_small_literal_int (kind
, NULL
);
53 m
= gfc_match_name (name
);
57 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
63 *is_iso_c
= sym
->attr
.is_iso_c
;
65 if (sym
->attr
.flavor
!= FL_PARAMETER
)
68 if (sym
->value
== NULL
)
71 p
= gfc_extract_int (sym
->value
, kind
);
75 gfc_set_sym_referenced (sym
);
84 /* Get a trailing kind-specification for non-character variables.
86 * the integer kind value or
87 * -1 if an error was generated,
88 * -2 if no kind was found.
89 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
90 symbol like e.g. 'c_int'. */
93 get_kind (int *is_iso_c
)
100 if (gfc_match_char ('_') != MATCH_YES
)
103 m
= match_kind_param (&kind
, is_iso_c
);
105 gfc_error ("Missing kind-parameter at %C");
107 return (m
== MATCH_YES
) ? kind
: -1;
111 /* Given a character and a radix, see if the character is a valid
112 digit in that radix. */
115 gfc_check_digit (char c
, int radix
)
122 r
= ('0' <= c
&& c
<= '1');
126 r
= ('0' <= c
&& c
<= '7');
130 r
= ('0' <= c
&& c
<= '9');
138 gfc_internal_error ("gfc_check_digit(): bad radix");
145 /* Match the digit string part of an integer if signflag is not set,
146 the signed digit string part if signflag is set. If the buffer
147 is NULL, we just count characters for the resolution pass. Returns
148 the number of characters matched, -1 for no match. */
151 match_digits (int signflag
, int radix
, char *buffer
)
158 c
= gfc_next_ascii_char ();
160 if (signflag
&& (c
== '+' || c
== '-'))
164 gfc_gobble_whitespace ();
165 c
= gfc_next_ascii_char ();
169 if (!gfc_check_digit (c
, radix
))
178 old_loc
= gfc_current_locus
;
179 c
= gfc_next_ascii_char ();
181 if (!gfc_check_digit (c
, radix
))
189 gfc_current_locus
= old_loc
;
195 /* Match an integer (digit string and optional kind).
196 A sign will be accepted if signflag is set. */
199 match_integer_constant (gfc_expr
**result
, int signflag
)
201 int length
, kind
, is_iso_c
;
206 old_loc
= gfc_current_locus
;
207 gfc_gobble_whitespace ();
209 length
= match_digits (signflag
, 10, NULL
);
210 gfc_current_locus
= old_loc
;
214 buffer
= (char *) alloca (length
+ 1);
215 memset (buffer
, '\0', length
+ 1);
217 gfc_gobble_whitespace ();
219 match_digits (signflag
, 10, buffer
);
221 kind
= get_kind (&is_iso_c
);
223 kind
= gfc_default_integer_kind
;
227 if (kind
== 4 && flag_integer4_kind
== 8)
230 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
232 gfc_error ("Integer kind %d at %C not available", kind
);
236 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
237 e
->ts
.is_c_interop
= is_iso_c
;
239 if (gfc_range_check (e
) != ARITH_OK
)
241 gfc_error ("Integer too big for its kind at %C. This check can be "
242 "disabled with the option -fno-range-check");
253 /* Match a Hollerith constant. */
256 match_hollerith_constant (gfc_expr
**result
)
264 old_loc
= gfc_current_locus
;
265 gfc_gobble_whitespace ();
267 if (match_integer_constant (&e
, 0) == MATCH_YES
268 && gfc_match_char ('h') == MATCH_YES
)
270 if (!gfc_notify_std (GFC_STD_LEGACY
, "Hollerith constant at %C"))
273 msg
= gfc_extract_int (e
, &num
);
281 gfc_error ("Invalid Hollerith constant: %L must contain at least "
282 "one character", &old_loc
);
285 if (e
->ts
.kind
!= gfc_default_integer_kind
)
287 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
288 "should be default", &old_loc
);
294 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
297 /* Calculate padding needed to fit default integer memory. */
298 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
300 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
302 for (i
= 0; i
< num
; i
++)
304 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
305 if (! gfc_wide_fits_in_byte (c
))
307 gfc_error ("Invalid Hollerith constant at %L contains a "
308 "wide character", &old_loc
);
312 e
->representation
.string
[i
] = (unsigned char) c
;
315 /* Now pad with blanks and end with a null char. */
316 for (i
= 0; i
< pad
; i
++)
317 e
->representation
.string
[num
+ i
] = ' ';
319 e
->representation
.string
[num
+ i
] = '\0';
320 e
->representation
.length
= num
+ pad
;
329 gfc_current_locus
= old_loc
;
338 /* Match a binary, octal or hexadecimal constant that can be found in
339 a DATA statement. The standard permits b'010...', o'73...', and
340 z'a1...' where b, o, and z can be capital letters. This function
341 also accepts postfixed forms of the constants: '01...'b, '73...'o,
342 and 'a1...'z. An additional extension is the use of x for z. */
345 match_boz_constant (gfc_expr
**result
)
347 int radix
, length
, x_hex
, kind
;
348 locus old_loc
, start_loc
;
349 char *buffer
, post
, delim
;
352 start_loc
= old_loc
= gfc_current_locus
;
353 gfc_gobble_whitespace ();
356 switch (post
= gfc_next_ascii_char ())
378 radix
= 16; /* Set to accept any valid digit string. */
384 /* No whitespace allowed here. */
387 delim
= gfc_next_ascii_char ();
389 if (delim
!= '\'' && delim
!= '\"')
393 && (!gfc_notify_std(GFC_STD_GNU
, "Hexadecimal "
394 "constant at %C uses non-standard syntax")))
397 old_loc
= gfc_current_locus
;
399 length
= match_digits (0, radix
, NULL
);
402 gfc_error ("Empty set of digits in BOZ constant at %C");
406 if (gfc_next_ascii_char () != delim
)
408 gfc_error ("Illegal character in BOZ constant at %C");
414 switch (gfc_next_ascii_char ())
431 if (!gfc_notify_std (GFC_STD_GNU
, "BOZ constant "
432 "at %C uses non-standard postfix syntax"))
436 gfc_current_locus
= old_loc
;
438 buffer
= (char *) alloca (length
+ 1);
439 memset (buffer
, '\0', length
+ 1);
441 match_digits (0, radix
, buffer
);
442 gfc_next_ascii_char (); /* Eat delimiter. */
444 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
446 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
447 "If a data-stmt-constant is a boz-literal-constant, the corresponding
448 variable shall be of type integer. The boz-literal-constant is treated
449 as if it were an int-literal-constant with a kind-param that specifies
450 the representation method with the largest decimal exponent range
451 supported by the processor." */
453 kind
= gfc_max_integer_kind
;
454 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
456 /* Mark as boz variable. */
459 if (gfc_range_check (e
) != ARITH_OK
)
461 gfc_error ("Integer too big for integer kind %i at %C", kind
);
466 if (!gfc_in_match_data ()
467 && (!gfc_notify_std(GFC_STD_F2003
, "BOZ used outside a DATA "
475 gfc_current_locus
= start_loc
;
480 /* Match a real constant of some sort. Allow a signed constant if signflag
484 match_real_constant (gfc_expr
**result
, int signflag
)
486 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
;
487 locus old_loc
, temp_loc
;
488 char *p
, *buffer
, c
, exp_char
;
492 old_loc
= gfc_current_locus
;
493 gfc_gobble_whitespace ();
503 c
= gfc_next_ascii_char ();
504 if (signflag
&& (c
== '+' || c
== '-'))
509 gfc_gobble_whitespace ();
510 c
= gfc_next_ascii_char ();
513 /* Scan significand. */
514 for (;; c
= gfc_next_ascii_char (), count
++)
521 /* Check to see if "." goes with a following operator like
523 temp_loc
= gfc_current_locus
;
524 c
= gfc_next_ascii_char ();
526 if (c
== 'e' || c
== 'd' || c
== 'q')
528 c
= gfc_next_ascii_char ();
530 goto done
; /* Operator named .e. or .d. */
534 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
536 gfc_current_locus
= temp_loc
;
550 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
557 if (!gfc_notify_std (GFC_STD_GNU
, "exponent-letter 'q' in "
558 "real-literal-constant at %C"))
560 else if (warn_real_q_constant
)
561 gfc_warning (OPT_Wreal_q_constant
,
562 "Extension: exponent-letter %<q%> in real-literal-constant "
567 c
= gfc_next_ascii_char ();
570 if (c
== '+' || c
== '-')
571 { /* optional sign */
572 c
= gfc_next_ascii_char ();
578 gfc_error ("Missing exponent in real number at %C");
584 c
= gfc_next_ascii_char ();
589 /* Check that we have a numeric constant. */
590 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
592 gfc_current_locus
= old_loc
;
596 /* Convert the number. */
597 gfc_current_locus
= old_loc
;
598 gfc_gobble_whitespace ();
600 buffer
= (char *) alloca (count
+ 1);
601 memset (buffer
, '\0', count
+ 1);
604 c
= gfc_next_ascii_char ();
605 if (c
== '+' || c
== '-')
607 gfc_gobble_whitespace ();
608 c
= gfc_next_ascii_char ();
611 /* Hack for mpfr_set_str(). */
614 if (c
== 'd' || c
== 'q')
622 c
= gfc_next_ascii_char ();
625 kind
= get_kind (&is_iso_c
);
634 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
638 kind
= gfc_default_double_kind
;
642 if (flag_real4_kind
== 8)
644 if (flag_real4_kind
== 10)
646 if (flag_real4_kind
== 16)
652 if (flag_real8_kind
== 4)
654 if (flag_real8_kind
== 10)
656 if (flag_real8_kind
== 16)
664 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
669 /* The maximum possible real kind type parameter is 16. First, try
670 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
671 extended precision. If neither value works, just given up. */
673 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
676 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
678 gfc_error ("Invalid exponent-letter %<q%> in "
679 "real-literal-constant at %C");
687 kind
= gfc_default_real_kind
;
691 if (flag_real4_kind
== 8)
693 if (flag_real4_kind
== 10)
695 if (flag_real4_kind
== 16)
701 if (flag_real8_kind
== 4)
703 if (flag_real8_kind
== 10)
705 if (flag_real8_kind
== 16)
709 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
711 gfc_error ("Invalid real kind %d at %C", kind
);
716 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
718 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
719 e
->ts
.is_c_interop
= is_iso_c
;
721 switch (gfc_range_check (e
))
726 gfc_error ("Real constant overflows its kind at %C");
729 case ARITH_UNDERFLOW
:
731 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
732 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
736 gfc_internal_error ("gfc_range_check() returned bad value");
748 /* Match a substring reference. */
751 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
753 gfc_expr
*start
, *end
;
761 old_loc
= gfc_current_locus
;
763 m
= gfc_match_char ('(');
767 if (gfc_match_char (':') != MATCH_YES
)
770 m
= gfc_match_init_expr (&start
);
772 m
= gfc_match_expr (&start
);
780 m
= gfc_match_char (':');
785 if (gfc_match_char (')') != MATCH_YES
)
788 m
= gfc_match_init_expr (&end
);
790 m
= gfc_match_expr (&end
);
794 if (m
== MATCH_ERROR
)
797 m
= gfc_match_char (')');
802 /* Optimize away the (:) reference. */
803 if (start
== NULL
&& end
== NULL
)
807 ref
= gfc_get_ref ();
809 ref
->type
= REF_SUBSTRING
;
811 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
812 ref
->u
.ss
.start
= start
;
813 if (end
== NULL
&& cl
)
814 end
= gfc_copy_expr (cl
->length
);
816 ref
->u
.ss
.length
= cl
;
823 gfc_error ("Syntax error in SUBSTRING specification at %C");
827 gfc_free_expr (start
);
830 gfc_current_locus
= old_loc
;
835 /* Reads the next character of a string constant, taking care to
836 return doubled delimiters on the input as a single instance of
839 Special return values for "ret" argument are:
840 -1 End of the string, as determined by the delimiter
841 -2 Unterminated string detected
843 Backslash codes are also expanded at this time. */
846 next_string_char (gfc_char_t delimiter
, int *ret
)
851 c
= gfc_next_char_literal (INSTRING_WARN
);
860 if (flag_backslash
&& c
== '\\')
862 old_locus
= gfc_current_locus
;
864 if (gfc_match_special_char (&c
) == MATCH_NO
)
865 gfc_current_locus
= old_locus
;
867 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
868 gfc_warning (0, "Extension: backslash character at %C");
874 old_locus
= gfc_current_locus
;
875 c
= gfc_next_char_literal (NONSTRING
);
879 gfc_current_locus
= old_locus
;
886 /* Special case of gfc_match_name() that matches a parameter kind name
887 before a string constant. This takes case of the weird but legal
892 where kind____ is a parameter. gfc_match_name() will happily slurp
893 up all the underscores, which leads to problems. If we return
894 MATCH_YES, the parse pointer points to the final underscore, which
895 is not part of the name. We never return MATCH_ERROR-- errors in
896 the name will be detected later. */
899 match_charkind_name (char *name
)
905 gfc_gobble_whitespace ();
906 c
= gfc_next_ascii_char ();
915 old_loc
= gfc_current_locus
;
916 c
= gfc_next_ascii_char ();
920 peek
= gfc_peek_ascii_char ();
922 if (peek
== '\'' || peek
== '\"')
924 gfc_current_locus
= old_loc
;
932 && (c
!= '$' || !flag_dollar_ok
))
936 if (++len
> GFC_MAX_SYMBOL_LEN
)
944 /* See if the current input matches a character constant. Lots of
945 contortions have to be done to match the kind parameter which comes
946 before the actual string. The main consideration is that we don't
947 want to error out too quickly. For example, we don't actually do
948 any validation of the kinds until we have actually seen a legal
949 delimiter. Using match_kind_param() generates errors too quickly. */
952 match_string_constant (gfc_expr
**result
)
954 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
955 int i
, kind
, length
, save_warn_ampersand
, ret
;
956 locus old_locus
, start_locus
;
961 gfc_char_t c
, delimiter
, *p
;
963 old_locus
= gfc_current_locus
;
965 gfc_gobble_whitespace ();
967 c
= gfc_next_char ();
968 if (c
== '\'' || c
== '"')
970 kind
= gfc_default_character_kind
;
971 start_locus
= gfc_current_locus
;
975 if (gfc_wide_is_digit (c
))
979 while (gfc_wide_is_digit (c
))
981 kind
= kind
* 10 + c
- '0';
984 c
= gfc_next_char ();
990 gfc_current_locus
= old_locus
;
992 m
= match_charkind_name (name
);
996 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
998 || sym
->attr
.flavor
!= FL_PARAMETER
)
1002 c
= gfc_next_char ();
1007 gfc_gobble_whitespace ();
1008 c
= gfc_next_char ();
1014 gfc_gobble_whitespace ();
1016 c
= gfc_next_char ();
1017 if (c
!= '\'' && c
!= '"')
1020 start_locus
= gfc_current_locus
;
1024 q
= gfc_extract_int (sym
->value
, &kind
);
1030 gfc_set_sym_referenced (sym
);
1033 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1035 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1040 /* Scan the string into a block of memory by first figuring out how
1041 long it is, allocating the structure, then re-reading it. This
1042 isn't particularly efficient, but string constants aren't that
1043 common in most code. TODO: Use obstacks? */
1050 c
= next_string_char (delimiter
, &ret
);
1055 gfc_current_locus
= start_locus
;
1056 gfc_error ("Unterminated character constant beginning at %C");
1063 /* Peek at the next character to see if it is a b, o, z, or x for the
1064 postfixed BOZ literal constants. */
1065 peek
= gfc_peek_ascii_char ();
1066 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1069 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1071 gfc_current_locus
= start_locus
;
1073 /* We disable the warning for the following loop as the warning has already
1074 been printed in the loop above. */
1075 save_warn_ampersand
= warn_ampersand
;
1076 warn_ampersand
= false;
1078 p
= e
->value
.character
.string
;
1079 for (i
= 0; i
< length
; i
++)
1081 c
= next_string_char (delimiter
, &ret
);
1083 if (!gfc_check_character_range (c
, kind
))
1086 gfc_error ("Character %qs in string at %C is not representable "
1087 "in character kind %d", gfc_print_wide_char (c
), kind
);
1094 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1095 warn_ampersand
= save_warn_ampersand
;
1097 next_string_char (delimiter
, &ret
);
1099 gfc_internal_error ("match_string_constant(): Delimiter not found");
1101 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1102 e
->expr_type
= EXPR_SUBSTRING
;
1109 gfc_current_locus
= old_locus
;
1114 /* Match a .true. or .false. Returns 1 if a .true. was found,
1115 0 if a .false. was found, and -1 otherwise. */
1117 match_logical_constant_string (void)
1119 locus orig_loc
= gfc_current_locus
;
1121 gfc_gobble_whitespace ();
1122 if (gfc_next_ascii_char () == '.')
1124 char ch
= gfc_next_ascii_char ();
1127 if (gfc_next_ascii_char () == 'a'
1128 && gfc_next_ascii_char () == 'l'
1129 && gfc_next_ascii_char () == 's'
1130 && gfc_next_ascii_char () == 'e'
1131 && gfc_next_ascii_char () == '.')
1132 /* Matched ".false.". */
1137 if (gfc_next_ascii_char () == 'r'
1138 && gfc_next_ascii_char () == 'u'
1139 && gfc_next_ascii_char () == 'e'
1140 && gfc_next_ascii_char () == '.')
1141 /* Matched ".true.". */
1145 gfc_current_locus
= orig_loc
;
1149 /* Match a .true. or .false. */
1152 match_logical_constant (gfc_expr
**result
)
1155 int i
, kind
, is_iso_c
;
1157 i
= match_logical_constant_string ();
1161 kind
= get_kind (&is_iso_c
);
1165 kind
= gfc_default_logical_kind
;
1167 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1169 gfc_error ("Bad kind for logical constant at %C");
1173 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1174 e
->ts
.is_c_interop
= is_iso_c
;
1181 /* Match a real or imaginary part of a complex constant that is a
1182 symbolic constant. */
1185 match_sym_complex_part (gfc_expr
**result
)
1187 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1192 m
= gfc_match_name (name
);
1196 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1199 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1201 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1205 if (!gfc_numeric_ts (&sym
->value
->ts
))
1207 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1211 if (sym
->value
->rank
!= 0)
1213 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1217 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1218 "complex constant at %C"))
1221 switch (sym
->value
->ts
.type
)
1224 e
= gfc_copy_expr (sym
->value
);
1228 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1234 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1240 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1243 *result
= e
; /* e is a scalar, real, constant expression. */
1247 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1252 /* Match a real or imaginary part of a complex number. */
1255 match_complex_part (gfc_expr
**result
)
1259 m
= match_sym_complex_part (result
);
1263 m
= match_real_constant (result
, 1);
1267 return match_integer_constant (result
, 1);
1271 /* Try to match a complex constant. */
1274 match_complex_constant (gfc_expr
**result
)
1276 gfc_expr
*e
, *real
, *imag
;
1277 gfc_error_buf old_error_1
;
1278 output_buffer old_error
;
1279 gfc_typespec target
;
1284 old_loc
= gfc_current_locus
;
1285 real
= imag
= e
= NULL
;
1287 m
= gfc_match_char ('(');
1291 gfc_push_error (&old_error
, &old_error_1
);
1293 m
= match_complex_part (&real
);
1296 gfc_free_error (&old_error
, &old_error_1
);
1300 if (gfc_match_char (',') == MATCH_NO
)
1302 gfc_pop_error (&old_error
, &old_error_1
);
1307 /* If m is error, then something was wrong with the real part and we
1308 assume we have a complex constant because we've seen the ','. An
1309 ambiguous case here is the start of an iterator list of some
1310 sort. These sort of lists are matched prior to coming here. */
1312 if (m
== MATCH_ERROR
)
1314 gfc_free_error (&old_error
, &old_error_1
);
1317 gfc_pop_error (&old_error
, &old_error_1
);
1319 m
= match_complex_part (&imag
);
1322 if (m
== MATCH_ERROR
)
1325 m
= gfc_match_char (')');
1328 /* Give the matcher for implied do-loops a chance to run. This
1329 yields a much saner error message for (/ (i, 4=i, 6) /). */
1330 if (gfc_peek_ascii_char () == '=')
1339 if (m
== MATCH_ERROR
)
1342 /* Decide on the kind of this complex number. */
1343 if (real
->ts
.type
== BT_REAL
)
1345 if (imag
->ts
.type
== BT_REAL
)
1346 kind
= gfc_kind_max (real
, imag
);
1348 kind
= real
->ts
.kind
;
1352 if (imag
->ts
.type
== BT_REAL
)
1353 kind
= imag
->ts
.kind
;
1355 kind
= gfc_default_real_kind
;
1357 gfc_clear_ts (&target
);
1358 target
.type
= BT_REAL
;
1361 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1362 gfc_convert_type (real
, &target
, 2);
1363 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1364 gfc_convert_type (imag
, &target
, 2);
1366 e
= gfc_convert_complex (real
, imag
, kind
);
1367 e
->where
= gfc_current_locus
;
1369 gfc_free_expr (real
);
1370 gfc_free_expr (imag
);
1376 gfc_error ("Syntax error in COMPLEX constant at %C");
1381 gfc_free_expr (real
);
1382 gfc_free_expr (imag
);
1383 gfc_current_locus
= old_loc
;
1389 /* Match constants in any of several forms. Returns nonzero for a
1390 match, zero for no match. */
1393 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1397 m
= match_complex_constant (result
);
1401 m
= match_string_constant (result
);
1405 m
= match_boz_constant (result
);
1409 m
= match_real_constant (result
, signflag
);
1413 m
= match_hollerith_constant (result
);
1417 m
= match_integer_constant (result
, signflag
);
1421 m
= match_logical_constant (result
);
1429 /* This checks if a symbol is the return value of an encompassing function.
1430 Function nesting can be maximally two levels deep, but we may have
1431 additional local namespaces like BLOCK etc. */
1434 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1436 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1440 if (ns
->proc_name
== sym
)
1448 /* Match a single actual argument value. An actual argument is
1449 usually an expression, but can also be a procedure name. If the
1450 argument is a single name, it is not always possible to tell
1451 whether the name is a dummy procedure or not. We treat these cases
1452 by creating an argument that looks like a dummy procedure and
1453 fixing things later during resolution. */
1456 match_actual_arg (gfc_expr
**result
)
1458 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1459 gfc_symtree
*symtree
;
1464 gfc_gobble_whitespace ();
1465 where
= gfc_current_locus
;
1467 switch (gfc_match_name (name
))
1476 w
= gfc_current_locus
;
1477 gfc_gobble_whitespace ();
1478 c
= gfc_next_ascii_char ();
1479 gfc_current_locus
= w
;
1481 if (c
!= ',' && c
!= ')')
1484 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1486 /* Handle error elsewhere. */
1488 /* Eliminate a couple of common cases where we know we don't
1489 have a function argument. */
1490 if (symtree
== NULL
)
1492 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1493 gfc_set_sym_referenced (symtree
->n
.sym
);
1499 sym
= symtree
->n
.sym
;
1500 gfc_set_sym_referenced (sym
);
1501 if (sym
->attr
.flavor
!= FL_PROCEDURE
1502 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1505 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1507 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1508 sym
->name
, &sym
->declared_at
))
1513 /* If the symbol is a function with itself as the result and
1514 is being defined, then we have a variable. */
1515 if (sym
->attr
.function
&& sym
->result
== sym
)
1517 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1521 && (sym
->ns
== gfc_current_ns
1522 || sym
->ns
== gfc_current_ns
->parent
))
1524 gfc_entry_list
*el
= NULL
;
1526 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1536 e
= gfc_get_expr (); /* Leave it unknown for now */
1537 e
->symtree
= symtree
;
1538 e
->expr_type
= EXPR_VARIABLE
;
1539 e
->ts
.type
= BT_PROCEDURE
;
1546 gfc_current_locus
= where
;
1547 return gfc_match_expr (result
);
1551 /* Match a keyword argument. */
1554 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1556 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1557 gfc_actual_arglist
*a
;
1561 name_locus
= gfc_current_locus
;
1562 m
= gfc_match_name (name
);
1566 if (gfc_match_char ('=') != MATCH_YES
)
1572 m
= match_actual_arg (&actual
->expr
);
1576 /* Make sure this name has not appeared yet. */
1578 if (name
[0] != '\0')
1580 for (a
= base
; a
; a
= a
->next
)
1581 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1583 gfc_error ("Keyword %qs at %C has already appeared in the "
1584 "current argument list", name
);
1589 actual
->name
= gfc_get_string (name
);
1593 gfc_current_locus
= name_locus
;
1598 /* Match an argument list function, such as %VAL. */
1601 match_arg_list_function (gfc_actual_arglist
*result
)
1603 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1607 old_locus
= gfc_current_locus
;
1609 if (gfc_match_char ('%') != MATCH_YES
)
1615 m
= gfc_match ("%n (", name
);
1619 if (name
[0] != '\0')
1624 if (strncmp (name
, "loc", 3) == 0)
1626 result
->name
= "%LOC";
1630 if (strncmp (name
, "ref", 3) == 0)
1632 result
->name
= "%REF";
1636 if (strncmp (name
, "val", 3) == 0)
1638 result
->name
= "%VAL";
1647 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1653 m
= match_actual_arg (&result
->expr
);
1657 if (gfc_match_char (')') != MATCH_YES
)
1666 gfc_current_locus
= old_locus
;
1671 /* Matches an actual argument list of a function or subroutine, from
1672 the opening parenthesis to the closing parenthesis. The argument
1673 list is assumed to allow keyword arguments because we don't know if
1674 the symbol associated with the procedure has an implicit interface
1675 or not. We make sure keywords are unique. If sub_flag is set,
1676 we're matching the argument list of a subroutine. */
1679 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1681 gfc_actual_arglist
*head
, *tail
;
1683 gfc_st_label
*label
;
1687 *argp
= tail
= NULL
;
1688 old_loc
= gfc_current_locus
;
1692 if (gfc_match_char ('(') == MATCH_NO
)
1693 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1695 if (gfc_match_char (')') == MATCH_YES
)
1699 matching_actual_arglist
++;
1704 head
= tail
= gfc_get_actual_arglist ();
1707 tail
->next
= gfc_get_actual_arglist ();
1711 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1713 m
= gfc_match_st_label (&label
);
1715 gfc_error ("Expected alternate return label at %C");
1719 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1723 tail
->label
= label
;
1727 /* After the first keyword argument is seen, the following
1728 arguments must also have keywords. */
1731 m
= match_keyword_arg (tail
, head
);
1733 if (m
== MATCH_ERROR
)
1737 gfc_error ("Missing keyword name in actual argument list at %C");
1744 /* Try an argument list function, like %VAL. */
1745 m
= match_arg_list_function (tail
);
1746 if (m
== MATCH_ERROR
)
1749 /* See if we have the first keyword argument. */
1752 m
= match_keyword_arg (tail
, head
);
1755 if (m
== MATCH_ERROR
)
1761 /* Try for a non-keyword argument. */
1762 m
= match_actual_arg (&tail
->expr
);
1763 if (m
== MATCH_ERROR
)
1772 if (gfc_match_char (')') == MATCH_YES
)
1774 if (gfc_match_char (',') != MATCH_YES
)
1779 matching_actual_arglist
--;
1783 gfc_error ("Syntax error in argument list at %C");
1786 gfc_free_actual_arglist (head
);
1787 gfc_current_locus
= old_loc
;
1788 matching_actual_arglist
--;
1793 /* Used by gfc_match_varspec() to extend the reference list by one
1797 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1799 if (primary
->ref
== NULL
)
1800 primary
->ref
= tail
= gfc_get_ref ();
1804 gfc_internal_error ("extend_ref(): Bad tail");
1805 tail
->next
= gfc_get_ref ();
1813 /* Match any additional specifications associated with the current
1814 variable like member references or substrings. If equiv_flag is
1815 set we only match stuff that is allowed inside an EQUIVALENCE
1816 statement. sub_flag tells whether we expect a type-bound procedure found
1817 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1818 components, 'ppc_arg' determines whether the PPC may be called (with an
1819 argument list), or whether it may just be referred to as a pointer. */
1822 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1825 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1826 gfc_ref
*substring
, *tail
;
1827 gfc_component
*component
;
1828 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1834 gfc_gobble_whitespace ();
1836 if (gfc_peek_ascii_char () == '[')
1838 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1839 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1840 && CLASS_DATA (sym
)->attr
.dimension
))
1842 gfc_error ("Array section designator, e.g. '(:)', is required "
1843 "besides the coarray designator '[...]' at %C");
1846 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1847 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1848 && !CLASS_DATA (sym
)->attr
.codimension
))
1850 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1856 /* For associate names, we may not yet know whether they are arrays or not.
1857 Thus if we have one and parentheses follow, we have to assume that it
1858 actually is one for now. The final decision will be made at
1859 resolution time, of course. */
1860 if (sym
->assoc
&& gfc_peek_ascii_char () == '('
1861 && !(sym
->assoc
->dangling
&& sym
->assoc
->st
1862 && sym
->assoc
->st
->n
.sym
1863 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
1864 sym
->attr
.dimension
= 1;
1866 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1867 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1868 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1869 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1870 && !(gfc_matching_procptr_assignment
1871 && sym
->attr
.flavor
== FL_PROCEDURE
))
1872 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1873 && (CLASS_DATA (sym
)->attr
.dimension
1874 || CLASS_DATA (sym
)->attr
.codimension
)))
1878 tail
= extend_ref (primary
, tail
);
1879 tail
->type
= REF_ARRAY
;
1881 /* In EQUIVALENCE, we don't know yet whether we are seeing
1882 an array, character variable or array of character
1883 variables. We'll leave the decision till resolve time. */
1887 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1888 as
= CLASS_DATA (sym
)->as
;
1892 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1893 as
? as
->corank
: 0);
1897 gfc_gobble_whitespace ();
1898 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1900 tail
= extend_ref (primary
, tail
);
1901 tail
->type
= REF_ARRAY
;
1903 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1909 primary
->ts
= sym
->ts
;
1914 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1915 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1916 gfc_set_default_type (sym
, 0, sym
->ns
);
1918 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_match_char ('%') == MATCH_YES
)
1920 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
1923 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1924 && gfc_match_char ('%') == MATCH_YES
)
1926 gfc_error ("Unexpected %<%%%> for nonderived-type variable %qs at %C",
1931 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1932 || gfc_match_char ('%') != MATCH_YES
)
1933 goto check_substring
;
1935 sym
= sym
->ts
.u
.derived
;
1942 m
= gfc_match_name (name
);
1944 gfc_error ("Expected structure component name at %C");
1948 if (sym
->f2k_derived
)
1949 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1955 gfc_symbol
* tbp_sym
;
1960 gcc_assert (!tail
|| !tail
->next
);
1962 if (!(primary
->expr_type
== EXPR_VARIABLE
1963 || (primary
->expr_type
== EXPR_STRUCTURE
1964 && primary
->symtree
&& primary
->symtree
->n
.sym
1965 && primary
->symtree
->n
.sym
->attr
.flavor
)))
1968 if (tbp
->n
.tb
->is_generic
)
1971 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1973 primary
->expr_type
= EXPR_COMPCALL
;
1974 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1975 primary
->value
.compcall
.name
= tbp
->name
;
1976 primary
->value
.compcall
.ignore_pass
= 0;
1977 primary
->value
.compcall
.assign
= 0;
1978 primary
->value
.compcall
.base_object
= NULL
;
1979 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1981 primary
->ts
= tbp_sym
->ts
;
1983 gfc_clear_ts (&primary
->ts
);
1985 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1986 &primary
->value
.compcall
.actual
);
1987 if (m
== MATCH_ERROR
)
1992 primary
->value
.compcall
.actual
= NULL
;
1995 gfc_error ("Expected argument list at %C");
2003 component
= gfc_find_component (sym
, name
, false, false);
2004 if (component
== NULL
)
2007 tail
= extend_ref (primary
, tail
);
2008 tail
->type
= REF_COMPONENT
;
2010 tail
->u
.c
.component
= component
;
2011 tail
->u
.c
.sym
= sym
;
2013 primary
->ts
= component
->ts
;
2015 if (component
->attr
.proc_pointer
&& ppc_arg
)
2017 /* Procedure pointer component call: Look for argument list. */
2018 m
= gfc_match_actual_arglist (sub_flag
,
2019 &primary
->value
.compcall
.actual
);
2020 if (m
== MATCH_ERROR
)
2023 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2024 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2026 gfc_error ("Procedure pointer component %qs requires an "
2027 "argument list at %C", component
->name
);
2032 primary
->expr_type
= EXPR_PPC
;
2037 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2039 tail
= extend_ref (primary
, tail
);
2040 tail
->type
= REF_ARRAY
;
2042 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2043 component
->as
->corank
);
2047 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2048 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2050 tail
= extend_ref (primary
, tail
);
2051 tail
->type
= REF_ARRAY
;
2053 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2055 CLASS_DATA (component
)->as
->corank
);
2060 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2061 || gfc_match_char ('%') != MATCH_YES
)
2064 sym
= component
->ts
.u
.derived
;
2069 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
2071 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2073 gfc_set_default_type (sym
, 0, sym
->ns
);
2074 primary
->ts
= sym
->ts
;
2079 if (primary
->ts
.type
== BT_CHARACTER
)
2081 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
2085 primary
->ref
= substring
;
2087 tail
->next
= substring
;
2089 if (primary
->expr_type
== EXPR_CONSTANT
)
2090 primary
->expr_type
= EXPR_SUBSTRING
;
2093 primary
->ts
.u
.cl
= NULL
;
2100 gfc_clear_ts (&primary
->ts
);
2101 gfc_clear_ts (&sym
->ts
);
2111 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2113 gfc_error ("Coindexed procedure-pointer component at %C");
2121 /* Given an expression that is a variable, figure out what the
2122 ultimate variable's type and attribute is, traversing the reference
2123 structures if necessary.
2125 This subroutine is trickier than it looks. We start at the base
2126 symbol and store the attribute. Component references load a
2127 completely new attribute.
2129 A couple of rules come into play. Subobjects of targets are always
2130 targets themselves. If we see a component that goes through a
2131 pointer, then the expression must also be a target, since the
2132 pointer is associated with something (if it isn't core will soon be
2133 dumped). If we see a full part or section of an array, the
2134 expression is also an array.
2136 We can have at most one full array reference. */
2139 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2141 int dimension
, codimension
, pointer
, allocatable
, target
, n
;
2142 symbol_attribute attr
;
2145 gfc_component
*comp
;
2147 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2148 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2150 sym
= expr
->symtree
->n
.sym
;
2153 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2155 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2156 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2157 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2158 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2162 dimension
= attr
.dimension
;
2163 codimension
= attr
.codimension
;
2164 pointer
= attr
.pointer
;
2165 allocatable
= attr
.allocatable
;
2168 target
= attr
.target
;
2169 if (pointer
|| attr
.proc_pointer
)
2172 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2175 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2180 switch (ref
->u
.ar
.type
)
2187 allocatable
= pointer
= 0;
2192 /* Handle coarrays. */
2193 if (ref
->u
.ar
.dimen
> 0)
2194 allocatable
= pointer
= 0;
2198 /* If any of start, end or stride is not integer, there will
2199 already have been an error issued. */
2200 for (n
= 0; n
< ref
->u
.ar
.as
->rank
; n
++)
2203 gfc_get_errors (NULL
, &errors
);
2204 if (((ref
->u
.ar
.start
[n
]
2205 && ref
->u
.ar
.start
[n
]->ts
.type
== BT_UNKNOWN
)
2208 && ref
->u
.ar
.end
[n
]->ts
.type
== BT_UNKNOWN
)
2210 (ref
->u
.ar
.stride
[n
]
2211 && ref
->u
.ar
.stride
[n
]->ts
.type
== BT_UNKNOWN
))
2215 if (n
== ref
->u
.ar
.as
->rank
)
2216 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2222 comp
= ref
->u
.c
.component
;
2227 /* Don't set the string length if a substring reference
2229 if (ts
->type
== BT_CHARACTER
2230 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2234 if (comp
->ts
.type
== BT_CLASS
)
2236 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2237 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2238 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2242 codimension
= comp
->attr
.codimension
;
2243 pointer
= comp
->attr
.pointer
;
2244 allocatable
= comp
->attr
.allocatable
;
2246 if (pointer
|| attr
.proc_pointer
)
2252 allocatable
= pointer
= 0;
2256 attr
.dimension
= dimension
;
2257 attr
.codimension
= codimension
;
2258 attr
.pointer
= pointer
;
2259 attr
.allocatable
= allocatable
;
2260 attr
.target
= target
;
2261 attr
.save
= sym
->attr
.save
;
2267 /* Return the attribute from a general expression. */
2270 gfc_expr_attr (gfc_expr
*e
)
2272 symbol_attribute attr
;
2274 switch (e
->expr_type
)
2277 attr
= gfc_variable_attr (e
, NULL
);
2281 gfc_clear_attr (&attr
);
2283 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2285 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2287 if (sym
->ts
.type
== BT_CLASS
)
2289 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2290 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2291 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2295 attr
= gfc_variable_attr (e
, NULL
);
2297 /* TODO: NULL() returns pointers. May have to take care of this
2303 gfc_clear_attr (&attr
);
2311 /* Match a structure constructor. The initial symbol has already been
2314 typedef struct gfc_structure_ctor_component
2319 struct gfc_structure_ctor_component
* next
;
2321 gfc_structure_ctor_component
;
2323 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2326 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2329 gfc_free_expr (comp
->val
);
2334 /* Translate the component list into the actual constructor by sorting it in
2335 the order required; this also checks along the way that each and every
2336 component actually has an initializer and handles default initializers
2337 for components without explicit value given. */
2339 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2340 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2342 gfc_structure_ctor_component
*comp_iter
;
2343 gfc_component
*comp
;
2345 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2347 gfc_structure_ctor_component
**next_ptr
;
2348 gfc_expr
*value
= NULL
;
2350 /* Try to find the initializer for the current component by name. */
2351 next_ptr
= comp_head
;
2352 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2354 if (!strcmp (comp_iter
->name
, comp
->name
))
2356 next_ptr
= &comp_iter
->next
;
2359 /* If an extension, try building the parent derived type by building
2360 a value expression for the parent derived type and calling self. */
2361 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2363 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2365 &gfc_current_locus
);
2366 value
->ts
= comp
->ts
;
2368 if (!build_actual_constructor (comp_head
,
2369 &value
->value
.constructor
,
2370 comp
->ts
.u
.derived
))
2372 gfc_free_expr (value
);
2376 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2380 /* If it was not found, try the default initializer if there's any;
2381 otherwise, it's an error unless this is a deferred parameter. */
2384 if (comp
->initializer
)
2386 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2387 "with missing optional arguments at %C"))
2389 value
= gfc_copy_expr (comp
->initializer
);
2391 else if (comp
->attr
.allocatable
2392 || (comp
->ts
.type
== BT_CLASS
2393 && CLASS_DATA (comp
)->attr
.allocatable
))
2395 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2396 "allocatable component '%qs' given in the "
2397 "structure constructor at %C", comp
->name
))
2400 else if (!comp
->attr
.artificial
)
2402 gfc_error ("No initializer for component %qs given in the"
2403 " structure constructor at %C!", comp
->name
);
2408 value
= comp_iter
->val
;
2410 /* Add the value to the constructor chain built. */
2411 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2413 /* Remove the entry from the component list. We don't want the expression
2414 value to be free'd, so set it to NULL. */
2417 *next_ptr
= comp_iter
->next
;
2418 comp_iter
->val
= NULL
;
2419 gfc_free_structure_ctor_component (comp_iter
);
2427 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2428 gfc_actual_arglist
**arglist
,
2431 gfc_actual_arglist
*actual
;
2432 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2433 gfc_constructor_base ctor_head
= NULL
;
2434 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2435 const char* last_name
= NULL
;
2439 expr
= parent
? *cexpr
: e
;
2440 old_locus
= gfc_current_locus
;
2442 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2444 gfc_current_locus
= expr
->where
;
2446 comp_tail
= comp_head
= NULL
;
2448 if (!parent
&& sym
->attr
.abstract
)
2450 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2451 sym
->name
, &expr
->where
);
2455 comp
= sym
->components
;
2456 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2459 gfc_component
*this_comp
= NULL
;
2462 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2465 comp_tail
->next
= gfc_get_structure_ctor_component ();
2466 comp_tail
= comp_tail
->next
;
2470 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2471 " constructor with named arguments at %C"))
2474 comp_tail
->name
= xstrdup (actual
->name
);
2475 last_name
= comp_tail
->name
;
2480 /* Components without name are not allowed after the first named
2481 component initializer! */
2482 if (!comp
|| comp
->attr
.artificial
)
2485 gfc_error ("Component initializer without name after component"
2486 " named %s at %L!", last_name
,
2487 actual
->expr
? &actual
->expr
->where
2488 : &gfc_current_locus
);
2490 gfc_error ("Too many components in structure constructor at "
2491 "%L!", actual
->expr
? &actual
->expr
->where
2492 : &gfc_current_locus
);
2496 comp_tail
->name
= xstrdup (comp
->name
);
2499 /* Find the current component in the structure definition and check
2500 its access is not private. */
2502 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2505 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2507 comp
= NULL
; /* Reset needed! */
2510 /* Here we can check if a component name is given which does not
2511 correspond to any component of the defined structure. */
2515 comp_tail
->val
= actual
->expr
;
2516 if (actual
->expr
!= NULL
)
2517 comp_tail
->where
= actual
->expr
->where
;
2518 actual
->expr
= NULL
;
2520 /* Check if this component is already given a value. */
2521 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2522 comp_iter
= comp_iter
->next
)
2524 gcc_assert (comp_iter
);
2525 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2527 gfc_error ("Component %qs is initialized twice in the structure"
2528 " constructor at %L!", comp_tail
->name
,
2529 comp_tail
->val
? &comp_tail
->where
2530 : &gfc_current_locus
);
2535 /* F2008, R457/C725, for PURE C1283. */
2536 if (this_comp
->attr
.pointer
&& comp_tail
->val
2537 && gfc_is_coindexed (comp_tail
->val
))
2539 gfc_error ("Coindexed expression to pointer component %qs in "
2540 "structure constructor at %L!", comp_tail
->name
,
2545 /* If not explicitly a parent constructor, gather up the components
2547 if (comp
&& comp
== sym
->components
2548 && sym
->attr
.extension
2550 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2552 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2555 gfc_actual_arglist
*arg_null
= NULL
;
2557 actual
->expr
= comp_tail
->val
;
2558 comp_tail
->val
= NULL
;
2560 m
= gfc_convert_to_structure_constructor (NULL
,
2561 comp
->ts
.u
.derived
, &comp_tail
->val
,
2562 comp
->ts
.u
.derived
->attr
.zero_comp
2563 ? &arg_null
: &actual
, true);
2567 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2576 if (parent
&& !comp
)
2580 actual
= actual
->next
;
2583 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2586 /* No component should be left, as this should have caused an error in the
2587 loop constructing the component-list (name that does not correspond to any
2588 component in the structure definition). */
2589 if (comp_head
&& sym
->attr
.extension
)
2591 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2593 gfc_error ("component %qs at %L has already been set by a "
2594 "parent derived type constructor", comp_iter
->name
,
2600 gcc_assert (!comp_head
);
2604 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2605 expr
->ts
.u
.derived
= sym
;
2606 expr
->value
.constructor
= ctor_head
;
2611 expr
->ts
.u
.derived
= sym
;
2613 expr
->ts
.type
= BT_DERIVED
;
2614 expr
->value
.constructor
= ctor_head
;
2615 expr
->expr_type
= EXPR_STRUCTURE
;
2618 gfc_current_locus
= old_locus
;
2624 gfc_current_locus
= old_locus
;
2626 for (comp_iter
= comp_head
; comp_iter
; )
2628 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2629 gfc_free_structure_ctor_component (comp_iter
);
2632 gfc_constructor_free (ctor_head
);
2639 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2643 gfc_symtree
*symtree
;
2645 gfc_get_sym_tree (sym
->name
, NULL
, &symtree
, false); /* Can't fail */
2647 e
= gfc_get_expr ();
2648 e
->symtree
= symtree
;
2649 e
->expr_type
= EXPR_FUNCTION
;
2651 gcc_assert (sym
->attr
.flavor
== FL_DERIVED
2652 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2653 e
->value
.function
.esym
= sym
;
2654 e
->symtree
->n
.sym
->attr
.generic
= 1;
2656 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2663 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
2674 /* If the symbol is an implicit do loop index and implicitly typed,
2675 it should not be host associated. Provide a symtree from the
2676 current namespace. */
2678 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2680 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2681 && (*sym
)->ns
!= gfc_current_ns
2682 && (*sym
)->attr
.implied_index
2683 && (*sym
)->attr
.implicit_type
2684 && !(*sym
)->attr
.use_assoc
)
2687 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2690 *sym
= (*st
)->n
.sym
;
2696 /* Procedure pointer as function result: Replace the function symbol by the
2697 auto-generated hidden result variable named "ppr@". */
2700 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2702 /* Check for procedure pointer result variable. */
2703 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2704 && (*sym
)->result
&& (*sym
)->result
!= *sym
2705 && (*sym
)->result
->attr
.proc_pointer
2706 && (*sym
) == gfc_current_ns
->proc_name
2707 && (*sym
) == (*sym
)->result
->ns
->proc_name
2708 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2710 /* Automatic replacement with "hidden" result variable. */
2711 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2712 *sym
= (*sym
)->result
;
2713 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2720 /* Matches a variable name followed by anything that might follow it--
2721 array reference, argument list of a function, etc. */
2724 gfc_match_rvalue (gfc_expr
**result
)
2726 gfc_actual_arglist
*actual_arglist
;
2727 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2730 gfc_symtree
*symtree
;
2731 locus where
, old_loc
;
2739 m
= gfc_match_name (name
);
2743 if (gfc_find_state (COMP_INTERFACE
)
2744 && !gfc_current_ns
->has_import_set
)
2745 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2747 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2752 sym
= symtree
->n
.sym
;
2754 where
= gfc_current_locus
;
2756 replace_hidden_procptr_result (&sym
, &symtree
);
2758 /* If this is an implicit do loop index and implicitly typed,
2759 it should not be host associated. */
2760 m
= check_for_implicit_index (&symtree
, &sym
);
2764 gfc_set_sym_referenced (sym
);
2765 sym
->attr
.implied_index
= 0;
2767 if (sym
->attr
.function
&& sym
->result
== sym
)
2769 /* See if this is a directly recursive function call. */
2770 gfc_gobble_whitespace ();
2771 if (sym
->attr
.recursive
2772 && gfc_peek_ascii_char () == '('
2773 && gfc_current_ns
->proc_name
== sym
2774 && !sym
->attr
.dimension
)
2776 gfc_error ("%qs at %C is the name of a recursive function "
2777 "and so refers to the result variable. Use an "
2778 "explicit RESULT variable for direct recursion "
2779 "(12.5.2.1)", sym
->name
);
2783 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2787 && (sym
->ns
== gfc_current_ns
2788 || sym
->ns
== gfc_current_ns
->parent
))
2790 gfc_entry_list
*el
= NULL
;
2792 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2798 if (gfc_matching_procptr_assignment
)
2801 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2804 if (sym
->attr
.generic
)
2805 goto generic_function
;
2807 switch (sym
->attr
.flavor
)
2811 e
= gfc_get_expr ();
2813 e
->expr_type
= EXPR_VARIABLE
;
2814 e
->symtree
= symtree
;
2816 m
= gfc_match_varspec (e
, 0, false, true);
2820 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2821 end up here. Unfortunately, sym->value->expr_type is set to
2822 EXPR_CONSTANT, and so the if () branch would be followed without
2823 the !sym->as check. */
2824 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2825 e
= gfc_copy_expr (sym
->value
);
2828 e
= gfc_get_expr ();
2829 e
->expr_type
= EXPR_VARIABLE
;
2832 e
->symtree
= symtree
;
2833 m
= gfc_match_varspec (e
, 0, false, true);
2835 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2838 /* Variable array references to derived type parameters cause
2839 all sorts of headaches in simplification. Treating such
2840 expressions as variable works just fine for all array
2842 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2844 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2845 if (ref
->type
== REF_ARRAY
)
2848 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2854 e
= gfc_get_expr ();
2855 e
->expr_type
= EXPR_VARIABLE
;
2856 e
->symtree
= symtree
;
2863 sym
= gfc_use_derived (sym
);
2867 goto generic_function
;
2870 /* If we're here, then the name is known to be the name of a
2871 procedure, yet it is not sure to be the name of a function. */
2874 /* Procedure Pointer Assignments. */
2876 if (gfc_matching_procptr_assignment
)
2878 gfc_gobble_whitespace ();
2879 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2880 /* Parse functions returning a procptr. */
2883 e
= gfc_get_expr ();
2884 e
->expr_type
= EXPR_VARIABLE
;
2885 e
->symtree
= symtree
;
2886 m
= gfc_match_varspec (e
, 0, false, true);
2887 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
2888 && sym
->ts
.type
== BT_UNKNOWN
2889 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
2897 if (sym
->attr
.subroutine
)
2899 gfc_error ("Unexpected use of subroutine name %qs at %C",
2905 /* At this point, the name has to be a non-statement function.
2906 If the name is the same as the current function being
2907 compiled, then we have a variable reference (to the function
2908 result) if the name is non-recursive. */
2910 st
= gfc_enclosing_unit (NULL
);
2912 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2914 && !sym
->attr
.recursive
)
2916 e
= gfc_get_expr ();
2917 e
->symtree
= symtree
;
2918 e
->expr_type
= EXPR_VARIABLE
;
2920 m
= gfc_match_varspec (e
, 0, false, true);
2924 /* Match a function reference. */
2926 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2929 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2930 gfc_error ("Statement function %qs requires argument list at %C",
2933 gfc_error ("Function %qs requires an argument list at %C",
2946 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2947 sym
= symtree
->n
.sym
;
2949 replace_hidden_procptr_result (&sym
, &symtree
);
2951 e
= gfc_get_expr ();
2952 e
->symtree
= symtree
;
2953 e
->expr_type
= EXPR_FUNCTION
;
2954 e
->value
.function
.actual
= actual_arglist
;
2955 e
->where
= gfc_current_locus
;
2957 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2958 && CLASS_DATA (sym
)->as
)
2959 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
2960 else if (sym
->as
!= NULL
)
2961 e
->rank
= sym
->as
->rank
;
2963 if (!sym
->attr
.function
2964 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2970 /* Check here for the existence of at least one argument for the
2971 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2972 argument(s) given will be checked in gfc_iso_c_func_interface,
2973 during resolution of the function call. */
2974 if (sym
->attr
.is_iso_c
== 1
2975 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2976 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2977 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2978 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2980 /* make sure we were given a param */
2981 if (actual_arglist
== NULL
)
2983 gfc_error ("Missing argument to %qs at %C", sym
->name
);
2989 if (sym
->result
== NULL
)
2997 /* Special case for derived type variables that get their types
2998 via an IMPLICIT statement. This can't wait for the
2999 resolution phase. */
3001 if (gfc_peek_ascii_char () == '%'
3002 && sym
->ts
.type
== BT_UNKNOWN
3003 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3004 gfc_set_default_type (sym
, 0, sym
->ns
);
3006 /* If the symbol has a (co)dimension attribute, the expression is a
3009 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3011 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3017 e
= gfc_get_expr ();
3018 e
->symtree
= symtree
;
3019 e
->expr_type
= EXPR_VARIABLE
;
3020 m
= gfc_match_varspec (e
, 0, false, true);
3024 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3025 && (CLASS_DATA (sym
)->attr
.dimension
3026 || CLASS_DATA (sym
)->attr
.codimension
))
3028 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3034 e
= gfc_get_expr ();
3035 e
->symtree
= symtree
;
3036 e
->expr_type
= EXPR_VARIABLE
;
3037 m
= gfc_match_varspec (e
, 0, false, true);
3041 /* Name is not an array, so we peek to see if a '(' implies a
3042 function call or a substring reference. Otherwise the
3043 variable is just a scalar. */
3045 gfc_gobble_whitespace ();
3046 if (gfc_peek_ascii_char () != '(')
3048 /* Assume a scalar variable */
3049 e
= gfc_get_expr ();
3050 e
->symtree
= symtree
;
3051 e
->expr_type
= EXPR_VARIABLE
;
3053 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3059 /*FIXME:??? gfc_match_varspec does set this for us: */
3061 m
= gfc_match_varspec (e
, 0, false, true);
3065 /* See if this is a function reference with a keyword argument
3066 as first argument. We do this because otherwise a spurious
3067 symbol would end up in the symbol table. */
3069 old_loc
= gfc_current_locus
;
3070 m2
= gfc_match (" ( %n =", argname
);
3071 gfc_current_locus
= old_loc
;
3073 e
= gfc_get_expr ();
3074 e
->symtree
= symtree
;
3076 if (m2
!= MATCH_YES
)
3078 /* Try to figure out whether we're dealing with a character type.
3079 We're peeking ahead here, because we don't want to call
3080 match_substring if we're dealing with an implicitly typed
3081 non-character variable. */
3082 implicit_char
= false;
3083 if (sym
->ts
.type
== BT_UNKNOWN
)
3085 ts
= gfc_get_default_type (sym
->name
, NULL
);
3086 if (ts
->type
== BT_CHARACTER
)
3087 implicit_char
= true;
3090 /* See if this could possibly be a substring reference of a name
3091 that we're not sure is a variable yet. */
3093 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3094 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
3097 e
->expr_type
= EXPR_VARIABLE
;
3099 if (sym
->attr
.flavor
!= FL_VARIABLE
3100 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3107 if (sym
->ts
.type
== BT_UNKNOWN
3108 && !gfc_set_default_type (sym
, 1, NULL
))
3122 /* Give up, assume we have a function. */
3124 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3125 sym
= symtree
->n
.sym
;
3126 e
->expr_type
= EXPR_FUNCTION
;
3128 if (!sym
->attr
.function
3129 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3137 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3139 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3147 /* If our new function returns a character, array or structure
3148 type, it might have subsequent references. */
3150 m
= gfc_match_varspec (e
, 0, false, true);
3157 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3159 e
= gfc_get_expr ();
3160 e
->symtree
= symtree
;
3161 e
->expr_type
= EXPR_FUNCTION
;
3163 if (sym
->attr
.flavor
== FL_DERIVED
)
3165 e
->value
.function
.esym
= sym
;
3166 e
->symtree
->n
.sym
->attr
.generic
= 1;
3169 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3173 gfc_error ("Symbol at %C is not appropriate for an expression");
3189 /* Match a variable, i.e. something that can be assigned to. This
3190 starts as a symbol, can be a structure component or an array
3191 reference. It can be a function if the function doesn't have a
3192 separate RESULT variable. If the symbol has not been previously
3193 seen, we assume it is a variable.
3195 This function is called by two interface functions:
3196 gfc_match_variable, which has host_flag = 1, and
3197 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3198 match of the symbol to the local scope. */
3201 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3209 /* Since nothing has any business being an lvalue in a module
3210 specification block, an interface block or a contains section,
3211 we force the changed_symbols mechanism to work by setting
3212 host_flag to 0. This prevents valid symbols that have the name
3213 of keywords, such as 'end', being turned into variables by
3214 failed matching to assignments for, e.g., END INTERFACE. */
3215 if (gfc_current_state () == COMP_MODULE
3216 || gfc_current_state () == COMP_INTERFACE
3217 || gfc_current_state () == COMP_CONTAINS
)
3220 where
= gfc_current_locus
;
3221 m
= gfc_match_sym_tree (&st
, host_flag
);
3227 /* If this is an implicit do loop index and implicitly typed,
3228 it should not be host associated. */
3229 m
= check_for_implicit_index (&st
, &sym
);
3233 sym
->attr
.implied_index
= 0;
3235 gfc_set_sym_referenced (sym
);
3236 switch (sym
->attr
.flavor
)
3239 /* Everything is alright. */
3244 sym_flavor flavor
= FL_UNKNOWN
;
3246 gfc_gobble_whitespace ();
3248 if (sym
->attr
.external
|| sym
->attr
.procedure
3249 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3250 flavor
= FL_PROCEDURE
;
3252 /* If it is not a procedure, is not typed and is host associated,
3253 we cannot give it a flavor yet. */
3254 else if (sym
->ns
== gfc_current_ns
->parent
3255 && sym
->ts
.type
== BT_UNKNOWN
)
3258 /* These are definitive indicators that this is a variable. */
3259 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3260 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3261 flavor
= FL_VARIABLE
;
3263 if (flavor
!= FL_UNKNOWN
3264 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3272 gfc_error ("Named constant at %C in an EQUIVALENCE");
3275 /* Otherwise this is checked for and an error given in the
3276 variable definition context checks. */
3280 /* Check for a nonrecursive function result variable. */
3281 if (sym
->attr
.function
3282 && !sym
->attr
.external
3283 && sym
->result
== sym
3284 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3286 && sym
->ns
== gfc_current_ns
)
3288 && sym
->ns
== gfc_current_ns
->parent
)))
3290 /* If a function result is a derived type, then the derived
3291 type may still have to be resolved. */
3293 if (sym
->ts
.type
== BT_DERIVED
3294 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3299 if (sym
->attr
.proc_pointer
3300 || replace_hidden_procptr_result (&sym
, &st
))
3303 /* Fall through to error */
3306 gfc_error ("%qs at %C is not a variable", sym
->name
);
3310 /* Special case for derived type variables that get their types
3311 via an IMPLICIT statement. This can't wait for the
3312 resolution phase. */
3315 gfc_namespace
* implicit_ns
;
3317 if (gfc_current_ns
->proc_name
== sym
)
3318 implicit_ns
= gfc_current_ns
;
3320 implicit_ns
= sym
->ns
;
3322 if (gfc_peek_ascii_char () == '%'
3323 && sym
->ts
.type
== BT_UNKNOWN
3324 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3325 gfc_set_default_type (sym
, 0, implicit_ns
);
3328 expr
= gfc_get_expr ();
3330 expr
->expr_type
= EXPR_VARIABLE
;
3333 expr
->where
= where
;
3335 /* Now see if we have to do more. */
3336 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3339 gfc_free_expr (expr
);
3349 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3351 return match_variable (result
, equiv_flag
, 1);
3356 gfc_match_equiv_variable (gfc_expr
**result
)
3358 return match_variable (result
, 1, 0);