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
))
1090 gfc_error ("Character '%s' in string at %C is not representable "
1091 "in character kind %d", gfc_print_wide_char (c
), kind
);
1098 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1099 gfc_option
.warn_ampersand
= warn_ampersand
;
1101 next_string_char (delimiter
, &ret
);
1103 gfc_internal_error ("match_string_constant(): Delimiter not found");
1105 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1106 e
->expr_type
= EXPR_SUBSTRING
;
1113 gfc_current_locus
= old_locus
;
1118 /* Match a .true. or .false. Returns 1 if a .true. was found,
1119 0 if a .false. was found, and -1 otherwise. */
1121 match_logical_constant_string (void)
1123 locus orig_loc
= gfc_current_locus
;
1125 gfc_gobble_whitespace ();
1126 if (gfc_next_ascii_char () == '.')
1128 char ch
= gfc_next_ascii_char ();
1131 if (gfc_next_ascii_char () == 'a'
1132 && gfc_next_ascii_char () == 'l'
1133 && gfc_next_ascii_char () == 's'
1134 && gfc_next_ascii_char () == 'e'
1135 && gfc_next_ascii_char () == '.')
1136 /* Matched ".false.". */
1141 if (gfc_next_ascii_char () == 'r'
1142 && gfc_next_ascii_char () == 'u'
1143 && gfc_next_ascii_char () == 'e'
1144 && gfc_next_ascii_char () == '.')
1145 /* Matched ".true.". */
1149 gfc_current_locus
= orig_loc
;
1153 /* Match a .true. or .false. */
1156 match_logical_constant (gfc_expr
**result
)
1159 int i
, kind
, is_iso_c
;
1161 i
= match_logical_constant_string ();
1165 kind
= get_kind (&is_iso_c
);
1169 kind
= gfc_default_logical_kind
;
1171 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1173 gfc_error ("Bad kind for logical constant at %C");
1177 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1178 e
->ts
.is_c_interop
= is_iso_c
;
1185 /* Match a real or imaginary part of a complex constant that is a
1186 symbolic constant. */
1189 match_sym_complex_part (gfc_expr
**result
)
1191 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1196 m
= gfc_match_name (name
);
1200 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1203 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1205 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1209 if (!gfc_numeric_ts (&sym
->value
->ts
))
1211 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1215 if (sym
->value
->rank
!= 0)
1217 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1221 if (gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1222 "complex constant at %C") == FAILURE
)
1225 switch (sym
->value
->ts
.type
)
1228 e
= gfc_copy_expr (sym
->value
);
1232 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1238 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1244 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1247 *result
= e
; /* e is a scalar, real, constant expression. */
1251 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1256 /* Match a real or imaginary part of a complex number. */
1259 match_complex_part (gfc_expr
**result
)
1263 m
= match_sym_complex_part (result
);
1267 m
= match_real_constant (result
, 1);
1271 return match_integer_constant (result
, 1);
1275 /* Try to match a complex constant. */
1278 match_complex_constant (gfc_expr
**result
)
1280 gfc_expr
*e
, *real
, *imag
;
1281 gfc_error_buf old_error
;
1282 gfc_typespec target
;
1287 old_loc
= gfc_current_locus
;
1288 real
= imag
= e
= NULL
;
1290 m
= gfc_match_char ('(');
1294 gfc_push_error (&old_error
);
1296 m
= match_complex_part (&real
);
1299 gfc_free_error (&old_error
);
1303 if (gfc_match_char (',') == MATCH_NO
)
1305 gfc_pop_error (&old_error
);
1310 /* If m is error, then something was wrong with the real part and we
1311 assume we have a complex constant because we've seen the ','. An
1312 ambiguous case here is the start of an iterator list of some
1313 sort. These sort of lists are matched prior to coming here. */
1315 if (m
== MATCH_ERROR
)
1317 gfc_free_error (&old_error
);
1320 gfc_pop_error (&old_error
);
1322 m
= match_complex_part (&imag
);
1325 if (m
== MATCH_ERROR
)
1328 m
= gfc_match_char (')');
1331 /* Give the matcher for implied do-loops a chance to run. This
1332 yields a much saner error message for (/ (i, 4=i, 6) /). */
1333 if (gfc_peek_ascii_char () == '=')
1342 if (m
== MATCH_ERROR
)
1345 /* Decide on the kind of this complex number. */
1346 if (real
->ts
.type
== BT_REAL
)
1348 if (imag
->ts
.type
== BT_REAL
)
1349 kind
= gfc_kind_max (real
, imag
);
1351 kind
= real
->ts
.kind
;
1355 if (imag
->ts
.type
== BT_REAL
)
1356 kind
= imag
->ts
.kind
;
1358 kind
= gfc_default_real_kind
;
1360 gfc_clear_ts (&target
);
1361 target
.type
= BT_REAL
;
1364 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1365 gfc_convert_type (real
, &target
, 2);
1366 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1367 gfc_convert_type (imag
, &target
, 2);
1369 e
= gfc_convert_complex (real
, imag
, kind
);
1370 e
->where
= gfc_current_locus
;
1372 gfc_free_expr (real
);
1373 gfc_free_expr (imag
);
1379 gfc_error ("Syntax error in COMPLEX constant at %C");
1384 gfc_free_expr (real
);
1385 gfc_free_expr (imag
);
1386 gfc_current_locus
= old_loc
;
1392 /* Match constants in any of several forms. Returns nonzero for a
1393 match, zero for no match. */
1396 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1400 m
= match_complex_constant (result
);
1404 m
= match_string_constant (result
);
1408 m
= match_boz_constant (result
);
1412 m
= match_real_constant (result
, signflag
);
1416 m
= match_hollerith_constant (result
);
1420 m
= match_integer_constant (result
, signflag
);
1424 m
= match_logical_constant (result
);
1432 /* This checks if a symbol is the return value of an encompassing function.
1433 Function nesting can be maximally two levels deep, but we may have
1434 additional local namespaces like BLOCK etc. */
1437 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1439 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1443 if (ns
->proc_name
== sym
)
1451 /* Match a single actual argument value. An actual argument is
1452 usually an expression, but can also be a procedure name. If the
1453 argument is a single name, it is not always possible to tell
1454 whether the name is a dummy procedure or not. We treat these cases
1455 by creating an argument that looks like a dummy procedure and
1456 fixing things later during resolution. */
1459 match_actual_arg (gfc_expr
**result
)
1461 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1462 gfc_symtree
*symtree
;
1467 gfc_gobble_whitespace ();
1468 where
= gfc_current_locus
;
1470 switch (gfc_match_name (name
))
1479 w
= gfc_current_locus
;
1480 gfc_gobble_whitespace ();
1481 c
= gfc_next_ascii_char ();
1482 gfc_current_locus
= w
;
1484 if (c
!= ',' && c
!= ')')
1487 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1489 /* Handle error elsewhere. */
1491 /* Eliminate a couple of common cases where we know we don't
1492 have a function argument. */
1493 if (symtree
== NULL
)
1495 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1496 gfc_set_sym_referenced (symtree
->n
.sym
);
1502 sym
= symtree
->n
.sym
;
1503 gfc_set_sym_referenced (sym
);
1504 if (sym
->attr
.flavor
!= FL_PROCEDURE
1505 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1508 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1510 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
,
1515 /* If the symbol is a function with itself as the result and
1516 is being defined, then we have a variable. */
1517 if (sym
->attr
.function
&& sym
->result
== sym
)
1519 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1523 && (sym
->ns
== gfc_current_ns
1524 || sym
->ns
== gfc_current_ns
->parent
))
1526 gfc_entry_list
*el
= NULL
;
1528 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1538 e
= gfc_get_expr (); /* Leave it unknown for now */
1539 e
->symtree
= symtree
;
1540 e
->expr_type
= EXPR_VARIABLE
;
1541 e
->ts
.type
= BT_PROCEDURE
;
1548 gfc_current_locus
= where
;
1549 return gfc_match_expr (result
);
1553 /* Match a keyword argument. */
1556 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1558 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1559 gfc_actual_arglist
*a
;
1563 name_locus
= gfc_current_locus
;
1564 m
= gfc_match_name (name
);
1568 if (gfc_match_char ('=') != MATCH_YES
)
1574 m
= match_actual_arg (&actual
->expr
);
1578 /* Make sure this name has not appeared yet. */
1580 if (name
[0] != '\0')
1582 for (a
= base
; a
; a
= a
->next
)
1583 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1585 gfc_error ("Keyword '%s' at %C has already appeared in the "
1586 "current argument list", name
);
1591 actual
->name
= gfc_get_string (name
);
1595 gfc_current_locus
= name_locus
;
1600 /* Match an argument list function, such as %VAL. */
1603 match_arg_list_function (gfc_actual_arglist
*result
)
1605 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1609 old_locus
= gfc_current_locus
;
1611 if (gfc_match_char ('%') != MATCH_YES
)
1617 m
= gfc_match ("%n (", name
);
1621 if (name
[0] != '\0')
1626 if (strncmp (name
, "loc", 3) == 0)
1628 result
->name
= "%LOC";
1632 if (strncmp (name
, "ref", 3) == 0)
1634 result
->name
= "%REF";
1638 if (strncmp (name
, "val", 3) == 0)
1640 result
->name
= "%VAL";
1649 if (gfc_notify_std (GFC_STD_GNU
, "argument list "
1650 "function at %C") == FAILURE
)
1656 m
= match_actual_arg (&result
->expr
);
1660 if (gfc_match_char (')') != MATCH_YES
)
1669 gfc_current_locus
= old_locus
;
1674 /* Matches an actual argument list of a function or subroutine, from
1675 the opening parenthesis to the closing parenthesis. The argument
1676 list is assumed to allow keyword arguments because we don't know if
1677 the symbol associated with the procedure has an implicit interface
1678 or not. We make sure keywords are unique. If sub_flag is set,
1679 we're matching the argument list of a subroutine. */
1682 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1684 gfc_actual_arglist
*head
, *tail
;
1686 gfc_st_label
*label
;
1690 *argp
= tail
= NULL
;
1691 old_loc
= gfc_current_locus
;
1695 if (gfc_match_char ('(') == MATCH_NO
)
1696 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1698 if (gfc_match_char (')') == MATCH_YES
)
1702 matching_actual_arglist
++;
1707 head
= tail
= gfc_get_actual_arglist ();
1710 tail
->next
= gfc_get_actual_arglist ();
1714 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1716 m
= gfc_match_st_label (&label
);
1718 gfc_error ("Expected alternate return label at %C");
1722 tail
->label
= label
;
1726 /* After the first keyword argument is seen, the following
1727 arguments must also have keywords. */
1730 m
= match_keyword_arg (tail
, head
);
1732 if (m
== MATCH_ERROR
)
1736 gfc_error ("Missing keyword name in actual argument list at %C");
1743 /* Try an argument list function, like %VAL. */
1744 m
= match_arg_list_function (tail
);
1745 if (m
== MATCH_ERROR
)
1748 /* See if we have the first keyword argument. */
1751 m
= match_keyword_arg (tail
, head
);
1754 if (m
== MATCH_ERROR
)
1760 /* Try for a non-keyword argument. */
1761 m
= match_actual_arg (&tail
->expr
);
1762 if (m
== MATCH_ERROR
)
1771 if (gfc_match_char (')') == MATCH_YES
)
1773 if (gfc_match_char (',') != MATCH_YES
)
1778 matching_actual_arglist
--;
1782 gfc_error ("Syntax error in argument list at %C");
1785 gfc_free_actual_arglist (head
);
1786 gfc_current_locus
= old_loc
;
1787 matching_actual_arglist
--;
1792 /* Used by gfc_match_varspec() to extend the reference list by one
1796 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1798 if (primary
->ref
== NULL
)
1799 primary
->ref
= tail
= gfc_get_ref ();
1803 gfc_internal_error ("extend_ref(): Bad tail");
1804 tail
->next
= gfc_get_ref ();
1812 /* Match any additional specifications associated with the current
1813 variable like member references or substrings. If equiv_flag is
1814 set we only match stuff that is allowed inside an EQUIVALENCE
1815 statement. sub_flag tells whether we expect a type-bound procedure found
1816 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1817 components, 'ppc_arg' determines whether the PPC may be called (with an
1818 argument list), or whether it may just be referred to as a pointer. */
1821 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1824 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1825 gfc_ref
*substring
, *tail
;
1826 gfc_component
*component
;
1827 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1833 gfc_gobble_whitespace ();
1835 if (gfc_peek_ascii_char () == '[')
1837 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1838 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1839 && CLASS_DATA (sym
)->attr
.dimension
))
1841 gfc_error ("Array section designator, e.g. '(:)', is required "
1842 "besides the coarray designator '[...]' at %C");
1845 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1846 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1847 && !CLASS_DATA (sym
)->attr
.codimension
))
1849 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1855 /* For associate names, we may not yet know whether they are arrays or not.
1856 Thus if we have one and parentheses follow, we have to assume that it
1857 actually is one for now. The final decision will be made at
1858 resolution time, of course. */
1859 if (sym
->assoc
&& gfc_peek_ascii_char () == '(')
1860 sym
->attr
.dimension
= 1;
1862 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1863 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1864 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1865 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1866 && !(gfc_matching_procptr_assignment
1867 && sym
->attr
.flavor
== FL_PROCEDURE
))
1868 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1869 && (CLASS_DATA (sym
)->attr
.dimension
1870 || CLASS_DATA (sym
)->attr
.codimension
)))
1874 tail
= extend_ref (primary
, tail
);
1875 tail
->type
= REF_ARRAY
;
1877 /* In EQUIVALENCE, we don't know yet whether we are seeing
1878 an array, character variable or array of character
1879 variables. We'll leave the decision till resolve time. */
1883 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1884 as
= CLASS_DATA (sym
)->as
;
1888 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1889 as
? as
->corank
: 0);
1893 gfc_gobble_whitespace ();
1894 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1896 tail
= extend_ref (primary
, tail
);
1897 tail
->type
= REF_ARRAY
;
1899 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1905 primary
->ts
= sym
->ts
;
1910 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1911 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1912 gfc_set_default_type (sym
, 0, sym
->ns
);
1914 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_match_char ('%') == MATCH_YES
)
1916 gfc_error ("Symbol '%s' at %C has no IMPLICIT type", sym
->name
);
1919 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1920 && gfc_match_char ('%') == MATCH_YES
)
1922 gfc_error ("Unexpected '%%' for nonderived-type variable '%s' at %C",
1927 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1928 || gfc_match_char ('%') != MATCH_YES
)
1929 goto check_substring
;
1931 sym
= sym
->ts
.u
.derived
;
1938 m
= gfc_match_name (name
);
1940 gfc_error ("Expected structure component name at %C");
1944 if (sym
->f2k_derived
)
1945 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1951 gfc_symbol
* tbp_sym
;
1956 gcc_assert (!tail
|| !tail
->next
);
1957 gcc_assert (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
));
1962 if (tbp
->n
.tb
->is_generic
)
1965 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1967 primary
->expr_type
= EXPR_COMPCALL
;
1968 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1969 primary
->value
.compcall
.name
= tbp
->name
;
1970 primary
->value
.compcall
.ignore_pass
= 0;
1971 primary
->value
.compcall
.assign
= 0;
1972 primary
->value
.compcall
.base_object
= NULL
;
1973 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1975 primary
->ts
= tbp_sym
->ts
;
1977 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1978 &primary
->value
.compcall
.actual
);
1979 if (m
== MATCH_ERROR
)
1984 primary
->value
.compcall
.actual
= NULL
;
1987 gfc_error ("Expected argument list at %C");
1995 component
= gfc_find_component (sym
, name
, false, false);
1996 if (component
== NULL
)
1999 tail
= extend_ref (primary
, tail
);
2000 tail
->type
= REF_COMPONENT
;
2002 tail
->u
.c
.component
= component
;
2003 tail
->u
.c
.sym
= sym
;
2005 primary
->ts
= component
->ts
;
2007 if (component
->attr
.proc_pointer
&& ppc_arg
)
2009 /* Procedure pointer component call: Look for argument list. */
2010 m
= gfc_match_actual_arglist (sub_flag
,
2011 &primary
->value
.compcall
.actual
);
2012 if (m
== MATCH_ERROR
)
2015 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2016 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2018 gfc_error ("Procedure pointer component '%s' requires an "
2019 "argument list at %C", component
->name
);
2024 primary
->expr_type
= EXPR_PPC
;
2029 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2031 tail
= extend_ref (primary
, tail
);
2032 tail
->type
= REF_ARRAY
;
2034 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2035 component
->as
->corank
);
2039 else if (component
->ts
.type
== BT_CLASS
2040 && CLASS_DATA (component
)->as
!= NULL
2041 && !component
->attr
.proc_pointer
)
2043 tail
= extend_ref (primary
, tail
);
2044 tail
->type
= REF_ARRAY
;
2046 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2048 CLASS_DATA (component
)->as
->corank
);
2053 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2054 || gfc_match_char ('%') != MATCH_YES
)
2057 sym
= component
->ts
.u
.derived
;
2062 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
2064 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2066 gfc_set_default_type (sym
, 0, sym
->ns
);
2067 primary
->ts
= sym
->ts
;
2072 if (primary
->ts
.type
== BT_CHARACTER
)
2074 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
2078 primary
->ref
= substring
;
2080 tail
->next
= substring
;
2082 if (primary
->expr_type
== EXPR_CONSTANT
)
2083 primary
->expr_type
= EXPR_SUBSTRING
;
2086 primary
->ts
.u
.cl
= NULL
;
2093 gfc_clear_ts (&primary
->ts
);
2094 gfc_clear_ts (&sym
->ts
);
2104 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2106 gfc_error ("Coindexed procedure-pointer component at %C");
2114 /* Given an expression that is a variable, figure out what the
2115 ultimate variable's type and attribute is, traversing the reference
2116 structures if necessary.
2118 This subroutine is trickier than it looks. We start at the base
2119 symbol and store the attribute. Component references load a
2120 completely new attribute.
2122 A couple of rules come into play. Subobjects of targets are always
2123 targets themselves. If we see a component that goes through a
2124 pointer, then the expression must also be a target, since the
2125 pointer is associated with something (if it isn't core will soon be
2126 dumped). If we see a full part or section of an array, the
2127 expression is also an array.
2129 We can have at most one full array reference. */
2132 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2134 int dimension
, pointer
, allocatable
, target
;
2135 symbol_attribute attr
;
2138 gfc_component
*comp
;
2140 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2141 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2143 sym
= expr
->symtree
->n
.sym
;
2146 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2148 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2149 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2150 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2154 dimension
= attr
.dimension
;
2155 pointer
= attr
.pointer
;
2156 allocatable
= attr
.allocatable
;
2159 target
= attr
.target
;
2160 if (pointer
|| attr
.proc_pointer
)
2163 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2166 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2171 switch (ref
->u
.ar
.type
)
2178 allocatable
= pointer
= 0;
2183 /* Handle coarrays. */
2184 if (ref
->u
.ar
.dimen
> 0)
2185 allocatable
= pointer
= 0;
2189 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2195 comp
= ref
->u
.c
.component
;
2200 /* Don't set the string length if a substring reference
2202 if (ts
->type
== BT_CHARACTER
2203 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2207 if (comp
->ts
.type
== BT_CLASS
)
2209 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2210 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2214 pointer
= comp
->attr
.pointer
;
2215 allocatable
= comp
->attr
.allocatable
;
2217 if (pointer
|| attr
.proc_pointer
)
2223 allocatable
= pointer
= 0;
2227 attr
.dimension
= dimension
;
2228 attr
.pointer
= pointer
;
2229 attr
.allocatable
= allocatable
;
2230 attr
.target
= target
;
2231 attr
.save
= sym
->attr
.save
;
2237 /* Return the attribute from a general expression. */
2240 gfc_expr_attr (gfc_expr
*e
)
2242 symbol_attribute attr
;
2244 switch (e
->expr_type
)
2247 attr
= gfc_variable_attr (e
, NULL
);
2251 gfc_clear_attr (&attr
);
2253 if (e
->value
.function
.esym
!= NULL
)
2255 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2257 if (sym
->ts
.type
== BT_CLASS
)
2259 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2260 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2261 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2265 attr
= gfc_variable_attr (e
, NULL
);
2267 /* TODO: NULL() returns pointers. May have to take care of this
2273 gfc_clear_attr (&attr
);
2281 /* Match a structure constructor. The initial symbol has already been
2284 typedef struct gfc_structure_ctor_component
2289 struct gfc_structure_ctor_component
* next
;
2291 gfc_structure_ctor_component
;
2293 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2296 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2299 gfc_free_expr (comp
->val
);
2304 /* Translate the component list into the actual constructor by sorting it in
2305 the order required; this also checks along the way that each and every
2306 component actually has an initializer and handles default initializers
2307 for components without explicit value given. */
2309 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2310 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2312 gfc_structure_ctor_component
*comp_iter
;
2313 gfc_component
*comp
;
2315 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2317 gfc_structure_ctor_component
**next_ptr
;
2318 gfc_expr
*value
= NULL
;
2320 /* Try to find the initializer for the current component by name. */
2321 next_ptr
= comp_head
;
2322 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2324 if (!strcmp (comp_iter
->name
, comp
->name
))
2326 next_ptr
= &comp_iter
->next
;
2329 /* If an extension, try building the parent derived type by building
2330 a value expression for the parent derived type and calling self. */
2331 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2333 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2335 &gfc_current_locus
);
2336 value
->ts
= comp
->ts
;
2338 if (build_actual_constructor (comp_head
, &value
->value
.constructor
,
2339 comp
->ts
.u
.derived
) == FAILURE
)
2341 gfc_free_expr (value
);
2345 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2349 /* If it was not found, try the default initializer if there's any;
2350 otherwise, it's an error. */
2353 if (comp
->initializer
)
2355 if (gfc_notify_std (GFC_STD_F2003
, "Structure"
2356 " constructor with missing optional arguments"
2357 " at %C") == FAILURE
)
2359 value
= gfc_copy_expr (comp
->initializer
);
2363 gfc_error ("No initializer for component '%s' given in the"
2364 " structure constructor at %C!", comp
->name
);
2369 value
= comp_iter
->val
;
2371 /* Add the value to the constructor chain built. */
2372 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2374 /* Remove the entry from the component list. We don't want the expression
2375 value to be free'd, so set it to NULL. */
2378 *next_ptr
= comp_iter
->next
;
2379 comp_iter
->val
= NULL
;
2380 gfc_free_structure_ctor_component (comp_iter
);
2388 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2389 gfc_actual_arglist
**arglist
,
2392 gfc_actual_arglist
*actual
;
2393 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2394 gfc_constructor_base ctor_head
= NULL
;
2395 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2396 const char* last_name
= NULL
;
2400 expr
= parent
? *cexpr
: e
;
2401 old_locus
= gfc_current_locus
;
2403 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2405 gfc_current_locus
= expr
->where
;
2407 comp_tail
= comp_head
= NULL
;
2409 if (!parent
&& sym
->attr
.abstract
)
2411 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2412 sym
->name
, &expr
->where
);
2416 comp
= sym
->components
;
2417 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2420 gfc_component
*this_comp
= NULL
;
2423 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2426 comp_tail
->next
= gfc_get_structure_ctor_component ();
2427 comp_tail
= comp_tail
->next
;
2431 if (gfc_notify_std (GFC_STD_F2003
, "Structure"
2432 " constructor with named arguments at %C")
2436 comp_tail
->name
= xstrdup (actual
->name
);
2437 last_name
= comp_tail
->name
;
2442 /* Components without name are not allowed after the first named
2443 component initializer! */
2447 gfc_error ("Component initializer without name after component"
2448 " named %s at %L!", last_name
,
2449 actual
->expr
? &actual
->expr
->where
2450 : &gfc_current_locus
);
2452 gfc_error ("Too many components in structure constructor at "
2453 "%L!", actual
->expr
? &actual
->expr
->where
2454 : &gfc_current_locus
);
2458 comp_tail
->name
= xstrdup (comp
->name
);
2461 /* Find the current component in the structure definition and check
2462 its access is not private. */
2464 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2467 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2469 comp
= NULL
; /* Reset needed! */
2472 /* Here we can check if a component name is given which does not
2473 correspond to any component of the defined structure. */
2477 comp_tail
->val
= actual
->expr
;
2478 if (actual
->expr
!= NULL
)
2479 comp_tail
->where
= actual
->expr
->where
;
2480 actual
->expr
= NULL
;
2482 /* Check if this component is already given a value. */
2483 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2484 comp_iter
= comp_iter
->next
)
2486 gcc_assert (comp_iter
);
2487 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2489 gfc_error ("Component '%s' is initialized twice in the structure"
2490 " constructor at %L!", comp_tail
->name
,
2491 comp_tail
->val
? &comp_tail
->where
2492 : &gfc_current_locus
);
2497 /* F2008, R457/C725, for PURE C1283. */
2498 if (this_comp
->attr
.pointer
&& comp_tail
->val
2499 && gfc_is_coindexed (comp_tail
->val
))
2501 gfc_error ("Coindexed expression to pointer component '%s' in "
2502 "structure constructor at %L!", comp_tail
->name
,
2507 /* If not explicitly a parent constructor, gather up the components
2509 if (comp
&& comp
== sym
->components
2510 && sym
->attr
.extension
2512 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2514 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2517 gfc_actual_arglist
*arg_null
= NULL
;
2519 actual
->expr
= comp_tail
->val
;
2520 comp_tail
->val
= NULL
;
2522 m
= gfc_convert_to_structure_constructor (NULL
,
2523 comp
->ts
.u
.derived
, &comp_tail
->val
,
2524 comp
->ts
.u
.derived
->attr
.zero_comp
2525 ? &arg_null
: &actual
, true);
2529 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2538 if (parent
&& !comp
)
2541 actual
= actual
->next
;
2544 if (build_actual_constructor (&comp_head
, &ctor_head
, sym
) == FAILURE
)
2547 /* No component should be left, as this should have caused an error in the
2548 loop constructing the component-list (name that does not correspond to any
2549 component in the structure definition). */
2550 if (comp_head
&& sym
->attr
.extension
)
2552 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2554 gfc_error ("component '%s' at %L has already been set by a "
2555 "parent derived type constructor", comp_iter
->name
,
2561 gcc_assert (!comp_head
);
2565 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2566 expr
->ts
.u
.derived
= sym
;
2567 expr
->value
.constructor
= ctor_head
;
2572 expr
->ts
.u
.derived
= sym
;
2574 expr
->ts
.type
= BT_DERIVED
;
2575 expr
->value
.constructor
= ctor_head
;
2576 expr
->expr_type
= EXPR_STRUCTURE
;
2579 gfc_current_locus
= old_locus
;
2585 gfc_current_locus
= old_locus
;
2587 for (comp_iter
= comp_head
; comp_iter
; )
2589 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2590 gfc_free_structure_ctor_component (comp_iter
);
2593 gfc_constructor_free (ctor_head
);
2600 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2604 gfc_symtree
*symtree
;
2606 gfc_get_sym_tree (sym
->name
, NULL
, &symtree
, false); /* Can't fail */
2608 e
= gfc_get_expr ();
2609 e
->symtree
= symtree
;
2610 e
->expr_type
= EXPR_FUNCTION
;
2612 gcc_assert (sym
->attr
.flavor
== FL_DERIVED
2613 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2614 e
->value
.function
.esym
= sym
;
2615 e
->symtree
->n
.sym
->attr
.generic
= 1;
2617 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2624 if (gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false)
2636 /* If the symbol is an implicit do loop index and implicitly typed,
2637 it should not be host associated. Provide a symtree from the
2638 current namespace. */
2640 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2642 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2643 && (*sym
)->ns
!= gfc_current_ns
2644 && (*sym
)->attr
.implied_index
2645 && (*sym
)->attr
.implicit_type
2646 && !(*sym
)->attr
.use_assoc
)
2649 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2652 *sym
= (*st
)->n
.sym
;
2658 /* Procedure pointer as function result: Replace the function symbol by the
2659 auto-generated hidden result variable named "ppr@". */
2662 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2664 /* Check for procedure pointer result variable. */
2665 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2666 && (*sym
)->result
&& (*sym
)->result
!= *sym
2667 && (*sym
)->result
->attr
.proc_pointer
2668 && (*sym
) == gfc_current_ns
->proc_name
2669 && (*sym
) == (*sym
)->result
->ns
->proc_name
2670 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2672 /* Automatic replacement with "hidden" result variable. */
2673 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2674 *sym
= (*sym
)->result
;
2675 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2682 /* Matches a variable name followed by anything that might follow it--
2683 array reference, argument list of a function, etc. */
2686 gfc_match_rvalue (gfc_expr
**result
)
2688 gfc_actual_arglist
*actual_arglist
;
2689 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2692 gfc_symtree
*symtree
;
2693 locus where
, old_loc
;
2701 m
= gfc_match_name (name
);
2705 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2706 && !gfc_current_ns
->has_import_set
)
2707 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2709 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2714 sym
= symtree
->n
.sym
;
2716 where
= gfc_current_locus
;
2718 replace_hidden_procptr_result (&sym
, &symtree
);
2720 /* If this is an implicit do loop index and implicitly typed,
2721 it should not be host associated. */
2722 m
= check_for_implicit_index (&symtree
, &sym
);
2726 gfc_set_sym_referenced (sym
);
2727 sym
->attr
.implied_index
= 0;
2729 if (sym
->attr
.function
&& sym
->result
== sym
)
2731 /* See if this is a directly recursive function call. */
2732 gfc_gobble_whitespace ();
2733 if (sym
->attr
.recursive
2734 && gfc_peek_ascii_char () == '('
2735 && gfc_current_ns
->proc_name
== sym
2736 && !sym
->attr
.dimension
)
2738 gfc_error ("'%s' at %C is the name of a recursive function "
2739 "and so refers to the result variable. Use an "
2740 "explicit RESULT variable for direct recursion "
2741 "(12.5.2.1)", sym
->name
);
2745 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2749 && (sym
->ns
== gfc_current_ns
2750 || sym
->ns
== gfc_current_ns
->parent
))
2752 gfc_entry_list
*el
= NULL
;
2754 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2760 if (gfc_matching_procptr_assignment
)
2763 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2766 if (sym
->attr
.generic
)
2767 goto generic_function
;
2769 switch (sym
->attr
.flavor
)
2773 e
= gfc_get_expr ();
2775 e
->expr_type
= EXPR_VARIABLE
;
2776 e
->symtree
= symtree
;
2778 m
= gfc_match_varspec (e
, 0, false, true);
2782 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2783 end up here. Unfortunately, sym->value->expr_type is set to
2784 EXPR_CONSTANT, and so the if () branch would be followed without
2785 the !sym->as check. */
2786 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2787 e
= gfc_copy_expr (sym
->value
);
2790 e
= gfc_get_expr ();
2791 e
->expr_type
= EXPR_VARIABLE
;
2794 e
->symtree
= symtree
;
2795 m
= gfc_match_varspec (e
, 0, false, true);
2797 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2800 /* Variable array references to derived type parameters cause
2801 all sorts of headaches in simplification. Treating such
2802 expressions as variable works just fine for all array
2804 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2806 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2807 if (ref
->type
== REF_ARRAY
)
2810 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2816 e
= gfc_get_expr ();
2817 e
->expr_type
= EXPR_VARIABLE
;
2818 e
->symtree
= symtree
;
2825 sym
= gfc_use_derived (sym
);
2829 goto generic_function
;
2832 /* If we're here, then the name is known to be the name of a
2833 procedure, yet it is not sure to be the name of a function. */
2836 /* Procedure Pointer Assignments. */
2838 if (gfc_matching_procptr_assignment
)
2840 gfc_gobble_whitespace ();
2841 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2842 /* Parse functions returning a procptr. */
2845 e
= gfc_get_expr ();
2846 e
->expr_type
= EXPR_VARIABLE
;
2847 e
->symtree
= symtree
;
2848 m
= gfc_match_varspec (e
, 0, false, true);
2849 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
2850 && sym
->ts
.type
== BT_UNKNOWN
2851 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
2852 sym
->name
, NULL
) == FAILURE
)
2860 if (sym
->attr
.subroutine
)
2862 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2868 /* At this point, the name has to be a non-statement function.
2869 If the name is the same as the current function being
2870 compiled, then we have a variable reference (to the function
2871 result) if the name is non-recursive. */
2873 st
= gfc_enclosing_unit (NULL
);
2875 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2877 && !sym
->attr
.recursive
)
2879 e
= gfc_get_expr ();
2880 e
->symtree
= symtree
;
2881 e
->expr_type
= EXPR_VARIABLE
;
2883 m
= gfc_match_varspec (e
, 0, false, true);
2887 /* Match a function reference. */
2889 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2892 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2893 gfc_error ("Statement function '%s' requires argument list at %C",
2896 gfc_error ("Function '%s' requires an argument list at %C",
2909 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2910 sym
= symtree
->n
.sym
;
2912 replace_hidden_procptr_result (&sym
, &symtree
);
2914 e
= gfc_get_expr ();
2915 e
->symtree
= symtree
;
2916 e
->expr_type
= EXPR_FUNCTION
;
2917 e
->value
.function
.actual
= actual_arglist
;
2918 e
->where
= gfc_current_locus
;
2920 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2921 && CLASS_DATA (sym
)->as
)
2922 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
2923 else if (sym
->as
!= NULL
)
2924 e
->rank
= sym
->as
->rank
;
2926 if (!sym
->attr
.function
2927 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2933 /* Check here for the existence of at least one argument for the
2934 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2935 argument(s) given will be checked in gfc_iso_c_func_interface,
2936 during resolution of the function call. */
2937 if (sym
->attr
.is_iso_c
== 1
2938 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2939 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2940 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2941 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2943 /* make sure we were given a param */
2944 if (actual_arglist
== NULL
)
2946 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2952 if (sym
->result
== NULL
)
2960 /* Special case for derived type variables that get their types
2961 via an IMPLICIT statement. This can't wait for the
2962 resolution phase. */
2964 if (gfc_peek_ascii_char () == '%'
2965 && sym
->ts
.type
== BT_UNKNOWN
2966 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2967 gfc_set_default_type (sym
, 0, sym
->ns
);
2969 /* If the symbol has a (co)dimension attribute, the expression is a
2972 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2974 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2975 sym
->name
, NULL
) == FAILURE
)
2981 e
= gfc_get_expr ();
2982 e
->symtree
= symtree
;
2983 e
->expr_type
= EXPR_VARIABLE
;
2984 m
= gfc_match_varspec (e
, 0, false, true);
2988 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2989 && (CLASS_DATA (sym
)->attr
.dimension
2990 || CLASS_DATA (sym
)->attr
.codimension
))
2992 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2993 sym
->name
, NULL
) == FAILURE
)
2999 e
= gfc_get_expr ();
3000 e
->symtree
= symtree
;
3001 e
->expr_type
= EXPR_VARIABLE
;
3002 m
= gfc_match_varspec (e
, 0, false, true);
3006 /* Name is not an array, so we peek to see if a '(' implies a
3007 function call or a substring reference. Otherwise the
3008 variable is just a scalar. */
3010 gfc_gobble_whitespace ();
3011 if (gfc_peek_ascii_char () != '(')
3013 /* Assume a scalar variable */
3014 e
= gfc_get_expr ();
3015 e
->symtree
= symtree
;
3016 e
->expr_type
= EXPR_VARIABLE
;
3018 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3019 sym
->name
, NULL
) == FAILURE
)
3025 /*FIXME:??? gfc_match_varspec does set this for us: */
3027 m
= gfc_match_varspec (e
, 0, false, true);
3031 /* See if this is a function reference with a keyword argument
3032 as first argument. We do this because otherwise a spurious
3033 symbol would end up in the symbol table. */
3035 old_loc
= gfc_current_locus
;
3036 m2
= gfc_match (" ( %n =", argname
);
3037 gfc_current_locus
= old_loc
;
3039 e
= gfc_get_expr ();
3040 e
->symtree
= symtree
;
3042 if (m2
!= MATCH_YES
)
3044 /* Try to figure out whether we're dealing with a character type.
3045 We're peeking ahead here, because we don't want to call
3046 match_substring if we're dealing with an implicitly typed
3047 non-character variable. */
3048 implicit_char
= false;
3049 if (sym
->ts
.type
== BT_UNKNOWN
)
3051 ts
= gfc_get_default_type (sym
->name
, NULL
);
3052 if (ts
->type
== BT_CHARACTER
)
3053 implicit_char
= true;
3056 /* See if this could possibly be a substring reference of a name
3057 that we're not sure is a variable yet. */
3059 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3060 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
3063 e
->expr_type
= EXPR_VARIABLE
;
3065 if (sym
->attr
.flavor
!= FL_VARIABLE
3066 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3067 sym
->name
, NULL
) == FAILURE
)
3073 if (sym
->ts
.type
== BT_UNKNOWN
3074 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3088 /* Give up, assume we have a function. */
3090 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3091 sym
= symtree
->n
.sym
;
3092 e
->expr_type
= EXPR_FUNCTION
;
3094 if (!sym
->attr
.function
3095 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3103 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3105 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
3113 /* If our new function returns a character, array or structure
3114 type, it might have subsequent references. */
3116 m
= gfc_match_varspec (e
, 0, false, true);
3123 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3125 e
= gfc_get_expr ();
3126 e
->symtree
= symtree
;
3127 e
->expr_type
= EXPR_FUNCTION
;
3129 if (sym
->attr
.flavor
== FL_DERIVED
)
3131 e
->value
.function
.esym
= sym
;
3132 e
->symtree
->n
.sym
->attr
.generic
= 1;
3135 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3139 gfc_error ("Symbol at %C is not appropriate for an expression");
3155 /* Match a variable, i.e. something that can be assigned to. This
3156 starts as a symbol, can be a structure component or an array
3157 reference. It can be a function if the function doesn't have a
3158 separate RESULT variable. If the symbol has not been previously
3159 seen, we assume it is a variable.
3161 This function is called by two interface functions:
3162 gfc_match_variable, which has host_flag = 1, and
3163 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3164 match of the symbol to the local scope. */
3167 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3175 /* Since nothing has any business being an lvalue in a module
3176 specification block, an interface block or a contains section,
3177 we force the changed_symbols mechanism to work by setting
3178 host_flag to 0. This prevents valid symbols that have the name
3179 of keywords, such as 'end', being turned into variables by
3180 failed matching to assignments for, e.g., END INTERFACE. */
3181 if (gfc_current_state () == COMP_MODULE
3182 || gfc_current_state () == COMP_INTERFACE
3183 || gfc_current_state () == COMP_CONTAINS
)
3186 where
= gfc_current_locus
;
3187 m
= gfc_match_sym_tree (&st
, host_flag
);
3193 /* If this is an implicit do loop index and implicitly typed,
3194 it should not be host associated. */
3195 m
= check_for_implicit_index (&st
, &sym
);
3199 sym
->attr
.implied_index
= 0;
3201 gfc_set_sym_referenced (sym
);
3202 switch (sym
->attr
.flavor
)
3205 /* Everything is alright. */
3210 sym_flavor flavor
= FL_UNKNOWN
;
3212 gfc_gobble_whitespace ();
3214 if (sym
->attr
.external
|| sym
->attr
.procedure
3215 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3216 flavor
= FL_PROCEDURE
;
3218 /* If it is not a procedure, is not typed and is host associated,
3219 we cannot give it a flavor yet. */
3220 else if (sym
->ns
== gfc_current_ns
->parent
3221 && sym
->ts
.type
== BT_UNKNOWN
)
3224 /* These are definitive indicators that this is a variable. */
3225 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3226 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3227 flavor
= FL_VARIABLE
;
3229 if (flavor
!= FL_UNKNOWN
3230 && gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
) == FAILURE
)
3238 gfc_error ("Named constant at %C in an EQUIVALENCE");
3241 /* Otherwise this is checked for and an error given in the
3242 variable definition context checks. */
3246 /* Check for a nonrecursive function result variable. */
3247 if (sym
->attr
.function
3248 && !sym
->attr
.external
3249 && sym
->result
== sym
3250 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3252 && sym
->ns
== gfc_current_ns
)
3254 && sym
->ns
== gfc_current_ns
->parent
)))
3256 /* If a function result is a derived type, then the derived
3257 type may still have to be resolved. */
3259 if (sym
->ts
.type
== BT_DERIVED
3260 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3265 if (sym
->attr
.proc_pointer
3266 || replace_hidden_procptr_result (&sym
, &st
) == SUCCESS
)
3269 /* Fall through to error */
3272 gfc_error ("'%s' at %C is not a variable", sym
->name
);
3276 /* Special case for derived type variables that get their types
3277 via an IMPLICIT statement. This can't wait for the
3278 resolution phase. */
3281 gfc_namespace
* implicit_ns
;
3283 if (gfc_current_ns
->proc_name
== sym
)
3284 implicit_ns
= gfc_current_ns
;
3286 implicit_ns
= sym
->ns
;
3288 if (gfc_peek_ascii_char () == '%'
3289 && sym
->ts
.type
== BT_UNKNOWN
3290 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3291 gfc_set_default_type (sym
, 0, implicit_ns
);
3294 expr
= gfc_get_expr ();
3296 expr
->expr_type
= EXPR_VARIABLE
;
3299 expr
->where
= where
;
3301 /* Now see if we have to do more. */
3302 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3305 gfc_free_expr (expr
);
3315 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3317 return match_variable (result
, equiv_flag
, 1);
3322 gfc_match_equiv_variable (gfc_expr
**result
)
3324 return match_variable (result
, 1, 0);