1 /* Primary expression subroutines
2 Copyright (C) 2000-2013 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 && gfc_option
.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 (gfc_option
.warn_real_q_constant
)
561 gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
566 c
= gfc_next_ascii_char ();
569 if (c
== '+' || c
== '-')
570 { /* optional sign */
571 c
= gfc_next_ascii_char ();
577 gfc_error ("Missing exponent in real number at %C");
583 c
= gfc_next_ascii_char ();
588 /* Check that we have a numeric constant. */
589 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
591 gfc_current_locus
= old_loc
;
595 /* Convert the number. */
596 gfc_current_locus
= old_loc
;
597 gfc_gobble_whitespace ();
599 buffer
= (char *) alloca (count
+ 1);
600 memset (buffer
, '\0', count
+ 1);
603 c
= gfc_next_ascii_char ();
604 if (c
== '+' || c
== '-')
606 gfc_gobble_whitespace ();
607 c
= gfc_next_ascii_char ();
610 /* Hack for mpfr_set_str(). */
613 if (c
== 'd' || c
== 'q')
621 c
= gfc_next_ascii_char ();
624 kind
= get_kind (&is_iso_c
);
633 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
637 kind
= gfc_default_double_kind
;
641 if (gfc_option
.flag_real4_kind
== 8)
643 if (gfc_option
.flag_real4_kind
== 10)
645 if (gfc_option
.flag_real4_kind
== 16)
651 if (gfc_option
.flag_real8_kind
== 4)
653 if (gfc_option
.flag_real8_kind
== 10)
655 if (gfc_option
.flag_real8_kind
== 16)
663 gfc_error ("Real number at %C has a 'q' exponent and an explicit "
668 /* The maximum possible real kind type parameter is 16. First, try
669 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
670 extended precision. If neither value works, just given up. */
672 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
675 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
677 gfc_error ("Invalid exponent-letter 'q' in "
678 "real-literal-constant at %C");
686 kind
= gfc_default_real_kind
;
690 if (gfc_option
.flag_real4_kind
== 8)
692 if (gfc_option
.flag_real4_kind
== 10)
694 if (gfc_option
.flag_real4_kind
== 16)
700 if (gfc_option
.flag_real8_kind
== 4)
702 if (gfc_option
.flag_real8_kind
== 10)
704 if (gfc_option
.flag_real8_kind
== 16)
708 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
710 gfc_error ("Invalid real kind %d at %C", kind
);
715 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
717 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
718 e
->ts
.is_c_interop
= is_iso_c
;
720 switch (gfc_range_check (e
))
725 gfc_error ("Real constant overflows its kind at %C");
728 case ARITH_UNDERFLOW
:
729 if (gfc_option
.warn_underflow
)
730 gfc_warning ("Real constant underflows its kind at %C");
731 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
735 gfc_internal_error ("gfc_range_check() returned bad value");
747 /* Match a substring reference. */
750 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
752 gfc_expr
*start
, *end
;
760 old_loc
= gfc_current_locus
;
762 m
= gfc_match_char ('(');
766 if (gfc_match_char (':') != MATCH_YES
)
769 m
= gfc_match_init_expr (&start
);
771 m
= gfc_match_expr (&start
);
779 m
= gfc_match_char (':');
784 if (gfc_match_char (')') != MATCH_YES
)
787 m
= gfc_match_init_expr (&end
);
789 m
= gfc_match_expr (&end
);
793 if (m
== MATCH_ERROR
)
796 m
= gfc_match_char (')');
801 /* Optimize away the (:) reference. */
802 if (start
== NULL
&& end
== NULL
)
806 ref
= gfc_get_ref ();
808 ref
->type
= REF_SUBSTRING
;
810 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
811 ref
->u
.ss
.start
= start
;
812 if (end
== NULL
&& cl
)
813 end
= gfc_copy_expr (cl
->length
);
815 ref
->u
.ss
.length
= cl
;
822 gfc_error ("Syntax error in SUBSTRING specification at %C");
826 gfc_free_expr (start
);
829 gfc_current_locus
= old_loc
;
834 /* Reads the next character of a string constant, taking care to
835 return doubled delimiters on the input as a single instance of
838 Special return values for "ret" argument are:
839 -1 End of the string, as determined by the delimiter
840 -2 Unterminated string detected
842 Backslash codes are also expanded at this time. */
845 next_string_char (gfc_char_t delimiter
, int *ret
)
850 c
= gfc_next_char_literal (INSTRING_WARN
);
859 if (gfc_option
.flag_backslash
&& c
== '\\')
861 old_locus
= gfc_current_locus
;
863 if (gfc_match_special_char (&c
) == MATCH_NO
)
864 gfc_current_locus
= old_locus
;
866 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
867 gfc_warning ("Extension: backslash character at %C");
873 old_locus
= gfc_current_locus
;
874 c
= gfc_next_char_literal (NONSTRING
);
878 gfc_current_locus
= old_locus
;
885 /* Special case of gfc_match_name() that matches a parameter kind name
886 before a string constant. This takes case of the weird but legal
891 where kind____ is a parameter. gfc_match_name() will happily slurp
892 up all the underscores, which leads to problems. If we return
893 MATCH_YES, the parse pointer points to the final underscore, which
894 is not part of the name. We never return MATCH_ERROR-- errors in
895 the name will be detected later. */
898 match_charkind_name (char *name
)
904 gfc_gobble_whitespace ();
905 c
= gfc_next_ascii_char ();
914 old_loc
= gfc_current_locus
;
915 c
= gfc_next_ascii_char ();
919 peek
= gfc_peek_ascii_char ();
921 if (peek
== '\'' || peek
== '\"')
923 gfc_current_locus
= old_loc
;
931 && (c
!= '$' || !gfc_option
.flag_dollar_ok
))
935 if (++len
> GFC_MAX_SYMBOL_LEN
)
943 /* See if the current input matches a character constant. Lots of
944 contortions have to be done to match the kind parameter which comes
945 before the actual string. The main consideration is that we don't
946 want to error out too quickly. For example, we don't actually do
947 any validation of the kinds until we have actually seen a legal
948 delimiter. Using match_kind_param() generates errors too quickly. */
951 match_string_constant (gfc_expr
**result
)
953 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
954 int i
, kind
, length
, warn_ampersand
, ret
;
955 locus old_locus
, start_locus
;
960 gfc_char_t c
, delimiter
, *p
;
962 old_locus
= gfc_current_locus
;
964 gfc_gobble_whitespace ();
966 c
= gfc_next_char ();
967 if (c
== '\'' || c
== '"')
969 kind
= gfc_default_character_kind
;
970 start_locus
= gfc_current_locus
;
974 if (gfc_wide_is_digit (c
))
978 while (gfc_wide_is_digit (c
))
980 kind
= kind
* 10 + c
- '0';
983 c
= gfc_next_char ();
989 gfc_current_locus
= old_locus
;
991 m
= match_charkind_name (name
);
995 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
997 || sym
->attr
.flavor
!= FL_PARAMETER
)
1001 c
= gfc_next_char ();
1006 gfc_gobble_whitespace ();
1007 c
= gfc_next_char ();
1013 gfc_gobble_whitespace ();
1015 c
= gfc_next_char ();
1016 if (c
!= '\'' && c
!= '"')
1019 start_locus
= gfc_current_locus
;
1023 q
= gfc_extract_int (sym
->value
, &kind
);
1029 gfc_set_sym_referenced (sym
);
1032 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1034 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1039 /* Scan the string into a block of memory by first figuring out how
1040 long it is, allocating the structure, then re-reading it. This
1041 isn't particularly efficient, but string constants aren't that
1042 common in most code. TODO: Use obstacks? */
1049 c
= next_string_char (delimiter
, &ret
);
1054 gfc_current_locus
= start_locus
;
1055 gfc_error ("Unterminated character constant beginning at %C");
1062 /* Peek at the next character to see if it is a b, o, z, or x for the
1063 postfixed BOZ literal constants. */
1064 peek
= gfc_peek_ascii_char ();
1065 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1068 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1070 gfc_current_locus
= start_locus
;
1072 /* We disable the warning for the following loop as the warning has already
1073 been printed in the loop above. */
1074 warn_ampersand
= gfc_option
.warn_ampersand
;
1075 gfc_option
.warn_ampersand
= 0;
1077 p
= e
->value
.character
.string
;
1078 for (i
= 0; i
< length
; i
++)
1080 c
= next_string_char (delimiter
, &ret
);
1082 if (!gfc_check_character_range (c
, kind
))
1085 gfc_error ("Character '%s' in string at %C is not representable "
1086 "in character kind %d", gfc_print_wide_char (c
), kind
);
1093 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1094 gfc_option
.warn_ampersand
= warn_ampersand
;
1096 next_string_char (delimiter
, &ret
);
1098 gfc_internal_error ("match_string_constant(): Delimiter not found");
1100 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1101 e
->expr_type
= EXPR_SUBSTRING
;
1108 gfc_current_locus
= old_locus
;
1113 /* Match a .true. or .false. Returns 1 if a .true. was found,
1114 0 if a .false. was found, and -1 otherwise. */
1116 match_logical_constant_string (void)
1118 locus orig_loc
= gfc_current_locus
;
1120 gfc_gobble_whitespace ();
1121 if (gfc_next_ascii_char () == '.')
1123 char ch
= gfc_next_ascii_char ();
1126 if (gfc_next_ascii_char () == 'a'
1127 && gfc_next_ascii_char () == 'l'
1128 && gfc_next_ascii_char () == 's'
1129 && gfc_next_ascii_char () == 'e'
1130 && gfc_next_ascii_char () == '.')
1131 /* Matched ".false.". */
1136 if (gfc_next_ascii_char () == 'r'
1137 && gfc_next_ascii_char () == 'u'
1138 && gfc_next_ascii_char () == 'e'
1139 && gfc_next_ascii_char () == '.')
1140 /* Matched ".true.". */
1144 gfc_current_locus
= orig_loc
;
1148 /* Match a .true. or .false. */
1151 match_logical_constant (gfc_expr
**result
)
1154 int i
, kind
, is_iso_c
;
1156 i
= match_logical_constant_string ();
1160 kind
= get_kind (&is_iso_c
);
1164 kind
= gfc_default_logical_kind
;
1166 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1168 gfc_error ("Bad kind for logical constant at %C");
1172 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1173 e
->ts
.is_c_interop
= is_iso_c
;
1180 /* Match a real or imaginary part of a complex constant that is a
1181 symbolic constant. */
1184 match_sym_complex_part (gfc_expr
**result
)
1186 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1191 m
= gfc_match_name (name
);
1195 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1198 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1200 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1204 if (!gfc_numeric_ts (&sym
->value
->ts
))
1206 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1210 if (sym
->value
->rank
!= 0)
1212 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1216 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1217 "complex constant at %C"))
1220 switch (sym
->value
->ts
.type
)
1223 e
= gfc_copy_expr (sym
->value
);
1227 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1233 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1239 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1242 *result
= e
; /* e is a scalar, real, constant expression. */
1246 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1251 /* Match a real or imaginary part of a complex number. */
1254 match_complex_part (gfc_expr
**result
)
1258 m
= match_sym_complex_part (result
);
1262 m
= match_real_constant (result
, 1);
1266 return match_integer_constant (result
, 1);
1270 /* Try to match a complex constant. */
1273 match_complex_constant (gfc_expr
**result
)
1275 gfc_expr
*e
, *real
, *imag
;
1276 gfc_error_buf old_error
;
1277 gfc_typespec target
;
1282 old_loc
= gfc_current_locus
;
1283 real
= imag
= e
= NULL
;
1285 m
= gfc_match_char ('(');
1289 gfc_push_error (&old_error
);
1291 m
= match_complex_part (&real
);
1294 gfc_free_error (&old_error
);
1298 if (gfc_match_char (',') == MATCH_NO
)
1300 gfc_pop_error (&old_error
);
1305 /* If m is error, then something was wrong with the real part and we
1306 assume we have a complex constant because we've seen the ','. An
1307 ambiguous case here is the start of an iterator list of some
1308 sort. These sort of lists are matched prior to coming here. */
1310 if (m
== MATCH_ERROR
)
1312 gfc_free_error (&old_error
);
1315 gfc_pop_error (&old_error
);
1317 m
= match_complex_part (&imag
);
1320 if (m
== MATCH_ERROR
)
1323 m
= gfc_match_char (')');
1326 /* Give the matcher for implied do-loops a chance to run. This
1327 yields a much saner error message for (/ (i, 4=i, 6) /). */
1328 if (gfc_peek_ascii_char () == '=')
1337 if (m
== MATCH_ERROR
)
1340 /* Decide on the kind of this complex number. */
1341 if (real
->ts
.type
== BT_REAL
)
1343 if (imag
->ts
.type
== BT_REAL
)
1344 kind
= gfc_kind_max (real
, imag
);
1346 kind
= real
->ts
.kind
;
1350 if (imag
->ts
.type
== BT_REAL
)
1351 kind
= imag
->ts
.kind
;
1353 kind
= gfc_default_real_kind
;
1355 gfc_clear_ts (&target
);
1356 target
.type
= BT_REAL
;
1359 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1360 gfc_convert_type (real
, &target
, 2);
1361 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1362 gfc_convert_type (imag
, &target
, 2);
1364 e
= gfc_convert_complex (real
, imag
, kind
);
1365 e
->where
= gfc_current_locus
;
1367 gfc_free_expr (real
);
1368 gfc_free_expr (imag
);
1374 gfc_error ("Syntax error in COMPLEX constant at %C");
1379 gfc_free_expr (real
);
1380 gfc_free_expr (imag
);
1381 gfc_current_locus
= old_loc
;
1387 /* Match constants in any of several forms. Returns nonzero for a
1388 match, zero for no match. */
1391 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1395 m
= match_complex_constant (result
);
1399 m
= match_string_constant (result
);
1403 m
= match_boz_constant (result
);
1407 m
= match_real_constant (result
, signflag
);
1411 m
= match_hollerith_constant (result
);
1415 m
= match_integer_constant (result
, signflag
);
1419 m
= match_logical_constant (result
);
1427 /* This checks if a symbol is the return value of an encompassing function.
1428 Function nesting can be maximally two levels deep, but we may have
1429 additional local namespaces like BLOCK etc. */
1432 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1434 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1438 if (ns
->proc_name
== sym
)
1446 /* Match a single actual argument value. An actual argument is
1447 usually an expression, but can also be a procedure name. If the
1448 argument is a single name, it is not always possible to tell
1449 whether the name is a dummy procedure or not. We treat these cases
1450 by creating an argument that looks like a dummy procedure and
1451 fixing things later during resolution. */
1454 match_actual_arg (gfc_expr
**result
)
1456 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1457 gfc_symtree
*symtree
;
1462 gfc_gobble_whitespace ();
1463 where
= gfc_current_locus
;
1465 switch (gfc_match_name (name
))
1474 w
= gfc_current_locus
;
1475 gfc_gobble_whitespace ();
1476 c
= gfc_next_ascii_char ();
1477 gfc_current_locus
= w
;
1479 if (c
!= ',' && c
!= ')')
1482 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1484 /* Handle error elsewhere. */
1486 /* Eliminate a couple of common cases where we know we don't
1487 have a function argument. */
1488 if (symtree
== NULL
)
1490 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1491 gfc_set_sym_referenced (symtree
->n
.sym
);
1497 sym
= symtree
->n
.sym
;
1498 gfc_set_sym_referenced (sym
);
1499 if (sym
->attr
.flavor
!= FL_PROCEDURE
1500 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1503 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1505 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1506 sym
->name
, &sym
->declared_at
))
1511 /* If the symbol is a function with itself as the result and
1512 is being defined, then we have a variable. */
1513 if (sym
->attr
.function
&& sym
->result
== sym
)
1515 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1519 && (sym
->ns
== gfc_current_ns
1520 || sym
->ns
== gfc_current_ns
->parent
))
1522 gfc_entry_list
*el
= NULL
;
1524 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1534 e
= gfc_get_expr (); /* Leave it unknown for now */
1535 e
->symtree
= symtree
;
1536 e
->expr_type
= EXPR_VARIABLE
;
1537 e
->ts
.type
= BT_PROCEDURE
;
1544 gfc_current_locus
= where
;
1545 return gfc_match_expr (result
);
1549 /* Match a keyword argument. */
1552 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1554 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1555 gfc_actual_arglist
*a
;
1559 name_locus
= gfc_current_locus
;
1560 m
= gfc_match_name (name
);
1564 if (gfc_match_char ('=') != MATCH_YES
)
1570 m
= match_actual_arg (&actual
->expr
);
1574 /* Make sure this name has not appeared yet. */
1576 if (name
[0] != '\0')
1578 for (a
= base
; a
; a
= a
->next
)
1579 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1581 gfc_error ("Keyword '%s' at %C has already appeared in the "
1582 "current argument list", name
);
1587 actual
->name
= gfc_get_string (name
);
1591 gfc_current_locus
= name_locus
;
1596 /* Match an argument list function, such as %VAL. */
1599 match_arg_list_function (gfc_actual_arglist
*result
)
1601 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1605 old_locus
= gfc_current_locus
;
1607 if (gfc_match_char ('%') != MATCH_YES
)
1613 m
= gfc_match ("%n (", name
);
1617 if (name
[0] != '\0')
1622 if (strncmp (name
, "loc", 3) == 0)
1624 result
->name
= "%LOC";
1628 if (strncmp (name
, "ref", 3) == 0)
1630 result
->name
= "%REF";
1634 if (strncmp (name
, "val", 3) == 0)
1636 result
->name
= "%VAL";
1645 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1651 m
= match_actual_arg (&result
->expr
);
1655 if (gfc_match_char (')') != MATCH_YES
)
1664 gfc_current_locus
= old_locus
;
1669 /* Matches an actual argument list of a function or subroutine, from
1670 the opening parenthesis to the closing parenthesis. The argument
1671 list is assumed to allow keyword arguments because we don't know if
1672 the symbol associated with the procedure has an implicit interface
1673 or not. We make sure keywords are unique. If sub_flag is set,
1674 we're matching the argument list of a subroutine. */
1677 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1679 gfc_actual_arglist
*head
, *tail
;
1681 gfc_st_label
*label
;
1685 *argp
= tail
= NULL
;
1686 old_loc
= gfc_current_locus
;
1690 if (gfc_match_char ('(') == MATCH_NO
)
1691 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1693 if (gfc_match_char (')') == MATCH_YES
)
1697 matching_actual_arglist
++;
1702 head
= tail
= gfc_get_actual_arglist ();
1705 tail
->next
= gfc_get_actual_arglist ();
1709 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1711 m
= gfc_match_st_label (&label
);
1713 gfc_error ("Expected alternate return label at %C");
1717 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1721 tail
->label
= label
;
1725 /* After the first keyword argument is seen, the following
1726 arguments must also have keywords. */
1729 m
= match_keyword_arg (tail
, head
);
1731 if (m
== MATCH_ERROR
)
1735 gfc_error ("Missing keyword name in actual argument list at %C");
1742 /* Try an argument list function, like %VAL. */
1743 m
= match_arg_list_function (tail
);
1744 if (m
== MATCH_ERROR
)
1747 /* See if we have the first keyword argument. */
1750 m
= match_keyword_arg (tail
, head
);
1753 if (m
== MATCH_ERROR
)
1759 /* Try for a non-keyword argument. */
1760 m
= match_actual_arg (&tail
->expr
);
1761 if (m
== MATCH_ERROR
)
1770 if (gfc_match_char (')') == MATCH_YES
)
1772 if (gfc_match_char (',') != MATCH_YES
)
1777 matching_actual_arglist
--;
1781 gfc_error ("Syntax error in argument list at %C");
1784 gfc_free_actual_arglist (head
);
1785 gfc_current_locus
= old_loc
;
1786 matching_actual_arglist
--;
1791 /* Used by gfc_match_varspec() to extend the reference list by one
1795 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1797 if (primary
->ref
== NULL
)
1798 primary
->ref
= tail
= gfc_get_ref ();
1802 gfc_internal_error ("extend_ref(): Bad tail");
1803 tail
->next
= gfc_get_ref ();
1811 /* Match any additional specifications associated with the current
1812 variable like member references or substrings. If equiv_flag is
1813 set we only match stuff that is allowed inside an EQUIVALENCE
1814 statement. sub_flag tells whether we expect a type-bound procedure found
1815 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1816 components, 'ppc_arg' determines whether the PPC may be called (with an
1817 argument list), or whether it may just be referred to as a pointer. */
1820 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1823 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1824 gfc_ref
*substring
, *tail
;
1825 gfc_component
*component
;
1826 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1832 gfc_gobble_whitespace ();
1834 if (gfc_peek_ascii_char () == '[')
1836 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1837 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1838 && CLASS_DATA (sym
)->attr
.dimension
))
1840 gfc_error ("Array section designator, e.g. '(:)', is required "
1841 "besides the coarray designator '[...]' at %C");
1844 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1845 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1846 && !CLASS_DATA (sym
)->attr
.codimension
))
1848 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1854 /* For associate names, we may not yet know whether they are arrays or not.
1855 Thus if we have one and parentheses follow, we have to assume that it
1856 actually is one for now. The final decision will be made at
1857 resolution time, of course. */
1858 if (sym
->assoc
&& gfc_peek_ascii_char () == '(')
1859 sym
->attr
.dimension
= 1;
1861 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1862 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1863 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1864 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1865 && !(gfc_matching_procptr_assignment
1866 && sym
->attr
.flavor
== FL_PROCEDURE
))
1867 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1868 && (CLASS_DATA (sym
)->attr
.dimension
1869 || CLASS_DATA (sym
)->attr
.codimension
)))
1873 tail
= extend_ref (primary
, tail
);
1874 tail
->type
= REF_ARRAY
;
1876 /* In EQUIVALENCE, we don't know yet whether we are seeing
1877 an array, character variable or array of character
1878 variables. We'll leave the decision till resolve time. */
1882 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1883 as
= CLASS_DATA (sym
)->as
;
1887 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1888 as
? as
->corank
: 0);
1892 gfc_gobble_whitespace ();
1893 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1895 tail
= extend_ref (primary
, tail
);
1896 tail
->type
= REF_ARRAY
;
1898 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1904 primary
->ts
= sym
->ts
;
1909 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1910 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1911 gfc_set_default_type (sym
, 0, sym
->ns
);
1913 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_match_char ('%') == MATCH_YES
)
1915 gfc_error ("Symbol '%s' at %C has no IMPLICIT type", sym
->name
);
1918 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1919 && gfc_match_char ('%') == MATCH_YES
)
1921 gfc_error ("Unexpected '%%' for nonderived-type variable '%s' at %C",
1926 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1927 || gfc_match_char ('%') != MATCH_YES
)
1928 goto check_substring
;
1930 sym
= sym
->ts
.u
.derived
;
1937 m
= gfc_match_name (name
);
1939 gfc_error ("Expected structure component name at %C");
1943 if (sym
->f2k_derived
)
1944 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1950 gfc_symbol
* tbp_sym
;
1955 gcc_assert (!tail
|| !tail
->next
);
1957 if (!(primary
->expr_type
== EXPR_VARIABLE
1958 || (primary
->expr_type
== EXPR_STRUCTURE
1959 && primary
->symtree
&& primary
->symtree
->n
.sym
1960 && primary
->symtree
->n
.sym
->attr
.flavor
)))
1963 if (tbp
->n
.tb
->is_generic
)
1966 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1968 primary
->expr_type
= EXPR_COMPCALL
;
1969 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1970 primary
->value
.compcall
.name
= tbp
->name
;
1971 primary
->value
.compcall
.ignore_pass
= 0;
1972 primary
->value
.compcall
.assign
= 0;
1973 primary
->value
.compcall
.base_object
= NULL
;
1974 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1976 primary
->ts
= tbp_sym
->ts
;
1978 gfc_clear_ts (&primary
->ts
);
1980 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1981 &primary
->value
.compcall
.actual
);
1982 if (m
== MATCH_ERROR
)
1987 primary
->value
.compcall
.actual
= NULL
;
1990 gfc_error ("Expected argument list at %C");
1998 component
= gfc_find_component (sym
, name
, false, false);
1999 if (component
== NULL
)
2002 tail
= extend_ref (primary
, tail
);
2003 tail
->type
= REF_COMPONENT
;
2005 tail
->u
.c
.component
= component
;
2006 tail
->u
.c
.sym
= sym
;
2008 primary
->ts
= component
->ts
;
2010 if (component
->attr
.proc_pointer
&& ppc_arg
)
2012 /* Procedure pointer component call: Look for argument list. */
2013 m
= gfc_match_actual_arglist (sub_flag
,
2014 &primary
->value
.compcall
.actual
);
2015 if (m
== MATCH_ERROR
)
2018 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2019 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2021 gfc_error ("Procedure pointer component '%s' requires an "
2022 "argument list at %C", component
->name
);
2027 primary
->expr_type
= EXPR_PPC
;
2032 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2034 tail
= extend_ref (primary
, tail
);
2035 tail
->type
= REF_ARRAY
;
2037 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2038 component
->as
->corank
);
2042 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2043 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2045 tail
= extend_ref (primary
, tail
);
2046 tail
->type
= REF_ARRAY
;
2048 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2050 CLASS_DATA (component
)->as
->corank
);
2055 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2056 || gfc_match_char ('%') != MATCH_YES
)
2059 sym
= component
->ts
.u
.derived
;
2064 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
2066 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2068 gfc_set_default_type (sym
, 0, sym
->ns
);
2069 primary
->ts
= sym
->ts
;
2074 if (primary
->ts
.type
== BT_CHARACTER
)
2076 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
2080 primary
->ref
= substring
;
2082 tail
->next
= substring
;
2084 if (primary
->expr_type
== EXPR_CONSTANT
)
2085 primary
->expr_type
= EXPR_SUBSTRING
;
2088 primary
->ts
.u
.cl
= NULL
;
2095 gfc_clear_ts (&primary
->ts
);
2096 gfc_clear_ts (&sym
->ts
);
2106 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2108 gfc_error ("Coindexed procedure-pointer component at %C");
2116 /* Given an expression that is a variable, figure out what the
2117 ultimate variable's type and attribute is, traversing the reference
2118 structures if necessary.
2120 This subroutine is trickier than it looks. We start at the base
2121 symbol and store the attribute. Component references load a
2122 completely new attribute.
2124 A couple of rules come into play. Subobjects of targets are always
2125 targets themselves. If we see a component that goes through a
2126 pointer, then the expression must also be a target, since the
2127 pointer is associated with something (if it isn't core will soon be
2128 dumped). If we see a full part or section of an array, the
2129 expression is also an array.
2131 We can have at most one full array reference. */
2134 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2136 int dimension
, codimension
, pointer
, allocatable
, target
;
2137 symbol_attribute attr
;
2140 gfc_component
*comp
;
2142 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2143 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2145 sym
= expr
->symtree
->n
.sym
;
2148 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2150 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2151 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2152 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2153 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2157 dimension
= attr
.dimension
;
2158 codimension
= attr
.codimension
;
2159 pointer
= attr
.pointer
;
2160 allocatable
= attr
.allocatable
;
2163 target
= attr
.target
;
2164 if (pointer
|| attr
.proc_pointer
)
2167 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2170 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2175 switch (ref
->u
.ar
.type
)
2182 allocatable
= pointer
= 0;
2187 /* Handle coarrays. */
2188 if (ref
->u
.ar
.dimen
> 0)
2189 allocatable
= pointer
= 0;
2193 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2199 comp
= ref
->u
.c
.component
;
2204 /* Don't set the string length if a substring reference
2206 if (ts
->type
== BT_CHARACTER
2207 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2211 if (comp
->ts
.type
== BT_CLASS
)
2213 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2214 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2215 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2219 codimension
= comp
->attr
.codimension
;
2220 pointer
= comp
->attr
.pointer
;
2221 allocatable
= comp
->attr
.allocatable
;
2223 if (pointer
|| attr
.proc_pointer
)
2229 allocatable
= pointer
= 0;
2233 attr
.dimension
= dimension
;
2234 attr
.codimension
= codimension
;
2235 attr
.pointer
= pointer
;
2236 attr
.allocatable
= allocatable
;
2237 attr
.target
= target
;
2238 attr
.save
= sym
->attr
.save
;
2244 /* Return the attribute from a general expression. */
2247 gfc_expr_attr (gfc_expr
*e
)
2249 symbol_attribute attr
;
2251 switch (e
->expr_type
)
2254 attr
= gfc_variable_attr (e
, NULL
);
2258 gfc_clear_attr (&attr
);
2260 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2262 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2264 if (sym
->ts
.type
== BT_CLASS
)
2266 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2267 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2268 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2272 attr
= gfc_variable_attr (e
, NULL
);
2274 /* TODO: NULL() returns pointers. May have to take care of this
2280 gfc_clear_attr (&attr
);
2288 /* Match a structure constructor. The initial symbol has already been
2291 typedef struct gfc_structure_ctor_component
2296 struct gfc_structure_ctor_component
* next
;
2298 gfc_structure_ctor_component
;
2300 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2303 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2306 gfc_free_expr (comp
->val
);
2311 /* Translate the component list into the actual constructor by sorting it in
2312 the order required; this also checks along the way that each and every
2313 component actually has an initializer and handles default initializers
2314 for components without explicit value given. */
2316 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2317 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2319 gfc_structure_ctor_component
*comp_iter
;
2320 gfc_component
*comp
;
2322 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2324 gfc_structure_ctor_component
**next_ptr
;
2325 gfc_expr
*value
= NULL
;
2327 /* Try to find the initializer for the current component by name. */
2328 next_ptr
= comp_head
;
2329 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2331 if (!strcmp (comp_iter
->name
, comp
->name
))
2333 next_ptr
= &comp_iter
->next
;
2336 /* If an extension, try building the parent derived type by building
2337 a value expression for the parent derived type and calling self. */
2338 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2340 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2342 &gfc_current_locus
);
2343 value
->ts
= comp
->ts
;
2345 if (!build_actual_constructor (comp_head
,
2346 &value
->value
.constructor
,
2347 comp
->ts
.u
.derived
))
2349 gfc_free_expr (value
);
2353 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2357 /* If it was not found, try the default initializer if there's any;
2358 otherwise, it's an error. */
2361 if (comp
->initializer
)
2363 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2364 "with missing optional arguments at %C"))
2366 value
= gfc_copy_expr (comp
->initializer
);
2370 gfc_error ("No initializer for component '%s' given in the"
2371 " structure constructor at %C!", comp
->name
);
2376 value
= comp_iter
->val
;
2378 /* Add the value to the constructor chain built. */
2379 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2381 /* Remove the entry from the component list. We don't want the expression
2382 value to be free'd, so set it to NULL. */
2385 *next_ptr
= comp_iter
->next
;
2386 comp_iter
->val
= NULL
;
2387 gfc_free_structure_ctor_component (comp_iter
);
2395 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2396 gfc_actual_arglist
**arglist
,
2399 gfc_actual_arglist
*actual
;
2400 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2401 gfc_constructor_base ctor_head
= NULL
;
2402 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2403 const char* last_name
= NULL
;
2407 expr
= parent
? *cexpr
: e
;
2408 old_locus
= gfc_current_locus
;
2410 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2412 gfc_current_locus
= expr
->where
;
2414 comp_tail
= comp_head
= NULL
;
2416 if (!parent
&& sym
->attr
.abstract
)
2418 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2419 sym
->name
, &expr
->where
);
2423 comp
= sym
->components
;
2424 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2427 gfc_component
*this_comp
= NULL
;
2430 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2433 comp_tail
->next
= gfc_get_structure_ctor_component ();
2434 comp_tail
= comp_tail
->next
;
2438 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2439 " constructor with named arguments at %C"))
2442 comp_tail
->name
= xstrdup (actual
->name
);
2443 last_name
= comp_tail
->name
;
2448 /* Components without name are not allowed after the first named
2449 component initializer! */
2453 gfc_error ("Component initializer without name after component"
2454 " named %s at %L!", last_name
,
2455 actual
->expr
? &actual
->expr
->where
2456 : &gfc_current_locus
);
2458 gfc_error ("Too many components in structure constructor at "
2459 "%L!", actual
->expr
? &actual
->expr
->where
2460 : &gfc_current_locus
);
2464 comp_tail
->name
= xstrdup (comp
->name
);
2467 /* Find the current component in the structure definition and check
2468 its access is not private. */
2470 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2473 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2475 comp
= NULL
; /* Reset needed! */
2478 /* Here we can check if a component name is given which does not
2479 correspond to any component of the defined structure. */
2483 comp_tail
->val
= actual
->expr
;
2484 if (actual
->expr
!= NULL
)
2485 comp_tail
->where
= actual
->expr
->where
;
2486 actual
->expr
= NULL
;
2488 /* Check if this component is already given a value. */
2489 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2490 comp_iter
= comp_iter
->next
)
2492 gcc_assert (comp_iter
);
2493 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2495 gfc_error ("Component '%s' is initialized twice in the structure"
2496 " constructor at %L!", comp_tail
->name
,
2497 comp_tail
->val
? &comp_tail
->where
2498 : &gfc_current_locus
);
2503 /* F2008, R457/C725, for PURE C1283. */
2504 if (this_comp
->attr
.pointer
&& comp_tail
->val
2505 && gfc_is_coindexed (comp_tail
->val
))
2507 gfc_error ("Coindexed expression to pointer component '%s' in "
2508 "structure constructor at %L!", comp_tail
->name
,
2513 /* If not explicitly a parent constructor, gather up the components
2515 if (comp
&& comp
== sym
->components
2516 && sym
->attr
.extension
2518 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2520 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2523 gfc_actual_arglist
*arg_null
= NULL
;
2525 actual
->expr
= comp_tail
->val
;
2526 comp_tail
->val
= NULL
;
2528 m
= gfc_convert_to_structure_constructor (NULL
,
2529 comp
->ts
.u
.derived
, &comp_tail
->val
,
2530 comp
->ts
.u
.derived
->attr
.zero_comp
2531 ? &arg_null
: &actual
, true);
2535 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2544 if (parent
&& !comp
)
2547 actual
= actual
->next
;
2550 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2553 /* No component should be left, as this should have caused an error in the
2554 loop constructing the component-list (name that does not correspond to any
2555 component in the structure definition). */
2556 if (comp_head
&& sym
->attr
.extension
)
2558 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2560 gfc_error ("component '%s' at %L has already been set by a "
2561 "parent derived type constructor", comp_iter
->name
,
2567 gcc_assert (!comp_head
);
2571 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2572 expr
->ts
.u
.derived
= sym
;
2573 expr
->value
.constructor
= ctor_head
;
2578 expr
->ts
.u
.derived
= sym
;
2580 expr
->ts
.type
= BT_DERIVED
;
2581 expr
->value
.constructor
= ctor_head
;
2582 expr
->expr_type
= EXPR_STRUCTURE
;
2585 gfc_current_locus
= old_locus
;
2591 gfc_current_locus
= old_locus
;
2593 for (comp_iter
= comp_head
; comp_iter
; )
2595 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2596 gfc_free_structure_ctor_component (comp_iter
);
2599 gfc_constructor_free (ctor_head
);
2606 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2610 gfc_symtree
*symtree
;
2612 gfc_get_sym_tree (sym
->name
, NULL
, &symtree
, false); /* Can't fail */
2614 e
= gfc_get_expr ();
2615 e
->symtree
= symtree
;
2616 e
->expr_type
= EXPR_FUNCTION
;
2618 gcc_assert (sym
->attr
.flavor
== FL_DERIVED
2619 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2620 e
->value
.function
.esym
= sym
;
2621 e
->symtree
->n
.sym
->attr
.generic
= 1;
2623 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2630 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
2641 /* If the symbol is an implicit do loop index and implicitly typed,
2642 it should not be host associated. Provide a symtree from the
2643 current namespace. */
2645 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2647 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2648 && (*sym
)->ns
!= gfc_current_ns
2649 && (*sym
)->attr
.implied_index
2650 && (*sym
)->attr
.implicit_type
2651 && !(*sym
)->attr
.use_assoc
)
2654 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2657 *sym
= (*st
)->n
.sym
;
2663 /* Procedure pointer as function result: Replace the function symbol by the
2664 auto-generated hidden result variable named "ppr@". */
2667 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2669 /* Check for procedure pointer result variable. */
2670 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2671 && (*sym
)->result
&& (*sym
)->result
!= *sym
2672 && (*sym
)->result
->attr
.proc_pointer
2673 && (*sym
) == gfc_current_ns
->proc_name
2674 && (*sym
) == (*sym
)->result
->ns
->proc_name
2675 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2677 /* Automatic replacement with "hidden" result variable. */
2678 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2679 *sym
= (*sym
)->result
;
2680 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2687 /* Matches a variable name followed by anything that might follow it--
2688 array reference, argument list of a function, etc. */
2691 gfc_match_rvalue (gfc_expr
**result
)
2693 gfc_actual_arglist
*actual_arglist
;
2694 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2697 gfc_symtree
*symtree
;
2698 locus where
, old_loc
;
2706 m
= gfc_match_name (name
);
2710 if (gfc_find_state (COMP_INTERFACE
)
2711 && !gfc_current_ns
->has_import_set
)
2712 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2714 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2719 sym
= symtree
->n
.sym
;
2721 where
= gfc_current_locus
;
2723 replace_hidden_procptr_result (&sym
, &symtree
);
2725 /* If this is an implicit do loop index and implicitly typed,
2726 it should not be host associated. */
2727 m
= check_for_implicit_index (&symtree
, &sym
);
2731 gfc_set_sym_referenced (sym
);
2732 sym
->attr
.implied_index
= 0;
2734 if (sym
->attr
.function
&& sym
->result
== sym
)
2736 /* See if this is a directly recursive function call. */
2737 gfc_gobble_whitespace ();
2738 if (sym
->attr
.recursive
2739 && gfc_peek_ascii_char () == '('
2740 && gfc_current_ns
->proc_name
== sym
2741 && !sym
->attr
.dimension
)
2743 gfc_error ("'%s' at %C is the name of a recursive function "
2744 "and so refers to the result variable. Use an "
2745 "explicit RESULT variable for direct recursion "
2746 "(12.5.2.1)", sym
->name
);
2750 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2754 && (sym
->ns
== gfc_current_ns
2755 || sym
->ns
== gfc_current_ns
->parent
))
2757 gfc_entry_list
*el
= NULL
;
2759 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2765 if (gfc_matching_procptr_assignment
)
2768 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2771 if (sym
->attr
.generic
)
2772 goto generic_function
;
2774 switch (sym
->attr
.flavor
)
2778 e
= gfc_get_expr ();
2780 e
->expr_type
= EXPR_VARIABLE
;
2781 e
->symtree
= symtree
;
2783 m
= gfc_match_varspec (e
, 0, false, true);
2787 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2788 end up here. Unfortunately, sym->value->expr_type is set to
2789 EXPR_CONSTANT, and so the if () branch would be followed without
2790 the !sym->as check. */
2791 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2792 e
= gfc_copy_expr (sym
->value
);
2795 e
= gfc_get_expr ();
2796 e
->expr_type
= EXPR_VARIABLE
;
2799 e
->symtree
= symtree
;
2800 m
= gfc_match_varspec (e
, 0, false, true);
2802 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2805 /* Variable array references to derived type parameters cause
2806 all sorts of headaches in simplification. Treating such
2807 expressions as variable works just fine for all array
2809 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2811 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2812 if (ref
->type
== REF_ARRAY
)
2815 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2821 e
= gfc_get_expr ();
2822 e
->expr_type
= EXPR_VARIABLE
;
2823 e
->symtree
= symtree
;
2830 sym
= gfc_use_derived (sym
);
2834 goto generic_function
;
2837 /* If we're here, then the name is known to be the name of a
2838 procedure, yet it is not sure to be the name of a function. */
2841 /* Procedure Pointer Assignments. */
2843 if (gfc_matching_procptr_assignment
)
2845 gfc_gobble_whitespace ();
2846 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2847 /* Parse functions returning a procptr. */
2850 e
= gfc_get_expr ();
2851 e
->expr_type
= EXPR_VARIABLE
;
2852 e
->symtree
= symtree
;
2853 m
= gfc_match_varspec (e
, 0, false, true);
2854 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
2855 && sym
->ts
.type
== BT_UNKNOWN
2856 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
2864 if (sym
->attr
.subroutine
)
2866 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2872 /* At this point, the name has to be a non-statement function.
2873 If the name is the same as the current function being
2874 compiled, then we have a variable reference (to the function
2875 result) if the name is non-recursive. */
2877 st
= gfc_enclosing_unit (NULL
);
2879 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2881 && !sym
->attr
.recursive
)
2883 e
= gfc_get_expr ();
2884 e
->symtree
= symtree
;
2885 e
->expr_type
= EXPR_VARIABLE
;
2887 m
= gfc_match_varspec (e
, 0, false, true);
2891 /* Match a function reference. */
2893 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2896 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2897 gfc_error ("Statement function '%s' requires argument list at %C",
2900 gfc_error ("Function '%s' requires an argument list at %C",
2913 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2914 sym
= symtree
->n
.sym
;
2916 replace_hidden_procptr_result (&sym
, &symtree
);
2918 e
= gfc_get_expr ();
2919 e
->symtree
= symtree
;
2920 e
->expr_type
= EXPR_FUNCTION
;
2921 e
->value
.function
.actual
= actual_arglist
;
2922 e
->where
= gfc_current_locus
;
2924 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2925 && CLASS_DATA (sym
)->as
)
2926 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
2927 else if (sym
->as
!= NULL
)
2928 e
->rank
= sym
->as
->rank
;
2930 if (!sym
->attr
.function
2931 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
2937 /* Check here for the existence of at least one argument for the
2938 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2939 argument(s) given will be checked in gfc_iso_c_func_interface,
2940 during resolution of the function call. */
2941 if (sym
->attr
.is_iso_c
== 1
2942 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2943 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2944 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2945 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2947 /* make sure we were given a param */
2948 if (actual_arglist
== NULL
)
2950 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2956 if (sym
->result
== NULL
)
2964 /* Special case for derived type variables that get their types
2965 via an IMPLICIT statement. This can't wait for the
2966 resolution phase. */
2968 if (gfc_peek_ascii_char () == '%'
2969 && sym
->ts
.type
== BT_UNKNOWN
2970 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2971 gfc_set_default_type (sym
, 0, sym
->ns
);
2973 /* If the symbol has a (co)dimension attribute, the expression is a
2976 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2978 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
2984 e
= gfc_get_expr ();
2985 e
->symtree
= symtree
;
2986 e
->expr_type
= EXPR_VARIABLE
;
2987 m
= gfc_match_varspec (e
, 0, false, true);
2991 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2992 && (CLASS_DATA (sym
)->attr
.dimension
2993 || CLASS_DATA (sym
)->attr
.codimension
))
2995 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3001 e
= gfc_get_expr ();
3002 e
->symtree
= symtree
;
3003 e
->expr_type
= EXPR_VARIABLE
;
3004 m
= gfc_match_varspec (e
, 0, false, true);
3008 /* Name is not an array, so we peek to see if a '(' implies a
3009 function call or a substring reference. Otherwise the
3010 variable is just a scalar. */
3012 gfc_gobble_whitespace ();
3013 if (gfc_peek_ascii_char () != '(')
3015 /* Assume a scalar variable */
3016 e
= gfc_get_expr ();
3017 e
->symtree
= symtree
;
3018 e
->expr_type
= EXPR_VARIABLE
;
3020 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3026 /*FIXME:??? gfc_match_varspec does set this for us: */
3028 m
= gfc_match_varspec (e
, 0, false, true);
3032 /* See if this is a function reference with a keyword argument
3033 as first argument. We do this because otherwise a spurious
3034 symbol would end up in the symbol table. */
3036 old_loc
= gfc_current_locus
;
3037 m2
= gfc_match (" ( %n =", argname
);
3038 gfc_current_locus
= old_loc
;
3040 e
= gfc_get_expr ();
3041 e
->symtree
= symtree
;
3043 if (m2
!= MATCH_YES
)
3045 /* Try to figure out whether we're dealing with a character type.
3046 We're peeking ahead here, because we don't want to call
3047 match_substring if we're dealing with an implicitly typed
3048 non-character variable. */
3049 implicit_char
= false;
3050 if (sym
->ts
.type
== BT_UNKNOWN
)
3052 ts
= gfc_get_default_type (sym
->name
, NULL
);
3053 if (ts
->type
== BT_CHARACTER
)
3054 implicit_char
= true;
3057 /* See if this could possibly be a substring reference of a name
3058 that we're not sure is a variable yet. */
3060 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3061 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
3064 e
->expr_type
= EXPR_VARIABLE
;
3066 if (sym
->attr
.flavor
!= FL_VARIABLE
3067 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3074 if (sym
->ts
.type
== BT_UNKNOWN
3075 && !gfc_set_default_type (sym
, 1, NULL
))
3089 /* Give up, assume we have a function. */
3091 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3092 sym
= symtree
->n
.sym
;
3093 e
->expr_type
= EXPR_FUNCTION
;
3095 if (!sym
->attr
.function
3096 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3104 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3106 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
3114 /* If our new function returns a character, array or structure
3115 type, it might have subsequent references. */
3117 m
= gfc_match_varspec (e
, 0, false, true);
3124 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3126 e
= gfc_get_expr ();
3127 e
->symtree
= symtree
;
3128 e
->expr_type
= EXPR_FUNCTION
;
3130 if (sym
->attr
.flavor
== FL_DERIVED
)
3132 e
->value
.function
.esym
= sym
;
3133 e
->symtree
->n
.sym
->attr
.generic
= 1;
3136 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3140 gfc_error ("Symbol at %C is not appropriate for an expression");
3156 /* Match a variable, i.e. something that can be assigned to. This
3157 starts as a symbol, can be a structure component or an array
3158 reference. It can be a function if the function doesn't have a
3159 separate RESULT variable. If the symbol has not been previously
3160 seen, we assume it is a variable.
3162 This function is called by two interface functions:
3163 gfc_match_variable, which has host_flag = 1, and
3164 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3165 match of the symbol to the local scope. */
3168 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3176 /* Since nothing has any business being an lvalue in a module
3177 specification block, an interface block or a contains section,
3178 we force the changed_symbols mechanism to work by setting
3179 host_flag to 0. This prevents valid symbols that have the name
3180 of keywords, such as 'end', being turned into variables by
3181 failed matching to assignments for, e.g., END INTERFACE. */
3182 if (gfc_current_state () == COMP_MODULE
3183 || gfc_current_state () == COMP_INTERFACE
3184 || gfc_current_state () == COMP_CONTAINS
)
3187 where
= gfc_current_locus
;
3188 m
= gfc_match_sym_tree (&st
, host_flag
);
3194 /* If this is an implicit do loop index and implicitly typed,
3195 it should not be host associated. */
3196 m
= check_for_implicit_index (&st
, &sym
);
3200 sym
->attr
.implied_index
= 0;
3202 gfc_set_sym_referenced (sym
);
3203 switch (sym
->attr
.flavor
)
3206 /* Everything is alright. */
3211 sym_flavor flavor
= FL_UNKNOWN
;
3213 gfc_gobble_whitespace ();
3215 if (sym
->attr
.external
|| sym
->attr
.procedure
3216 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3217 flavor
= FL_PROCEDURE
;
3219 /* If it is not a procedure, is not typed and is host associated,
3220 we cannot give it a flavor yet. */
3221 else if (sym
->ns
== gfc_current_ns
->parent
3222 && sym
->ts
.type
== BT_UNKNOWN
)
3225 /* These are definitive indicators that this is a variable. */
3226 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3227 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3228 flavor
= FL_VARIABLE
;
3230 if (flavor
!= FL_UNKNOWN
3231 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3239 gfc_error ("Named constant at %C in an EQUIVALENCE");
3242 /* Otherwise this is checked for and an error given in the
3243 variable definition context checks. */
3247 /* Check for a nonrecursive function result variable. */
3248 if (sym
->attr
.function
3249 && !sym
->attr
.external
3250 && sym
->result
== sym
3251 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3253 && sym
->ns
== gfc_current_ns
)
3255 && sym
->ns
== gfc_current_ns
->parent
)))
3257 /* If a function result is a derived type, then the derived
3258 type may still have to be resolved. */
3260 if (sym
->ts
.type
== BT_DERIVED
3261 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3266 if (sym
->attr
.proc_pointer
3267 || replace_hidden_procptr_result (&sym
, &st
))
3270 /* Fall through to error */
3273 gfc_error ("'%s' at %C is not a variable", sym
->name
);
3277 /* Special case for derived type variables that get their types
3278 via an IMPLICIT statement. This can't wait for the
3279 resolution phase. */
3282 gfc_namespace
* implicit_ns
;
3284 if (gfc_current_ns
->proc_name
== sym
)
3285 implicit_ns
= gfc_current_ns
;
3287 implicit_ns
= sym
->ns
;
3289 if (gfc_peek_ascii_char () == '%'
3290 && sym
->ts
.type
== BT_UNKNOWN
3291 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3292 gfc_set_default_type (sym
, 0, implicit_ns
);
3295 expr
= gfc_get_expr ();
3297 expr
->expr_type
= EXPR_VARIABLE
;
3300 expr
->where
= where
;
3302 /* Now see if we have to do more. */
3303 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3306 gfc_free_expr (expr
);
3316 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3318 return match_variable (result
, equiv_flag
, 1);
3323 gfc_match_equiv_variable (gfc_expr
**result
)
3325 return match_variable (result
, 1, 0);