1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
31 #include "constructor.h"
33 int matching_actual_arglist
= 0;
35 /* Matches a kind-parameter expression, which is either a named
36 symbolic constant or a nonnegative integer constant. If
37 successful, sets the kind value to the correct integer.
38 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
39 symbol like e.g. 'c_int'. */
42 match_kind_param (int *kind
, int *is_iso_c
)
44 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
51 m
= gfc_match_small_literal_int (kind
, NULL
);
55 m
= gfc_match_name (name
);
59 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
65 *is_iso_c
= sym
->attr
.is_iso_c
;
67 if (sym
->attr
.flavor
!= FL_PARAMETER
)
70 if (sym
->value
== NULL
)
73 p
= gfc_extract_int (sym
->value
, kind
);
77 gfc_set_sym_referenced (sym
);
86 /* Get a trailing kind-specification for non-character variables.
88 * the integer kind value or
89 * -1 if an error was generated,
90 * -2 if no kind was found.
91 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
92 symbol like e.g. 'c_int'. */
95 get_kind (int *is_iso_c
)
102 if (gfc_match_char ('_') != MATCH_YES
)
105 m
= match_kind_param (&kind
, is_iso_c
);
107 gfc_error ("Missing kind-parameter at %C");
109 return (m
== MATCH_YES
) ? kind
: -1;
113 /* Given a character and a radix, see if the character is a valid
114 digit in that radix. */
117 gfc_check_digit (char c
, int radix
)
124 r
= ('0' <= c
&& c
<= '1');
128 r
= ('0' <= c
&& c
<= '7');
132 r
= ('0' <= c
&& c
<= '9');
140 gfc_internal_error ("gfc_check_digit(): bad radix");
147 /* Match the digit string part of an integer if signflag is not set,
148 the signed digit string part if signflag is set. If the buffer
149 is NULL, we just count characters for the resolution pass. Returns
150 the number of characters matched, -1 for no match. */
153 match_digits (int signflag
, int radix
, char *buffer
)
160 c
= gfc_next_ascii_char ();
162 if (signflag
&& (c
== '+' || c
== '-'))
166 gfc_gobble_whitespace ();
167 c
= gfc_next_ascii_char ();
171 if (!gfc_check_digit (c
, radix
))
180 old_loc
= gfc_current_locus
;
181 c
= gfc_next_ascii_char ();
183 if (!gfc_check_digit (c
, radix
))
191 gfc_current_locus
= old_loc
;
197 /* Match an integer (digit string and optional kind).
198 A sign will be accepted if signflag is set. */
201 match_integer_constant (gfc_expr
**result
, int signflag
)
203 int length
, kind
, is_iso_c
;
208 old_loc
= gfc_current_locus
;
209 gfc_gobble_whitespace ();
211 length
= match_digits (signflag
, 10, NULL
);
212 gfc_current_locus
= old_loc
;
216 buffer
= (char *) alloca (length
+ 1);
217 memset (buffer
, '\0', length
+ 1);
219 gfc_gobble_whitespace ();
221 match_digits (signflag
, 10, buffer
);
223 kind
= get_kind (&is_iso_c
);
225 kind
= gfc_default_integer_kind
;
229 if (kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
232 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
234 gfc_error ("Integer kind %d at %C not available", kind
);
238 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
239 e
->ts
.is_c_interop
= is_iso_c
;
241 if (gfc_range_check (e
) != ARITH_OK
)
243 gfc_error ("Integer too big for its kind at %C. This check can be "
244 "disabled with the option -fno-range-check");
255 /* Match a Hollerith constant. */
258 match_hollerith_constant (gfc_expr
**result
)
266 old_loc
= gfc_current_locus
;
267 gfc_gobble_whitespace ();
269 if (match_integer_constant (&e
, 0) == MATCH_YES
270 && gfc_match_char ('h') == MATCH_YES
)
272 if (gfc_notify_std (GFC_STD_LEGACY
, "Hollerith constant "
276 msg
= gfc_extract_int (e
, &num
);
284 gfc_error ("Invalid Hollerith constant: %L must contain at least "
285 "one character", &old_loc
);
288 if (e
->ts
.kind
!= gfc_default_integer_kind
)
290 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
291 "should be default", &old_loc
);
297 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
300 /* Calculate padding needed to fit default integer memory. */
301 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
303 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
305 for (i
= 0; i
< num
; i
++)
307 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
308 if (! gfc_wide_fits_in_byte (c
))
310 gfc_error ("Invalid Hollerith constant at %L contains a "
311 "wide character", &old_loc
);
315 e
->representation
.string
[i
] = (unsigned char) c
;
318 /* Now pad with blanks and end with a null char. */
319 for (i
= 0; i
< pad
; i
++)
320 e
->representation
.string
[num
+ i
] = ' ';
322 e
->representation
.string
[num
+ i
] = '\0';
323 e
->representation
.length
= num
+ pad
;
332 gfc_current_locus
= old_loc
;
341 /* Match a binary, octal or hexadecimal constant that can be found in
342 a DATA statement. The standard permits b'010...', o'73...', and
343 z'a1...' where b, o, and z can be capital letters. This function
344 also accepts postfixed forms of the constants: '01...'b, '73...'o,
345 and 'a1...'z. An additional extension is the use of x for z. */
348 match_boz_constant (gfc_expr
**result
)
350 int radix
, length
, x_hex
, kind
;
351 locus old_loc
, start_loc
;
352 char *buffer
, post
, delim
;
355 start_loc
= old_loc
= gfc_current_locus
;
356 gfc_gobble_whitespace ();
359 switch (post
= gfc_next_ascii_char ())
381 radix
= 16; /* Set to accept any valid digit string. */
387 /* No whitespace allowed here. */
390 delim
= gfc_next_ascii_char ();
392 if (delim
!= '\'' && delim
!= '\"')
396 && (gfc_notify_std (GFC_STD_GNU
, "Hexadecimal "
397 "constant at %C uses non-standard syntax")
401 old_loc
= gfc_current_locus
;
403 length
= match_digits (0, radix
, NULL
);
406 gfc_error ("Empty set of digits in BOZ constant at %C");
410 if (gfc_next_ascii_char () != delim
)
412 gfc_error ("Illegal character in BOZ constant at %C");
418 switch (gfc_next_ascii_char ())
435 if (gfc_notify_std (GFC_STD_GNU
, "BOZ constant "
436 "at %C uses non-standard postfix syntax")
441 gfc_current_locus
= old_loc
;
443 buffer
= (char *) alloca (length
+ 1);
444 memset (buffer
, '\0', length
+ 1);
446 match_digits (0, radix
, buffer
);
447 gfc_next_ascii_char (); /* Eat delimiter. */
449 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
451 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
452 "If a data-stmt-constant is a boz-literal-constant, the corresponding
453 variable shall be of type integer. The boz-literal-constant is treated
454 as if it were an int-literal-constant with a kind-param that specifies
455 the representation method with the largest decimal exponent range
456 supported by the processor." */
458 kind
= gfc_max_integer_kind
;
459 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
461 /* Mark as boz variable. */
464 if (gfc_range_check (e
) != ARITH_OK
)
466 gfc_error ("Integer too big for integer kind %i at %C", kind
);
471 if (!gfc_in_match_data ()
472 && (gfc_notify_std (GFC_STD_F2003
, "BOZ used outside a DATA "
481 gfc_current_locus
= start_loc
;
486 /* Match a real constant of some sort. Allow a signed constant if signflag
490 match_real_constant (gfc_expr
**result
, int signflag
)
492 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
;
493 locus old_loc
, temp_loc
;
494 char *p
, *buffer
, c
, exp_char
;
498 old_loc
= gfc_current_locus
;
499 gfc_gobble_whitespace ();
509 c
= gfc_next_ascii_char ();
510 if (signflag
&& (c
== '+' || c
== '-'))
515 gfc_gobble_whitespace ();
516 c
= gfc_next_ascii_char ();
519 /* Scan significand. */
520 for (;; c
= gfc_next_ascii_char (), count
++)
527 /* Check to see if "." goes with a following operator like
529 temp_loc
= gfc_current_locus
;
530 c
= gfc_next_ascii_char ();
532 if (c
== 'e' || c
== 'd' || c
== 'q')
534 c
= gfc_next_ascii_char ();
536 goto done
; /* Operator named .e. or .d. */
540 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
542 gfc_current_locus
= temp_loc
;
556 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
563 if (gfc_notify_std (GFC_STD_GNU
, "exponent-letter 'q' in "
564 "real-literal-constant at %C") == FAILURE
)
566 else if (gfc_option
.warn_real_q_constant
)
567 gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
572 c
= gfc_next_ascii_char ();
575 if (c
== '+' || c
== '-')
576 { /* optional sign */
577 c
= gfc_next_ascii_char ();
583 gfc_error ("Missing exponent in real number at %C");
589 c
= gfc_next_ascii_char ();
594 /* Check that we have a numeric constant. */
595 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
597 gfc_current_locus
= old_loc
;
601 /* Convert the number. */
602 gfc_current_locus
= old_loc
;
603 gfc_gobble_whitespace ();
605 buffer
= (char *) alloca (count
+ 1);
606 memset (buffer
, '\0', count
+ 1);
609 c
= gfc_next_ascii_char ();
610 if (c
== '+' || c
== '-')
612 gfc_gobble_whitespace ();
613 c
= gfc_next_ascii_char ();
616 /* Hack for mpfr_set_str(). */
619 if (c
== 'd' || c
== 'q')
627 c
= gfc_next_ascii_char ();
630 kind
= get_kind (&is_iso_c
);
639 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
643 kind
= gfc_default_double_kind
;
647 if (gfc_option
.flag_real4_kind
== 8)
649 if (gfc_option
.flag_real4_kind
== 10)
651 if (gfc_option
.flag_real4_kind
== 16)
657 if (gfc_option
.flag_real8_kind
== 4)
659 if (gfc_option
.flag_real8_kind
== 10)
661 if (gfc_option
.flag_real8_kind
== 16)
669 gfc_error ("Real number at %C has a 'q' exponent and an explicit "
674 /* The maximum possible real kind type parameter is 16. First, try
675 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
676 extended precision. If neither value works, just given up. */
678 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
681 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
683 gfc_error ("Invalid exponent-letter 'q' in "
684 "real-literal-constant at %C");
692 kind
= gfc_default_real_kind
;
696 if (gfc_option
.flag_real4_kind
== 8)
698 if (gfc_option
.flag_real4_kind
== 10)
700 if (gfc_option
.flag_real4_kind
== 16)
706 if (gfc_option
.flag_real8_kind
== 4)
708 if (gfc_option
.flag_real8_kind
== 10)
710 if (gfc_option
.flag_real8_kind
== 16)
714 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
716 gfc_error ("Invalid real kind %d at %C", kind
);
721 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
723 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
724 e
->ts
.is_c_interop
= is_iso_c
;
726 switch (gfc_range_check (e
))
731 gfc_error ("Real constant overflows its kind at %C");
734 case ARITH_UNDERFLOW
:
735 if (gfc_option
.warn_underflow
)
736 gfc_warning ("Real constant underflows its kind at %C");
737 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
741 gfc_internal_error ("gfc_range_check() returned bad value");
753 /* Match a substring reference. */
756 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
758 gfc_expr
*start
, *end
;
766 old_loc
= gfc_current_locus
;
768 m
= gfc_match_char ('(');
772 if (gfc_match_char (':') != MATCH_YES
)
775 m
= gfc_match_init_expr (&start
);
777 m
= gfc_match_expr (&start
);
785 m
= gfc_match_char (':');
790 if (gfc_match_char (')') != MATCH_YES
)
793 m
= gfc_match_init_expr (&end
);
795 m
= gfc_match_expr (&end
);
799 if (m
== MATCH_ERROR
)
802 m
= gfc_match_char (')');
807 /* Optimize away the (:) reference. */
808 if (start
== NULL
&& end
== NULL
)
812 ref
= gfc_get_ref ();
814 ref
->type
= REF_SUBSTRING
;
816 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
817 ref
->u
.ss
.start
= start
;
818 if (end
== NULL
&& cl
)
819 end
= gfc_copy_expr (cl
->length
);
821 ref
->u
.ss
.length
= cl
;
828 gfc_error ("Syntax error in SUBSTRING specification at %C");
832 gfc_free_expr (start
);
835 gfc_current_locus
= old_loc
;
840 /* Reads the next character of a string constant, taking care to
841 return doubled delimiters on the input as a single instance of
844 Special return values for "ret" argument are:
845 -1 End of the string, as determined by the delimiter
846 -2 Unterminated string detected
848 Backslash codes are also expanded at this time. */
851 next_string_char (gfc_char_t delimiter
, int *ret
)
856 c
= gfc_next_char_literal (INSTRING_WARN
);
865 if (gfc_option
.flag_backslash
&& c
== '\\')
867 old_locus
= gfc_current_locus
;
869 if (gfc_match_special_char (&c
) == MATCH_NO
)
870 gfc_current_locus
= old_locus
;
872 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
873 gfc_warning ("Extension: backslash character at %C");
879 old_locus
= gfc_current_locus
;
880 c
= gfc_next_char_literal (NONSTRING
);
884 gfc_current_locus
= old_locus
;
891 /* Special case of gfc_match_name() that matches a parameter kind name
892 before a string constant. This takes case of the weird but legal
897 where kind____ is a parameter. gfc_match_name() will happily slurp
898 up all the underscores, which leads to problems. If we return
899 MATCH_YES, the parse pointer points to the final underscore, which
900 is not part of the name. We never return MATCH_ERROR-- errors in
901 the name will be detected later. */
904 match_charkind_name (char *name
)
910 gfc_gobble_whitespace ();
911 c
= gfc_next_ascii_char ();
920 old_loc
= gfc_current_locus
;
921 c
= gfc_next_ascii_char ();
925 peek
= gfc_peek_ascii_char ();
927 if (peek
== '\'' || peek
== '\"')
929 gfc_current_locus
= old_loc
;
937 && (c
!= '$' || !gfc_option
.flag_dollar_ok
))
941 if (++len
> GFC_MAX_SYMBOL_LEN
)
949 /* See if the current input matches a character constant. Lots of
950 contortions have to be done to match the kind parameter which comes
951 before the actual string. The main consideration is that we don't
952 want to error out too quickly. For example, we don't actually do
953 any validation of the kinds until we have actually seen a legal
954 delimiter. Using match_kind_param() generates errors too quickly. */
957 match_string_constant (gfc_expr
**result
)
959 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
960 int i
, kind
, length
, warn_ampersand
, ret
;
961 locus old_locus
, start_locus
;
966 gfc_char_t c
, delimiter
, *p
;
968 old_locus
= gfc_current_locus
;
970 gfc_gobble_whitespace ();
972 c
= gfc_next_char ();
973 if (c
== '\'' || c
== '"')
975 kind
= gfc_default_character_kind
;
976 start_locus
= gfc_current_locus
;
980 if (gfc_wide_is_digit (c
))
984 while (gfc_wide_is_digit (c
))
986 kind
= kind
* 10 + c
- '0';
989 c
= gfc_next_char ();
995 gfc_current_locus
= old_locus
;
997 m
= match_charkind_name (name
);
1001 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1003 || sym
->attr
.flavor
!= FL_PARAMETER
)
1007 c
= gfc_next_char ();
1012 gfc_gobble_whitespace ();
1013 c
= gfc_next_char ();
1019 gfc_gobble_whitespace ();
1021 c
= gfc_next_char ();
1022 if (c
!= '\'' && c
!= '"')
1025 start_locus
= gfc_current_locus
;
1029 q
= gfc_extract_int (sym
->value
, &kind
);
1035 gfc_set_sym_referenced (sym
);
1038 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1040 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1045 /* Scan the string into a block of memory by first figuring out how
1046 long it is, allocating the structure, then re-reading it. This
1047 isn't particularly efficient, but string constants aren't that
1048 common in most code. TODO: Use obstacks? */
1055 c
= next_string_char (delimiter
, &ret
);
1060 gfc_current_locus
= start_locus
;
1061 gfc_error ("Unterminated character constant beginning at %C");
1068 /* Peek at the next character to see if it is a b, o, z, or x for the
1069 postfixed BOZ literal constants. */
1070 peek
= gfc_peek_ascii_char ();
1071 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1074 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1076 gfc_current_locus
= start_locus
;
1078 /* We disable the warning for the following loop as the warning has already
1079 been printed in the loop above. */
1080 warn_ampersand
= gfc_option
.warn_ampersand
;
1081 gfc_option
.warn_ampersand
= 0;
1083 p
= e
->value
.character
.string
;
1084 for (i
= 0; i
< length
; i
++)
1086 c
= next_string_char (delimiter
, &ret
);
1088 if (!gfc_check_character_range (c
, kind
))
1091 gfc_error ("Character '%s' in string at %C is not representable "
1092 "in character kind %d", gfc_print_wide_char (c
), kind
);
1099 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1100 gfc_option
.warn_ampersand
= warn_ampersand
;
1102 next_string_char (delimiter
, &ret
);
1104 gfc_internal_error ("match_string_constant(): Delimiter not found");
1106 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1107 e
->expr_type
= EXPR_SUBSTRING
;
1114 gfc_current_locus
= old_locus
;
1119 /* Match a .true. or .false. Returns 1 if a .true. was found,
1120 0 if a .false. was found, and -1 otherwise. */
1122 match_logical_constant_string (void)
1124 locus orig_loc
= gfc_current_locus
;
1126 gfc_gobble_whitespace ();
1127 if (gfc_next_ascii_char () == '.')
1129 char ch
= gfc_next_ascii_char ();
1132 if (gfc_next_ascii_char () == 'a'
1133 && gfc_next_ascii_char () == 'l'
1134 && gfc_next_ascii_char () == 's'
1135 && gfc_next_ascii_char () == 'e'
1136 && gfc_next_ascii_char () == '.')
1137 /* Matched ".false.". */
1142 if (gfc_next_ascii_char () == 'r'
1143 && gfc_next_ascii_char () == 'u'
1144 && gfc_next_ascii_char () == 'e'
1145 && gfc_next_ascii_char () == '.')
1146 /* Matched ".true.". */
1150 gfc_current_locus
= orig_loc
;
1154 /* Match a .true. or .false. */
1157 match_logical_constant (gfc_expr
**result
)
1160 int i
, kind
, is_iso_c
;
1162 i
= match_logical_constant_string ();
1166 kind
= get_kind (&is_iso_c
);
1170 kind
= gfc_default_logical_kind
;
1172 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1174 gfc_error ("Bad kind for logical constant at %C");
1178 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1179 e
->ts
.is_c_interop
= is_iso_c
;
1186 /* Match a real or imaginary part of a complex constant that is a
1187 symbolic constant. */
1190 match_sym_complex_part (gfc_expr
**result
)
1192 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1197 m
= gfc_match_name (name
);
1201 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1204 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1206 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1210 if (!gfc_numeric_ts (&sym
->value
->ts
))
1212 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1216 if (sym
->value
->rank
!= 0)
1218 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1222 if (gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1223 "complex constant at %C") == FAILURE
)
1226 switch (sym
->value
->ts
.type
)
1229 e
= gfc_copy_expr (sym
->value
);
1233 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1239 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1245 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1248 *result
= e
; /* e is a scalar, real, constant expression. */
1252 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1257 /* Match a real or imaginary part of a complex number. */
1260 match_complex_part (gfc_expr
**result
)
1264 m
= match_sym_complex_part (result
);
1268 m
= match_real_constant (result
, 1);
1272 return match_integer_constant (result
, 1);
1276 /* Try to match a complex constant. */
1279 match_complex_constant (gfc_expr
**result
)
1281 gfc_expr
*e
, *real
, *imag
;
1282 gfc_error_buf old_error
;
1283 gfc_typespec target
;
1288 old_loc
= gfc_current_locus
;
1289 real
= imag
= e
= NULL
;
1291 m
= gfc_match_char ('(');
1295 gfc_push_error (&old_error
);
1297 m
= match_complex_part (&real
);
1300 gfc_free_error (&old_error
);
1304 if (gfc_match_char (',') == MATCH_NO
)
1306 gfc_pop_error (&old_error
);
1311 /* If m is error, then something was wrong with the real part and we
1312 assume we have a complex constant because we've seen the ','. An
1313 ambiguous case here is the start of an iterator list of some
1314 sort. These sort of lists are matched prior to coming here. */
1316 if (m
== MATCH_ERROR
)
1318 gfc_free_error (&old_error
);
1321 gfc_pop_error (&old_error
);
1323 m
= match_complex_part (&imag
);
1326 if (m
== MATCH_ERROR
)
1329 m
= gfc_match_char (')');
1332 /* Give the matcher for implied do-loops a chance to run. This
1333 yields a much saner error message for (/ (i, 4=i, 6) /). */
1334 if (gfc_peek_ascii_char () == '=')
1343 if (m
== MATCH_ERROR
)
1346 /* Decide on the kind of this complex number. */
1347 if (real
->ts
.type
== BT_REAL
)
1349 if (imag
->ts
.type
== BT_REAL
)
1350 kind
= gfc_kind_max (real
, imag
);
1352 kind
= real
->ts
.kind
;
1356 if (imag
->ts
.type
== BT_REAL
)
1357 kind
= imag
->ts
.kind
;
1359 kind
= gfc_default_real_kind
;
1361 gfc_clear_ts (&target
);
1362 target
.type
= BT_REAL
;
1365 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1366 gfc_convert_type (real
, &target
, 2);
1367 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1368 gfc_convert_type (imag
, &target
, 2);
1370 e
= gfc_convert_complex (real
, imag
, kind
);
1371 e
->where
= gfc_current_locus
;
1373 gfc_free_expr (real
);
1374 gfc_free_expr (imag
);
1380 gfc_error ("Syntax error in COMPLEX constant at %C");
1385 gfc_free_expr (real
);
1386 gfc_free_expr (imag
);
1387 gfc_current_locus
= old_loc
;
1393 /* Match constants in any of several forms. Returns nonzero for a
1394 match, zero for no match. */
1397 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1401 m
= match_complex_constant (result
);
1405 m
= match_string_constant (result
);
1409 m
= match_boz_constant (result
);
1413 m
= match_real_constant (result
, signflag
);
1417 m
= match_hollerith_constant (result
);
1421 m
= match_integer_constant (result
, signflag
);
1425 m
= match_logical_constant (result
);
1433 /* This checks if a symbol is the return value of an encompassing function.
1434 Function nesting can be maximally two levels deep, but we may have
1435 additional local namespaces like BLOCK etc. */
1438 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1440 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1444 if (ns
->proc_name
== sym
)
1452 /* Match a single actual argument value. An actual argument is
1453 usually an expression, but can also be a procedure name. If the
1454 argument is a single name, it is not always possible to tell
1455 whether the name is a dummy procedure or not. We treat these cases
1456 by creating an argument that looks like a dummy procedure and
1457 fixing things later during resolution. */
1460 match_actual_arg (gfc_expr
**result
)
1462 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1463 gfc_symtree
*symtree
;
1468 gfc_gobble_whitespace ();
1469 where
= gfc_current_locus
;
1471 switch (gfc_match_name (name
))
1480 w
= gfc_current_locus
;
1481 gfc_gobble_whitespace ();
1482 c
= gfc_next_ascii_char ();
1483 gfc_current_locus
= w
;
1485 if (c
!= ',' && c
!= ')')
1488 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1490 /* Handle error elsewhere. */
1492 /* Eliminate a couple of common cases where we know we don't
1493 have a function argument. */
1494 if (symtree
== NULL
)
1496 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1497 gfc_set_sym_referenced (symtree
->n
.sym
);
1503 sym
= symtree
->n
.sym
;
1504 gfc_set_sym_referenced (sym
);
1505 if (sym
->attr
.flavor
!= FL_PROCEDURE
1506 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1509 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1511 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
,
1512 &sym
->declared_at
) == FAILURE
)
1517 /* If the symbol is a function with itself as the result and
1518 is being defined, then we have a variable. */
1519 if (sym
->attr
.function
&& sym
->result
== sym
)
1521 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1525 && (sym
->ns
== gfc_current_ns
1526 || sym
->ns
== gfc_current_ns
->parent
))
1528 gfc_entry_list
*el
= NULL
;
1530 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1540 e
= gfc_get_expr (); /* Leave it unknown for now */
1541 e
->symtree
= symtree
;
1542 e
->expr_type
= EXPR_VARIABLE
;
1543 e
->ts
.type
= BT_PROCEDURE
;
1550 gfc_current_locus
= where
;
1551 return gfc_match_expr (result
);
1555 /* Match a keyword argument. */
1558 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1560 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1561 gfc_actual_arglist
*a
;
1565 name_locus
= gfc_current_locus
;
1566 m
= gfc_match_name (name
);
1570 if (gfc_match_char ('=') != MATCH_YES
)
1576 m
= match_actual_arg (&actual
->expr
);
1580 /* Make sure this name has not appeared yet. */
1582 if (name
[0] != '\0')
1584 for (a
= base
; a
; a
= a
->next
)
1585 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1587 gfc_error ("Keyword '%s' at %C has already appeared in the "
1588 "current argument list", name
);
1593 actual
->name
= gfc_get_string (name
);
1597 gfc_current_locus
= name_locus
;
1602 /* Match an argument list function, such as %VAL. */
1605 match_arg_list_function (gfc_actual_arglist
*result
)
1607 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1611 old_locus
= gfc_current_locus
;
1613 if (gfc_match_char ('%') != MATCH_YES
)
1619 m
= gfc_match ("%n (", name
);
1623 if (name
[0] != '\0')
1628 if (strncmp (name
, "loc", 3) == 0)
1630 result
->name
= "%LOC";
1634 if (strncmp (name
, "ref", 3) == 0)
1636 result
->name
= "%REF";
1640 if (strncmp (name
, "val", 3) == 0)
1642 result
->name
= "%VAL";
1651 if (gfc_notify_std (GFC_STD_GNU
, "argument list "
1652 "function at %C") == FAILURE
)
1658 m
= match_actual_arg (&result
->expr
);
1662 if (gfc_match_char (')') != MATCH_YES
)
1671 gfc_current_locus
= old_locus
;
1676 /* Matches an actual argument list of a function or subroutine, from
1677 the opening parenthesis to the closing parenthesis. The argument
1678 list is assumed to allow keyword arguments because we don't know if
1679 the symbol associated with the procedure has an implicit interface
1680 or not. We make sure keywords are unique. If sub_flag is set,
1681 we're matching the argument list of a subroutine. */
1684 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1686 gfc_actual_arglist
*head
, *tail
;
1688 gfc_st_label
*label
;
1692 *argp
= tail
= NULL
;
1693 old_loc
= gfc_current_locus
;
1697 if (gfc_match_char ('(') == MATCH_NO
)
1698 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1700 if (gfc_match_char (')') == MATCH_YES
)
1704 matching_actual_arglist
++;
1709 head
= tail
= gfc_get_actual_arglist ();
1712 tail
->next
= gfc_get_actual_arglist ();
1716 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1718 m
= gfc_match_st_label (&label
);
1720 gfc_error ("Expected alternate return label at %C");
1724 tail
->label
= label
;
1728 /* After the first keyword argument is seen, the following
1729 arguments must also have keywords. */
1732 m
= match_keyword_arg (tail
, head
);
1734 if (m
== MATCH_ERROR
)
1738 gfc_error ("Missing keyword name in actual argument list at %C");
1745 /* Try an argument list function, like %VAL. */
1746 m
= match_arg_list_function (tail
);
1747 if (m
== MATCH_ERROR
)
1750 /* See if we have the first keyword argument. */
1753 m
= match_keyword_arg (tail
, head
);
1756 if (m
== MATCH_ERROR
)
1762 /* Try for a non-keyword argument. */
1763 m
= match_actual_arg (&tail
->expr
);
1764 if (m
== MATCH_ERROR
)
1773 if (gfc_match_char (')') == MATCH_YES
)
1775 if (gfc_match_char (',') != MATCH_YES
)
1780 matching_actual_arglist
--;
1784 gfc_error ("Syntax error in argument list at %C");
1787 gfc_free_actual_arglist (head
);
1788 gfc_current_locus
= old_loc
;
1789 matching_actual_arglist
--;
1794 /* Used by gfc_match_varspec() to extend the reference list by one
1798 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1800 if (primary
->ref
== NULL
)
1801 primary
->ref
= tail
= gfc_get_ref ();
1805 gfc_internal_error ("extend_ref(): Bad tail");
1806 tail
->next
= gfc_get_ref ();
1814 /* Match any additional specifications associated with the current
1815 variable like member references or substrings. If equiv_flag is
1816 set we only match stuff that is allowed inside an EQUIVALENCE
1817 statement. sub_flag tells whether we expect a type-bound procedure found
1818 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1819 components, 'ppc_arg' determines whether the PPC may be called (with an
1820 argument list), or whether it may just be referred to as a pointer. */
1823 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1826 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1827 gfc_ref
*substring
, *tail
;
1828 gfc_component
*component
;
1829 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1835 gfc_gobble_whitespace ();
1837 if (gfc_peek_ascii_char () == '[')
1839 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1840 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1841 && CLASS_DATA (sym
)->attr
.dimension
))
1843 gfc_error ("Array section designator, e.g. '(:)', is required "
1844 "besides the coarray designator '[...]' at %C");
1847 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1848 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1849 && !CLASS_DATA (sym
)->attr
.codimension
))
1851 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1857 /* For associate names, we may not yet know whether they are arrays or not.
1858 Thus if we have one and parentheses follow, we have to assume that it
1859 actually is one for now. The final decision will be made at
1860 resolution time, of course. */
1861 if (sym
->assoc
&& gfc_peek_ascii_char () == '(')
1862 sym
->attr
.dimension
= 1;
1864 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1865 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1866 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1867 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1868 && !(gfc_matching_procptr_assignment
1869 && sym
->attr
.flavor
== FL_PROCEDURE
))
1870 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1871 && (CLASS_DATA (sym
)->attr
.dimension
1872 || CLASS_DATA (sym
)->attr
.codimension
)))
1876 tail
= extend_ref (primary
, tail
);
1877 tail
->type
= REF_ARRAY
;
1879 /* In EQUIVALENCE, we don't know yet whether we are seeing
1880 an array, character variable or array of character
1881 variables. We'll leave the decision till resolve time. */
1885 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1886 as
= CLASS_DATA (sym
)->as
;
1890 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1891 as
? as
->corank
: 0);
1895 gfc_gobble_whitespace ();
1896 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1898 tail
= extend_ref (primary
, tail
);
1899 tail
->type
= REF_ARRAY
;
1901 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1907 primary
->ts
= sym
->ts
;
1912 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1913 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1914 gfc_set_default_type (sym
, 0, sym
->ns
);
1916 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_match_char ('%') == MATCH_YES
)
1918 gfc_error ("Symbol '%s' at %C has no IMPLICIT type", sym
->name
);
1921 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1922 && gfc_match_char ('%') == MATCH_YES
)
1924 gfc_error ("Unexpected '%%' for nonderived-type variable '%s' at %C",
1929 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1930 || gfc_match_char ('%') != MATCH_YES
)
1931 goto check_substring
;
1933 sym
= sym
->ts
.u
.derived
;
1940 m
= gfc_match_name (name
);
1942 gfc_error ("Expected structure component name at %C");
1946 if (sym
->f2k_derived
)
1947 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1953 gfc_symbol
* tbp_sym
;
1958 gcc_assert (!tail
|| !tail
->next
);
1959 gcc_assert (primary
->expr_type
== EXPR_VARIABLE
1960 || (primary
->expr_type
== EXPR_STRUCTURE
1961 && primary
->symtree
&& primary
->symtree
->n
.sym
1962 && primary
->symtree
->n
.sym
->attr
.flavor
));
1964 if (tbp
->n
.tb
->is_generic
)
1967 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1969 primary
->expr_type
= EXPR_COMPCALL
;
1970 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1971 primary
->value
.compcall
.name
= tbp
->name
;
1972 primary
->value
.compcall
.ignore_pass
= 0;
1973 primary
->value
.compcall
.assign
= 0;
1974 primary
->value
.compcall
.base_object
= NULL
;
1975 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1977 primary
->ts
= tbp_sym
->ts
;
1979 gfc_clear_ts (&primary
->ts
);
1981 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1982 &primary
->value
.compcall
.actual
);
1983 if (m
== MATCH_ERROR
)
1988 primary
->value
.compcall
.actual
= NULL
;
1991 gfc_error ("Expected argument list at %C");
1999 component
= gfc_find_component (sym
, name
, false, false);
2000 if (component
== NULL
)
2003 tail
= extend_ref (primary
, tail
);
2004 tail
->type
= REF_COMPONENT
;
2006 tail
->u
.c
.component
= component
;
2007 tail
->u
.c
.sym
= sym
;
2009 primary
->ts
= component
->ts
;
2011 if (component
->attr
.proc_pointer
&& ppc_arg
)
2013 /* Procedure pointer component call: Look for argument list. */
2014 m
= gfc_match_actual_arglist (sub_flag
,
2015 &primary
->value
.compcall
.actual
);
2016 if (m
== MATCH_ERROR
)
2019 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2020 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2022 gfc_error ("Procedure pointer component '%s' requires an "
2023 "argument list at %C", component
->name
);
2028 primary
->expr_type
= EXPR_PPC
;
2033 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2035 tail
= extend_ref (primary
, tail
);
2036 tail
->type
= REF_ARRAY
;
2038 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2039 component
->as
->corank
);
2043 else if (component
->ts
.type
== BT_CLASS
2044 && CLASS_DATA (component
)->as
!= NULL
2045 && !component
->attr
.proc_pointer
)
2047 tail
= extend_ref (primary
, tail
);
2048 tail
->type
= REF_ARRAY
;
2050 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2052 CLASS_DATA (component
)->as
->corank
);
2057 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2058 || gfc_match_char ('%') != MATCH_YES
)
2061 sym
= component
->ts
.u
.derived
;
2066 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
2068 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2070 gfc_set_default_type (sym
, 0, sym
->ns
);
2071 primary
->ts
= sym
->ts
;
2076 if (primary
->ts
.type
== BT_CHARACTER
)
2078 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
2082 primary
->ref
= substring
;
2084 tail
->next
= substring
;
2086 if (primary
->expr_type
== EXPR_CONSTANT
)
2087 primary
->expr_type
= EXPR_SUBSTRING
;
2090 primary
->ts
.u
.cl
= NULL
;
2097 gfc_clear_ts (&primary
->ts
);
2098 gfc_clear_ts (&sym
->ts
);
2108 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2110 gfc_error ("Coindexed procedure-pointer component at %C");
2118 /* Given an expression that is a variable, figure out what the
2119 ultimate variable's type and attribute is, traversing the reference
2120 structures if necessary.
2122 This subroutine is trickier than it looks. We start at the base
2123 symbol and store the attribute. Component references load a
2124 completely new attribute.
2126 A couple of rules come into play. Subobjects of targets are always
2127 targets themselves. If we see a component that goes through a
2128 pointer, then the expression must also be a target, since the
2129 pointer is associated with something (if it isn't core will soon be
2130 dumped). If we see a full part or section of an array, the
2131 expression is also an array.
2133 We can have at most one full array reference. */
2136 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2138 int dimension
, pointer
, allocatable
, target
;
2139 symbol_attribute attr
;
2142 gfc_component
*comp
;
2144 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2145 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2147 sym
= expr
->symtree
->n
.sym
;
2150 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2152 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2153 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2154 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2158 dimension
= attr
.dimension
;
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 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2214 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2218 pointer
= comp
->attr
.pointer
;
2219 allocatable
= comp
->attr
.allocatable
;
2221 if (pointer
|| attr
.proc_pointer
)
2227 allocatable
= pointer
= 0;
2231 attr
.dimension
= dimension
;
2232 attr
.pointer
= pointer
;
2233 attr
.allocatable
= allocatable
;
2234 attr
.target
= target
;
2235 attr
.save
= sym
->attr
.save
;
2241 /* Return the attribute from a general expression. */
2244 gfc_expr_attr (gfc_expr
*e
)
2246 symbol_attribute attr
;
2248 switch (e
->expr_type
)
2251 attr
= gfc_variable_attr (e
, NULL
);
2255 gfc_clear_attr (&attr
);
2257 if (e
->value
.function
.esym
!= NULL
)
2259 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2261 if (sym
->ts
.type
== BT_CLASS
)
2263 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2264 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2265 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2269 attr
= gfc_variable_attr (e
, NULL
);
2271 /* TODO: NULL() returns pointers. May have to take care of this
2277 gfc_clear_attr (&attr
);
2285 /* Match a structure constructor. The initial symbol has already been
2288 typedef struct gfc_structure_ctor_component
2293 struct gfc_structure_ctor_component
* next
;
2295 gfc_structure_ctor_component
;
2297 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2300 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2303 gfc_free_expr (comp
->val
);
2308 /* Translate the component list into the actual constructor by sorting it in
2309 the order required; this also checks along the way that each and every
2310 component actually has an initializer and handles default initializers
2311 for components without explicit value given. */
2313 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2314 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2316 gfc_structure_ctor_component
*comp_iter
;
2317 gfc_component
*comp
;
2319 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2321 gfc_structure_ctor_component
**next_ptr
;
2322 gfc_expr
*value
= NULL
;
2324 /* Try to find the initializer for the current component by name. */
2325 next_ptr
= comp_head
;
2326 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2328 if (!strcmp (comp_iter
->name
, comp
->name
))
2330 next_ptr
= &comp_iter
->next
;
2333 /* If an extension, try building the parent derived type by building
2334 a value expression for the parent derived type and calling self. */
2335 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2337 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2339 &gfc_current_locus
);
2340 value
->ts
= comp
->ts
;
2342 if (build_actual_constructor (comp_head
, &value
->value
.constructor
,
2343 comp
->ts
.u
.derived
) == FAILURE
)
2345 gfc_free_expr (value
);
2349 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2353 /* If it was not found, try the default initializer if there's any;
2354 otherwise, it's an error. */
2357 if (comp
->initializer
)
2359 if (gfc_notify_std (GFC_STD_F2003
, "Structure"
2360 " constructor with missing optional arguments"
2361 " at %C") == FAILURE
)
2363 value
= gfc_copy_expr (comp
->initializer
);
2367 gfc_error ("No initializer for component '%s' given in the"
2368 " structure constructor at %C!", comp
->name
);
2373 value
= comp_iter
->val
;
2375 /* Add the value to the constructor chain built. */
2376 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2378 /* Remove the entry from the component list. We don't want the expression
2379 value to be free'd, so set it to NULL. */
2382 *next_ptr
= comp_iter
->next
;
2383 comp_iter
->val
= NULL
;
2384 gfc_free_structure_ctor_component (comp_iter
);
2392 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2393 gfc_actual_arglist
**arglist
,
2396 gfc_actual_arglist
*actual
;
2397 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2398 gfc_constructor_base ctor_head
= NULL
;
2399 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2400 const char* last_name
= NULL
;
2404 expr
= parent
? *cexpr
: e
;
2405 old_locus
= gfc_current_locus
;
2407 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2409 gfc_current_locus
= expr
->where
;
2411 comp_tail
= comp_head
= NULL
;
2413 if (!parent
&& sym
->attr
.abstract
)
2415 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2416 sym
->name
, &expr
->where
);
2420 comp
= sym
->components
;
2421 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2424 gfc_component
*this_comp
= NULL
;
2427 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2430 comp_tail
->next
= gfc_get_structure_ctor_component ();
2431 comp_tail
= comp_tail
->next
;
2435 if (gfc_notify_std (GFC_STD_F2003
, "Structure"
2436 " constructor with named arguments at %C")
2440 comp_tail
->name
= xstrdup (actual
->name
);
2441 last_name
= comp_tail
->name
;
2446 /* Components without name are not allowed after the first named
2447 component initializer! */
2451 gfc_error ("Component initializer without name after component"
2452 " named %s at %L!", last_name
,
2453 actual
->expr
? &actual
->expr
->where
2454 : &gfc_current_locus
);
2456 gfc_error ("Too many components in structure constructor at "
2457 "%L!", actual
->expr
? &actual
->expr
->where
2458 : &gfc_current_locus
);
2462 comp_tail
->name
= xstrdup (comp
->name
);
2465 /* Find the current component in the structure definition and check
2466 its access is not private. */
2468 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2471 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2473 comp
= NULL
; /* Reset needed! */
2476 /* Here we can check if a component name is given which does not
2477 correspond to any component of the defined structure. */
2481 comp_tail
->val
= actual
->expr
;
2482 if (actual
->expr
!= NULL
)
2483 comp_tail
->where
= actual
->expr
->where
;
2484 actual
->expr
= NULL
;
2486 /* Check if this component is already given a value. */
2487 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2488 comp_iter
= comp_iter
->next
)
2490 gcc_assert (comp_iter
);
2491 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2493 gfc_error ("Component '%s' is initialized twice in the structure"
2494 " constructor at %L!", comp_tail
->name
,
2495 comp_tail
->val
? &comp_tail
->where
2496 : &gfc_current_locus
);
2501 /* F2008, R457/C725, for PURE C1283. */
2502 if (this_comp
->attr
.pointer
&& comp_tail
->val
2503 && gfc_is_coindexed (comp_tail
->val
))
2505 gfc_error ("Coindexed expression to pointer component '%s' in "
2506 "structure constructor at %L!", comp_tail
->name
,
2511 /* If not explicitly a parent constructor, gather up the components
2513 if (comp
&& comp
== sym
->components
2514 && sym
->attr
.extension
2516 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2518 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2521 gfc_actual_arglist
*arg_null
= NULL
;
2523 actual
->expr
= comp_tail
->val
;
2524 comp_tail
->val
= NULL
;
2526 m
= gfc_convert_to_structure_constructor (NULL
,
2527 comp
->ts
.u
.derived
, &comp_tail
->val
,
2528 comp
->ts
.u
.derived
->attr
.zero_comp
2529 ? &arg_null
: &actual
, true);
2533 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2542 if (parent
&& !comp
)
2545 actual
= actual
->next
;
2548 if (build_actual_constructor (&comp_head
, &ctor_head
, sym
) == FAILURE
)
2551 /* No component should be left, as this should have caused an error in the
2552 loop constructing the component-list (name that does not correspond to any
2553 component in the structure definition). */
2554 if (comp_head
&& sym
->attr
.extension
)
2556 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2558 gfc_error ("component '%s' at %L has already been set by a "
2559 "parent derived type constructor", comp_iter
->name
,
2565 gcc_assert (!comp_head
);
2569 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2570 expr
->ts
.u
.derived
= sym
;
2571 expr
->value
.constructor
= ctor_head
;
2576 expr
->ts
.u
.derived
= sym
;
2578 expr
->ts
.type
= BT_DERIVED
;
2579 expr
->value
.constructor
= ctor_head
;
2580 expr
->expr_type
= EXPR_STRUCTURE
;
2583 gfc_current_locus
= old_locus
;
2589 gfc_current_locus
= old_locus
;
2591 for (comp_iter
= comp_head
; comp_iter
; )
2593 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2594 gfc_free_structure_ctor_component (comp_iter
);
2597 gfc_constructor_free (ctor_head
);
2604 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2608 gfc_symtree
*symtree
;
2610 gfc_get_sym_tree (sym
->name
, NULL
, &symtree
, false); /* Can't fail */
2612 e
= gfc_get_expr ();
2613 e
->symtree
= symtree
;
2614 e
->expr_type
= EXPR_FUNCTION
;
2616 gcc_assert (sym
->attr
.flavor
== FL_DERIVED
2617 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2618 e
->value
.function
.esym
= sym
;
2619 e
->symtree
->n
.sym
->attr
.generic
= 1;
2621 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2628 if (gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false)
2640 /* If the symbol is an implicit do loop index and implicitly typed,
2641 it should not be host associated. Provide a symtree from the
2642 current namespace. */
2644 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2646 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2647 && (*sym
)->ns
!= gfc_current_ns
2648 && (*sym
)->attr
.implied_index
2649 && (*sym
)->attr
.implicit_type
2650 && !(*sym
)->attr
.use_assoc
)
2653 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2656 *sym
= (*st
)->n
.sym
;
2662 /* Procedure pointer as function result: Replace the function symbol by the
2663 auto-generated hidden result variable named "ppr@". */
2666 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2668 /* Check for procedure pointer result variable. */
2669 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2670 && (*sym
)->result
&& (*sym
)->result
!= *sym
2671 && (*sym
)->result
->attr
.proc_pointer
2672 && (*sym
) == gfc_current_ns
->proc_name
2673 && (*sym
) == (*sym
)->result
->ns
->proc_name
2674 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2676 /* Automatic replacement with "hidden" result variable. */
2677 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2678 *sym
= (*sym
)->result
;
2679 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2686 /* Matches a variable name followed by anything that might follow it--
2687 array reference, argument list of a function, etc. */
2690 gfc_match_rvalue (gfc_expr
**result
)
2692 gfc_actual_arglist
*actual_arglist
;
2693 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2696 gfc_symtree
*symtree
;
2697 locus where
, old_loc
;
2705 m
= gfc_match_name (name
);
2709 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2710 && !gfc_current_ns
->has_import_set
)
2711 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2713 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2718 sym
= symtree
->n
.sym
;
2720 where
= gfc_current_locus
;
2722 replace_hidden_procptr_result (&sym
, &symtree
);
2724 /* If this is an implicit do loop index and implicitly typed,
2725 it should not be host associated. */
2726 m
= check_for_implicit_index (&symtree
, &sym
);
2730 gfc_set_sym_referenced (sym
);
2731 sym
->attr
.implied_index
= 0;
2733 if (sym
->attr
.function
&& sym
->result
== sym
)
2735 /* See if this is a directly recursive function call. */
2736 gfc_gobble_whitespace ();
2737 if (sym
->attr
.recursive
2738 && gfc_peek_ascii_char () == '('
2739 && gfc_current_ns
->proc_name
== sym
2740 && !sym
->attr
.dimension
)
2742 gfc_error ("'%s' at %C is the name of a recursive function "
2743 "and so refers to the result variable. Use an "
2744 "explicit RESULT variable for direct recursion "
2745 "(12.5.2.1)", sym
->name
);
2749 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2753 && (sym
->ns
== gfc_current_ns
2754 || sym
->ns
== gfc_current_ns
->parent
))
2756 gfc_entry_list
*el
= NULL
;
2758 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2764 if (gfc_matching_procptr_assignment
)
2767 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2770 if (sym
->attr
.generic
)
2771 goto generic_function
;
2773 switch (sym
->attr
.flavor
)
2777 e
= gfc_get_expr ();
2779 e
->expr_type
= EXPR_VARIABLE
;
2780 e
->symtree
= symtree
;
2782 m
= gfc_match_varspec (e
, 0, false, true);
2786 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2787 end up here. Unfortunately, sym->value->expr_type is set to
2788 EXPR_CONSTANT, and so the if () branch would be followed without
2789 the !sym->as check. */
2790 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2791 e
= gfc_copy_expr (sym
->value
);
2794 e
= gfc_get_expr ();
2795 e
->expr_type
= EXPR_VARIABLE
;
2798 e
->symtree
= symtree
;
2799 m
= gfc_match_varspec (e
, 0, false, true);
2801 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2804 /* Variable array references to derived type parameters cause
2805 all sorts of headaches in simplification. Treating such
2806 expressions as variable works just fine for all array
2808 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2810 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2811 if (ref
->type
== REF_ARRAY
)
2814 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2820 e
= gfc_get_expr ();
2821 e
->expr_type
= EXPR_VARIABLE
;
2822 e
->symtree
= symtree
;
2829 sym
= gfc_use_derived (sym
);
2833 goto generic_function
;
2836 /* If we're here, then the name is known to be the name of a
2837 procedure, yet it is not sure to be the name of a function. */
2840 /* Procedure Pointer Assignments. */
2842 if (gfc_matching_procptr_assignment
)
2844 gfc_gobble_whitespace ();
2845 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2846 /* Parse functions returning a procptr. */
2849 e
= gfc_get_expr ();
2850 e
->expr_type
= EXPR_VARIABLE
;
2851 e
->symtree
= symtree
;
2852 m
= gfc_match_varspec (e
, 0, false, true);
2853 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
2854 && sym
->ts
.type
== BT_UNKNOWN
2855 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
2856 sym
->name
, NULL
) == FAILURE
)
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
) == FAILURE
)
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
,
2979 sym
->name
, NULL
) == FAILURE
)
2985 e
= gfc_get_expr ();
2986 e
->symtree
= symtree
;
2987 e
->expr_type
= EXPR_VARIABLE
;
2988 m
= gfc_match_varspec (e
, 0, false, true);
2992 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2993 && (CLASS_DATA (sym
)->attr
.dimension
2994 || CLASS_DATA (sym
)->attr
.codimension
))
2996 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2997 sym
->name
, NULL
) == FAILURE
)
3003 e
= gfc_get_expr ();
3004 e
->symtree
= symtree
;
3005 e
->expr_type
= EXPR_VARIABLE
;
3006 m
= gfc_match_varspec (e
, 0, false, true);
3010 /* Name is not an array, so we peek to see if a '(' implies a
3011 function call or a substring reference. Otherwise the
3012 variable is just a scalar. */
3014 gfc_gobble_whitespace ();
3015 if (gfc_peek_ascii_char () != '(')
3017 /* Assume a scalar variable */
3018 e
= gfc_get_expr ();
3019 e
->symtree
= symtree
;
3020 e
->expr_type
= EXPR_VARIABLE
;
3022 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3023 sym
->name
, NULL
) == FAILURE
)
3029 /*FIXME:??? gfc_match_varspec does set this for us: */
3031 m
= gfc_match_varspec (e
, 0, false, true);
3035 /* See if this is a function reference with a keyword argument
3036 as first argument. We do this because otherwise a spurious
3037 symbol would end up in the symbol table. */
3039 old_loc
= gfc_current_locus
;
3040 m2
= gfc_match (" ( %n =", argname
);
3041 gfc_current_locus
= old_loc
;
3043 e
= gfc_get_expr ();
3044 e
->symtree
= symtree
;
3046 if (m2
!= MATCH_YES
)
3048 /* Try to figure out whether we're dealing with a character type.
3049 We're peeking ahead here, because we don't want to call
3050 match_substring if we're dealing with an implicitly typed
3051 non-character variable. */
3052 implicit_char
= false;
3053 if (sym
->ts
.type
== BT_UNKNOWN
)
3055 ts
= gfc_get_default_type (sym
->name
, NULL
);
3056 if (ts
->type
== BT_CHARACTER
)
3057 implicit_char
= true;
3060 /* See if this could possibly be a substring reference of a name
3061 that we're not sure is a variable yet. */
3063 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3064 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
3067 e
->expr_type
= EXPR_VARIABLE
;
3069 if (sym
->attr
.flavor
!= FL_VARIABLE
3070 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3071 sym
->name
, NULL
) == FAILURE
)
3077 if (sym
->ts
.type
== BT_UNKNOWN
3078 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3092 /* Give up, assume we have a function. */
3094 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3095 sym
= symtree
->n
.sym
;
3096 e
->expr_type
= EXPR_FUNCTION
;
3098 if (!sym
->attr
.function
3099 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3107 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3109 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
3117 /* If our new function returns a character, array or structure
3118 type, it might have subsequent references. */
3120 m
= gfc_match_varspec (e
, 0, false, true);
3127 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3129 e
= gfc_get_expr ();
3130 e
->symtree
= symtree
;
3131 e
->expr_type
= EXPR_FUNCTION
;
3133 if (sym
->attr
.flavor
== FL_DERIVED
)
3135 e
->value
.function
.esym
= sym
;
3136 e
->symtree
->n
.sym
->attr
.generic
= 1;
3139 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3143 gfc_error ("Symbol at %C is not appropriate for an expression");
3159 /* Match a variable, i.e. something that can be assigned to. This
3160 starts as a symbol, can be a structure component or an array
3161 reference. It can be a function if the function doesn't have a
3162 separate RESULT variable. If the symbol has not been previously
3163 seen, we assume it is a variable.
3165 This function is called by two interface functions:
3166 gfc_match_variable, which has host_flag = 1, and
3167 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3168 match of the symbol to the local scope. */
3171 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3179 /* Since nothing has any business being an lvalue in a module
3180 specification block, an interface block or a contains section,
3181 we force the changed_symbols mechanism to work by setting
3182 host_flag to 0. This prevents valid symbols that have the name
3183 of keywords, such as 'end', being turned into variables by
3184 failed matching to assignments for, e.g., END INTERFACE. */
3185 if (gfc_current_state () == COMP_MODULE
3186 || gfc_current_state () == COMP_INTERFACE
3187 || gfc_current_state () == COMP_CONTAINS
)
3190 where
= gfc_current_locus
;
3191 m
= gfc_match_sym_tree (&st
, host_flag
);
3197 /* If this is an implicit do loop index and implicitly typed,
3198 it should not be host associated. */
3199 m
= check_for_implicit_index (&st
, &sym
);
3203 sym
->attr
.implied_index
= 0;
3205 gfc_set_sym_referenced (sym
);
3206 switch (sym
->attr
.flavor
)
3209 /* Everything is alright. */
3214 sym_flavor flavor
= FL_UNKNOWN
;
3216 gfc_gobble_whitespace ();
3218 if (sym
->attr
.external
|| sym
->attr
.procedure
3219 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3220 flavor
= FL_PROCEDURE
;
3222 /* If it is not a procedure, is not typed and is host associated,
3223 we cannot give it a flavor yet. */
3224 else if (sym
->ns
== gfc_current_ns
->parent
3225 && sym
->ts
.type
== BT_UNKNOWN
)
3228 /* These are definitive indicators that this is a variable. */
3229 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3230 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3231 flavor
= FL_VARIABLE
;
3233 if (flavor
!= FL_UNKNOWN
3234 && gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
) == FAILURE
)
3242 gfc_error ("Named constant at %C in an EQUIVALENCE");
3245 /* Otherwise this is checked for and an error given in the
3246 variable definition context checks. */
3250 /* Check for a nonrecursive function result variable. */
3251 if (sym
->attr
.function
3252 && !sym
->attr
.external
3253 && sym
->result
== sym
3254 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3256 && sym
->ns
== gfc_current_ns
)
3258 && sym
->ns
== gfc_current_ns
->parent
)))
3260 /* If a function result is a derived type, then the derived
3261 type may still have to be resolved. */
3263 if (sym
->ts
.type
== BT_DERIVED
3264 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3269 if (sym
->attr
.proc_pointer
3270 || replace_hidden_procptr_result (&sym
, &st
) == SUCCESS
)
3273 /* Fall through to error */
3276 gfc_error ("'%s' at %C is not a variable", sym
->name
);
3280 /* Special case for derived type variables that get their types
3281 via an IMPLICIT statement. This can't wait for the
3282 resolution phase. */
3285 gfc_namespace
* implicit_ns
;
3287 if (gfc_current_ns
->proc_name
== sym
)
3288 implicit_ns
= gfc_current_ns
;
3290 implicit_ns
= sym
->ns
;
3292 if (gfc_peek_ascii_char () == '%'
3293 && sym
->ts
.type
== BT_UNKNOWN
3294 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3295 gfc_set_default_type (sym
, 0, implicit_ns
);
3298 expr
= gfc_get_expr ();
3300 expr
->expr_type
= EXPR_VARIABLE
;
3303 expr
->where
= where
;
3305 /* Now see if we have to do more. */
3306 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3309 gfc_free_expr (expr
);
3319 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3321 return match_variable (result
, equiv_flag
, 1);
3326 gfc_match_equiv_variable (gfc_expr
**result
)
3328 return match_variable (result
, 1, 0);