1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
30 /* Matches a kind-parameter expression, which is either a named
31 symbolic constant or a nonnegative integer constant. If
32 successful, sets the kind value to the correct integer. */
35 match_kind_param (int *kind
)
37 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
42 m
= gfc_match_small_literal_int (kind
, NULL
);
46 m
= gfc_match_name (name
);
50 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
56 if (sym
->attr
.flavor
!= FL_PARAMETER
)
59 p
= gfc_extract_int (sym
->value
, kind
);
70 /* Get a trailing kind-specification for non-character variables.
72 the integer kind value or:
73 -1 if an error was generated
74 -2 if no kind was found */
82 if (gfc_match_char ('_') != MATCH_YES
)
85 m
= match_kind_param (&kind
);
87 gfc_error ("Missing kind-parameter at %C");
89 return (m
== MATCH_YES
) ? kind
: -1;
93 /* Given a character and a radix, see if the character is a valid
94 digit in that radix. */
97 check_digit (int c
, int radix
)
104 r
= ('0' <= c
&& c
<= '1');
108 r
= ('0' <= c
&& c
<= '7');
112 r
= ('0' <= c
&& c
<= '9');
120 gfc_internal_error ("check_digit(): bad radix");
127 /* Match the digit string part of an integer if signflag is not set,
128 the signed digit string part if signflag is set. If the buffer
129 is NULL, we just count characters for the resolution pass. Returns
130 the number of characters matched, -1 for no match. */
133 match_digits (int signflag
, int radix
, char *buffer
)
139 c
= gfc_next_char ();
141 if (signflag
&& (c
== '+' || c
== '-'))
145 gfc_gobble_whitespace ();
146 c
= gfc_next_char ();
150 if (!check_digit (c
, radix
))
159 old_loc
= gfc_current_locus
;
160 c
= gfc_next_char ();
162 if (!check_digit (c
, radix
))
170 gfc_current_locus
= old_loc
;
176 /* Match an integer (digit string and optional kind).
177 A sign will be accepted if signflag is set. */
180 match_integer_constant (gfc_expr
**result
, int signflag
)
187 old_loc
= gfc_current_locus
;
188 gfc_gobble_whitespace ();
190 length
= match_digits (signflag
, 10, NULL
);
191 gfc_current_locus
= old_loc
;
195 buffer
= alloca (length
+ 1);
196 memset (buffer
, '\0', length
+ 1);
198 gfc_gobble_whitespace ();
200 match_digits (signflag
, 10, buffer
);
204 kind
= gfc_default_integer_kind
;
208 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
210 gfc_error ("Integer kind %d at %C not available", kind
);
214 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
216 if (gfc_range_check (e
) != ARITH_OK
)
218 gfc_error ("Integer too big for its kind at %C. This check can be "
219 "disabled with the option -fno-range-check");
230 /* Match a Hollerith constant. */
233 match_hollerith_constant (gfc_expr
**result
)
241 old_loc
= gfc_current_locus
;
242 gfc_gobble_whitespace ();
244 if (match_integer_constant (&e
, 0) == MATCH_YES
245 && gfc_match_char ('h') == MATCH_YES
)
247 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Hollerith constant "
251 msg
= gfc_extract_int (e
, &num
);
259 gfc_error ("Invalid Hollerith constant: %L must contain at least "
260 "one character", &old_loc
);
263 if (e
->ts
.kind
!= gfc_default_integer_kind
)
265 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
266 "should be default", &old_loc
);
272 e
= gfc_constant_result (BT_HOLLERITH
, gfc_default_character_kind
,
275 e
->representation
.string
= gfc_getmem (num
+ 1);
276 for (i
= 0; i
< num
; i
++)
278 e
->representation
.string
[i
] = gfc_next_char_literal (1);
280 e
->representation
.string
[num
] = '\0';
281 e
->representation
.length
= num
;
289 gfc_current_locus
= old_loc
;
298 /* Match a binary, octal or hexadecimal constant that can be found in
299 a DATA statement. The standard permits b'010...', o'73...', and
300 z'a1...' where b, o, and z can be capital letters. This function
301 also accepts postfixed forms of the constants: '01...'b, '73...'o,
302 and 'a1...'z. An additional extension is the use of x for z. */
305 match_boz_constant (gfc_expr
**result
)
307 int post
, radix
, delim
, length
, x_hex
, kind
;
308 locus old_loc
, start_loc
;
312 start_loc
= old_loc
= gfc_current_locus
;
313 gfc_gobble_whitespace ();
316 switch (post
= gfc_next_char ())
338 radix
= 16; /* Set to accept any valid digit string. */
344 /* No whitespace allowed here. */
347 delim
= gfc_next_char ();
349 if (delim
!= '\'' && delim
!= '\"')
352 if (x_hex
&& pedantic
353 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
354 "constant at %C uses non-standard syntax.")
358 old_loc
= gfc_current_locus
;
360 length
= match_digits (0, radix
, NULL
);
363 gfc_error ("Empty set of digits in BOZ constant at %C");
367 if (gfc_next_char () != delim
)
369 gfc_error ("Illegal character in BOZ constant at %C");
375 switch (gfc_next_char ())
391 gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ constant "
392 "at %C uses non-standard postfix syntax.");
395 gfc_current_locus
= old_loc
;
397 buffer
= alloca (length
+ 1);
398 memset (buffer
, '\0', length
+ 1);
400 match_digits (0, radix
, buffer
);
401 gfc_next_char (); /* Eat delimiter. */
403 gfc_next_char (); /* Eat postfixed b, o, z, or x. */
405 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
406 "If a data-stmt-constant is a boz-literal-constant, the corresponding
407 variable shall be of type integer. The boz-literal-constant is treated
408 as if it were an int-literal-constant with a kind-param that specifies
409 the representation method with the largest decimal exponent range
410 supported by the processor." */
412 kind
= gfc_max_integer_kind
;
413 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
415 if (gfc_range_check (e
) != ARITH_OK
)
417 gfc_error ("Integer too big for integer kind %i at %C", kind
);
426 gfc_current_locus
= start_loc
;
431 /* Match a real constant of some sort. Allow a signed constant if signflag
432 is nonzero. Allow integer constants if allow_int is true. */
435 match_real_constant (gfc_expr
**result
, int signflag
)
437 int kind
, c
, count
, seen_dp
, seen_digits
, exp_char
;
438 locus old_loc
, temp_loc
;
443 old_loc
= gfc_current_locus
;
444 gfc_gobble_whitespace ();
454 c
= gfc_next_char ();
455 if (signflag
&& (c
== '+' || c
== '-'))
460 gfc_gobble_whitespace ();
461 c
= gfc_next_char ();
464 /* Scan significand. */
465 for (;; c
= gfc_next_char (), count
++)
472 /* Check to see if "." goes with a following operator like
474 temp_loc
= gfc_current_locus
;
475 c
= gfc_next_char ();
477 if (c
== 'e' || c
== 'd' || c
== 'q')
479 c
= gfc_next_char ();
481 goto done
; /* Operator named .e. or .d. */
485 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
487 gfc_current_locus
= temp_loc
;
501 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
506 c
= gfc_next_char ();
509 if (c
== '+' || c
== '-')
510 { /* optional sign */
511 c
= gfc_next_char ();
517 gfc_error ("Missing exponent in real number at %C");
523 c
= gfc_next_char ();
528 /* Check that we have a numeric constant. */
529 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
531 gfc_current_locus
= old_loc
;
535 /* Convert the number. */
536 gfc_current_locus
= old_loc
;
537 gfc_gobble_whitespace ();
539 buffer
= alloca (count
+ 1);
540 memset (buffer
, '\0', count
+ 1);
543 c
= gfc_next_char ();
544 if (c
== '+' || c
== '-')
546 gfc_gobble_whitespace ();
547 c
= gfc_next_char ();
550 /* Hack for mpfr_set_str(). */
553 if (c
== 'd' || c
== 'q')
561 c
= gfc_next_char ();
573 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
577 kind
= gfc_default_double_kind
;
582 kind
= gfc_default_real_kind
;
584 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
586 gfc_error ("Invalid real kind %d at %C", kind
);
591 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
593 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
595 switch (gfc_range_check (e
))
600 gfc_error ("Real constant overflows its kind at %C");
603 case ARITH_UNDERFLOW
:
604 if (gfc_option
.warn_underflow
)
605 gfc_warning ("Real constant underflows its kind at %C");
606 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
610 gfc_internal_error ("gfc_range_check() returned bad value");
622 /* Match a substring reference. */
625 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
627 gfc_expr
*start
, *end
;
635 old_loc
= gfc_current_locus
;
637 m
= gfc_match_char ('(');
641 if (gfc_match_char (':') != MATCH_YES
)
644 m
= gfc_match_init_expr (&start
);
646 m
= gfc_match_expr (&start
);
654 m
= gfc_match_char (':');
659 if (gfc_match_char (')') != MATCH_YES
)
662 m
= gfc_match_init_expr (&end
);
664 m
= gfc_match_expr (&end
);
668 if (m
== MATCH_ERROR
)
671 m
= gfc_match_char (')');
676 /* Optimize away the (:) reference. */
677 if (start
== NULL
&& end
== NULL
)
681 ref
= gfc_get_ref ();
683 ref
->type
= REF_SUBSTRING
;
685 start
= gfc_int_expr (1);
686 ref
->u
.ss
.start
= start
;
687 if (end
== NULL
&& cl
)
688 end
= gfc_copy_expr (cl
->length
);
690 ref
->u
.ss
.length
= cl
;
697 gfc_error ("Syntax error in SUBSTRING specification at %C");
701 gfc_free_expr (start
);
704 gfc_current_locus
= old_loc
;
709 /* Reads the next character of a string constant, taking care to
710 return doubled delimiters on the input as a single instance of
713 Special return values are:
714 -1 End of the string, as determined by the delimiter
715 -2 Unterminated string detected
717 Backslash codes are also expanded at this time. */
720 next_string_char (char delimiter
)
725 c
= gfc_next_char_literal (1);
730 if (gfc_option
.flag_backslash
&& c
== '\\')
732 old_locus
= gfc_current_locus
;
734 if (gfc_match_special_char (&c
) == MATCH_NO
)
735 gfc_current_locus
= old_locus
;
737 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
738 gfc_warning ("Extension: backslash character at %C");
744 old_locus
= gfc_current_locus
;
745 c
= gfc_next_char_literal (0);
749 gfc_current_locus
= old_locus
;
755 /* Special case of gfc_match_name() that matches a parameter kind name
756 before a string constant. This takes case of the weird but legal
761 where kind____ is a parameter. gfc_match_name() will happily slurp
762 up all the underscores, which leads to problems. If we return
763 MATCH_YES, the parse pointer points to the final underscore, which
764 is not part of the name. We never return MATCH_ERROR-- errors in
765 the name will be detected later. */
768 match_charkind_name (char *name
)
774 gfc_gobble_whitespace ();
775 c
= gfc_next_char ();
784 old_loc
= gfc_current_locus
;
785 c
= gfc_next_char ();
789 peek
= gfc_peek_char ();
791 if (peek
== '\'' || peek
== '\"')
793 gfc_current_locus
= old_loc
;
801 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
805 if (++len
> GFC_MAX_SYMBOL_LEN
)
813 /* See if the current input matches a character constant. Lots of
814 contortions have to be done to match the kind parameter which comes
815 before the actual string. The main consideration is that we don't
816 want to error out too quickly. For example, we don't actually do
817 any validation of the kinds until we have actually seen a legal
818 delimiter. Using match_kind_param() generates errors too quickly. */
821 match_string_constant (gfc_expr
**result
)
823 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
824 int i
, c
, kind
, length
, delimiter
, warn_ampersand
;
825 locus old_locus
, start_locus
;
831 old_locus
= gfc_current_locus
;
833 gfc_gobble_whitespace ();
835 start_locus
= gfc_current_locus
;
837 c
= gfc_next_char ();
838 if (c
== '\'' || c
== '"')
840 kind
= gfc_default_character_kind
;
850 kind
= kind
* 10 + c
- '0';
853 c
= gfc_next_char ();
859 gfc_current_locus
= old_locus
;
861 m
= match_charkind_name (name
);
865 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
867 || sym
->attr
.flavor
!= FL_PARAMETER
)
871 c
= gfc_next_char ();
876 gfc_gobble_whitespace ();
877 c
= gfc_next_char ();
883 gfc_gobble_whitespace ();
884 start_locus
= gfc_current_locus
;
886 c
= gfc_next_char ();
887 if (c
!= '\'' && c
!= '"')
892 q
= gfc_extract_int (sym
->value
, &kind
);
900 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
902 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
907 /* Scan the string into a block of memory by first figuring out how
908 long it is, allocating the structure, then re-reading it. This
909 isn't particularly efficient, but string constants aren't that
910 common in most code. TODO: Use obstacks? */
917 c
= next_string_char (delimiter
);
922 gfc_current_locus
= start_locus
;
923 gfc_error ("Unterminated character constant beginning at %C");
930 /* Peek at the next character to see if it is a b, o, z, or x for the
931 postfixed BOZ literal constants. */
932 c
= gfc_peek_char ();
933 if (c
== 'b' || c
== 'o' || c
=='z' || c
== 'x')
939 e
->expr_type
= EXPR_CONSTANT
;
941 e
->ts
.type
= BT_CHARACTER
;
943 e
->ts
.is_c_interop
= 0;
945 e
->where
= start_locus
;
947 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
948 e
->value
.character
.length
= length
;
950 gfc_current_locus
= start_locus
;
951 gfc_next_char (); /* Skip delimiter */
953 /* We disable the warning for the following loop as the warning has already
954 been printed in the loop above. */
955 warn_ampersand
= gfc_option
.warn_ampersand
;
956 gfc_option
.warn_ampersand
= 0;
958 for (i
= 0; i
< length
; i
++)
959 *p
++ = next_string_char (delimiter
);
961 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
962 gfc_option
.warn_ampersand
= warn_ampersand
;
964 if (next_string_char (delimiter
) != -1)
965 gfc_internal_error ("match_string_constant(): Delimiter not found");
967 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
968 e
->expr_type
= EXPR_SUBSTRING
;
975 gfc_current_locus
= old_locus
;
980 /* Match a .true. or .false. */
983 match_logical_constant (gfc_expr
**result
)
985 static mstring logical_ops
[] = {
986 minit (".false.", 0),
994 i
= gfc_match_strings (logical_ops
);
1002 kind
= gfc_default_logical_kind
;
1004 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1006 gfc_error ("Bad kind for logical constant at %C");
1010 e
= gfc_get_expr ();
1012 e
->expr_type
= EXPR_CONSTANT
;
1013 e
->value
.logical
= i
;
1014 e
->ts
.type
= BT_LOGICAL
;
1016 e
->ts
.is_c_interop
= 0;
1018 e
->where
= gfc_current_locus
;
1025 /* Match a real or imaginary part of a complex constant that is a
1026 symbolic constant. */
1029 match_sym_complex_part (gfc_expr
**result
)
1031 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1036 m
= gfc_match_name (name
);
1040 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1043 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1045 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1049 if (!gfc_numeric_ts (&sym
->value
->ts
))
1051 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1055 if (sym
->value
->rank
!= 0)
1057 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1061 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PARAMETER symbol in "
1062 "complex constant at %C") == FAILURE
)
1065 switch (sym
->value
->ts
.type
)
1068 e
= gfc_copy_expr (sym
->value
);
1072 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1078 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1084 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1087 *result
= e
; /* e is a scalar, real, constant expression. */
1091 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1096 /* Match a real or imaginary part of a complex number. */
1099 match_complex_part (gfc_expr
**result
)
1103 m
= match_sym_complex_part (result
);
1107 m
= match_real_constant (result
, 1);
1111 return match_integer_constant (result
, 1);
1115 /* Try to match a complex constant. */
1118 match_complex_constant (gfc_expr
**result
)
1120 gfc_expr
*e
, *real
, *imag
;
1121 gfc_error_buf old_error
;
1122 gfc_typespec target
;
1127 old_loc
= gfc_current_locus
;
1128 real
= imag
= e
= NULL
;
1130 m
= gfc_match_char ('(');
1134 gfc_push_error (&old_error
);
1136 m
= match_complex_part (&real
);
1139 gfc_free_error (&old_error
);
1143 if (gfc_match_char (',') == MATCH_NO
)
1145 gfc_pop_error (&old_error
);
1150 /* If m is error, then something was wrong with the real part and we
1151 assume we have a complex constant because we've seen the ','. An
1152 ambiguous case here is the start of an iterator list of some
1153 sort. These sort of lists are matched prior to coming here. */
1155 if (m
== MATCH_ERROR
)
1157 gfc_free_error (&old_error
);
1160 gfc_pop_error (&old_error
);
1162 m
= match_complex_part (&imag
);
1165 if (m
== MATCH_ERROR
)
1168 m
= gfc_match_char (')');
1171 /* Give the matcher for implied do-loops a chance to run. This
1172 yields a much saner error message for (/ (i, 4=i, 6) /). */
1173 if (gfc_peek_char () == '=')
1182 if (m
== MATCH_ERROR
)
1185 /* Decide on the kind of this complex number. */
1186 if (real
->ts
.type
== BT_REAL
)
1188 if (imag
->ts
.type
== BT_REAL
)
1189 kind
= gfc_kind_max (real
, imag
);
1191 kind
= real
->ts
.kind
;
1195 if (imag
->ts
.type
== BT_REAL
)
1196 kind
= imag
->ts
.kind
;
1198 kind
= gfc_default_real_kind
;
1200 target
.type
= BT_REAL
;
1202 target
.is_c_interop
= 0;
1203 target
.is_iso_c
= 0;
1205 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1206 gfc_convert_type (real
, &target
, 2);
1207 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1208 gfc_convert_type (imag
, &target
, 2);
1210 e
= gfc_convert_complex (real
, imag
, kind
);
1211 e
->where
= gfc_current_locus
;
1213 gfc_free_expr (real
);
1214 gfc_free_expr (imag
);
1220 gfc_error ("Syntax error in COMPLEX constant at %C");
1225 gfc_free_expr (real
);
1226 gfc_free_expr (imag
);
1227 gfc_current_locus
= old_loc
;
1233 /* Match constants in any of several forms. Returns nonzero for a
1234 match, zero for no match. */
1237 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1241 m
= match_complex_constant (result
);
1245 m
= match_string_constant (result
);
1249 m
= match_boz_constant (result
);
1253 m
= match_real_constant (result
, signflag
);
1257 m
= match_hollerith_constant (result
);
1261 m
= match_integer_constant (result
, signflag
);
1265 m
= match_logical_constant (result
);
1273 /* Match a single actual argument value. An actual argument is
1274 usually an expression, but can also be a procedure name. If the
1275 argument is a single name, it is not always possible to tell
1276 whether the name is a dummy procedure or not. We treat these cases
1277 by creating an argument that looks like a dummy procedure and
1278 fixing things later during resolution. */
1281 match_actual_arg (gfc_expr
**result
)
1283 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1284 gfc_symtree
*symtree
;
1289 where
= gfc_current_locus
;
1291 switch (gfc_match_name (name
))
1300 w
= gfc_current_locus
;
1301 gfc_gobble_whitespace ();
1302 c
= gfc_next_char ();
1303 gfc_current_locus
= w
;
1305 if (c
!= ',' && c
!= ')')
1308 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1310 /* Handle error elsewhere. */
1312 /* Eliminate a couple of common cases where we know we don't
1313 have a function argument. */
1314 if (symtree
== NULL
)
1316 gfc_get_sym_tree (name
, NULL
, &symtree
);
1317 gfc_set_sym_referenced (symtree
->n
.sym
);
1323 sym
= symtree
->n
.sym
;
1324 gfc_set_sym_referenced (sym
);
1325 if (sym
->attr
.flavor
!= FL_PROCEDURE
1326 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1329 /* If the symbol is a function with itself as the result and
1330 is being defined, then we have a variable. */
1331 if (sym
->attr
.function
&& sym
->result
== sym
)
1333 if (gfc_current_ns
->proc_name
== sym
1334 || (gfc_current_ns
->parent
!= NULL
1335 && gfc_current_ns
->parent
->proc_name
== sym
))
1339 && (sym
->ns
== gfc_current_ns
1340 || sym
->ns
== gfc_current_ns
->parent
))
1342 gfc_entry_list
*el
= NULL
;
1344 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1354 e
= gfc_get_expr (); /* Leave it unknown for now */
1355 e
->symtree
= symtree
;
1356 e
->expr_type
= EXPR_VARIABLE
;
1357 e
->ts
.type
= BT_PROCEDURE
;
1364 gfc_current_locus
= where
;
1365 return gfc_match_expr (result
);
1369 /* Match a keyword argument. */
1372 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1374 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1375 gfc_actual_arglist
*a
;
1379 name_locus
= gfc_current_locus
;
1380 m
= gfc_match_name (name
);
1384 if (gfc_match_char ('=') != MATCH_YES
)
1390 m
= match_actual_arg (&actual
->expr
);
1394 /* Make sure this name has not appeared yet. */
1396 if (name
[0] != '\0')
1398 for (a
= base
; a
; a
= a
->next
)
1399 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1401 gfc_error ("Keyword '%s' at %C has already appeared in the "
1402 "current argument list", name
);
1407 actual
->name
= gfc_get_string (name
);
1411 gfc_current_locus
= name_locus
;
1416 /* Match an argument list function, such as %VAL. */
1419 match_arg_list_function (gfc_actual_arglist
*result
)
1421 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1425 old_locus
= gfc_current_locus
;
1427 if (gfc_match_char ('%') != MATCH_YES
)
1433 m
= gfc_match ("%n (", name
);
1437 if (name
[0] != '\0')
1442 if (strncmp (name
, "loc", 3) == 0)
1444 result
->name
= "%LOC";
1448 if (strncmp (name
, "ref", 3) == 0)
1450 result
->name
= "%REF";
1454 if (strncmp (name
, "val", 3) == 0)
1456 result
->name
= "%VAL";
1465 if (gfc_notify_std (GFC_STD_GNU
, "Extension: argument list "
1466 "function at %C") == FAILURE
)
1472 m
= match_actual_arg (&result
->expr
);
1476 if (gfc_match_char (')') != MATCH_YES
)
1485 gfc_current_locus
= old_locus
;
1490 /* Matches an actual argument list of a function or subroutine, from
1491 the opening parenthesis to the closing parenthesis. The argument
1492 list is assumed to allow keyword arguments because we don't know if
1493 the symbol associated with the procedure has an implicit interface
1494 or not. We make sure keywords are unique. If sub_flag is set,
1495 we're matching the argument list of a subroutine. */
1498 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1500 gfc_actual_arglist
*head
, *tail
;
1502 gfc_st_label
*label
;
1506 *argp
= tail
= NULL
;
1507 old_loc
= gfc_current_locus
;
1511 if (gfc_match_char ('(') == MATCH_NO
)
1512 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1514 if (gfc_match_char (')') == MATCH_YES
)
1521 head
= tail
= gfc_get_actual_arglist ();
1524 tail
->next
= gfc_get_actual_arglist ();
1528 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1530 m
= gfc_match_st_label (&label
);
1532 gfc_error ("Expected alternate return label at %C");
1536 tail
->label
= label
;
1540 /* After the first keyword argument is seen, the following
1541 arguments must also have keywords. */
1544 m
= match_keyword_arg (tail
, head
);
1546 if (m
== MATCH_ERROR
)
1550 gfc_error ("Missing keyword name in actual argument list at %C");
1557 /* Try an argument list function, like %VAL. */
1558 m
= match_arg_list_function (tail
);
1559 if (m
== MATCH_ERROR
)
1562 /* See if we have the first keyword argument. */
1565 m
= match_keyword_arg (tail
, head
);
1568 if (m
== MATCH_ERROR
)
1574 /* Try for a non-keyword argument. */
1575 m
= match_actual_arg (&tail
->expr
);
1576 if (m
== MATCH_ERROR
)
1585 if (gfc_match_char (')') == MATCH_YES
)
1587 if (gfc_match_char (',') != MATCH_YES
)
1595 gfc_error ("Syntax error in argument list at %C");
1598 gfc_free_actual_arglist (head
);
1599 gfc_current_locus
= old_loc
;
1605 /* Used by match_varspec() to extend the reference list by one
1609 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1611 if (primary
->ref
== NULL
)
1612 primary
->ref
= tail
= gfc_get_ref ();
1616 gfc_internal_error ("extend_ref(): Bad tail");
1617 tail
->next
= gfc_get_ref ();
1625 /* Match any additional specifications associated with the current
1626 variable like member references or substrings. If equiv_flag is
1627 set we only match stuff that is allowed inside an EQUIVALENCE
1631 match_varspec (gfc_expr
*primary
, int equiv_flag
)
1633 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1634 gfc_ref
*substring
, *tail
;
1635 gfc_component
*component
;
1636 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1641 if ((equiv_flag
&& gfc_peek_char () == '(') || sym
->attr
.dimension
)
1643 /* In EQUIVALENCE, we don't know yet whether we are seeing
1644 an array, character variable or array of character
1645 variables. We'll leave the decision till resolve time. */
1646 tail
= extend_ref (primary
, tail
);
1647 tail
->type
= REF_ARRAY
;
1649 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1654 if (equiv_flag
&& gfc_peek_char () == '(')
1656 tail
= extend_ref (primary
, tail
);
1657 tail
->type
= REF_ARRAY
;
1659 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
);
1665 primary
->ts
= sym
->ts
;
1670 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1671 goto check_substring
;
1673 sym
= sym
->ts
.derived
;
1677 m
= gfc_match_name (name
);
1679 gfc_error ("Expected structure component name at %C");
1683 component
= gfc_find_component (sym
, name
);
1684 if (component
== NULL
)
1687 tail
= extend_ref (primary
, tail
);
1688 tail
->type
= REF_COMPONENT
;
1690 tail
->u
.c
.component
= component
;
1691 tail
->u
.c
.sym
= sym
;
1693 primary
->ts
= component
->ts
;
1695 if (component
->as
!= NULL
)
1697 tail
= extend_ref (primary
, tail
);
1698 tail
->type
= REF_ARRAY
;
1700 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1705 if (component
->ts
.type
!= BT_DERIVED
1706 || gfc_match_char ('%') != MATCH_YES
)
1709 sym
= component
->ts
.derived
;
1713 if (primary
->ts
.type
== BT_UNKNOWN
)
1715 if (gfc_get_default_type (sym
, sym
->ns
)->type
== BT_CHARACTER
)
1717 gfc_set_default_type (sym
, 0, sym
->ns
);
1718 primary
->ts
= sym
->ts
;
1722 if (primary
->ts
.type
== BT_CHARACTER
)
1724 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1728 primary
->ref
= substring
;
1730 tail
->next
= substring
;
1732 if (primary
->expr_type
== EXPR_CONSTANT
)
1733 primary
->expr_type
= EXPR_SUBSTRING
;
1736 primary
->ts
.cl
= NULL
;
1752 /* Given an expression that is a variable, figure out what the
1753 ultimate variable's type and attribute is, traversing the reference
1754 structures if necessary.
1756 This subroutine is trickier than it looks. We start at the base
1757 symbol and store the attribute. Component references load a
1758 completely new attribute.
1760 A couple of rules come into play. Subobjects of targets are always
1761 targets themselves. If we see a component that goes through a
1762 pointer, then the expression must also be a target, since the
1763 pointer is associated with something (if it isn't core will soon be
1764 dumped). If we see a full part or section of an array, the
1765 expression is also an array.
1767 We can have at most one full array reference. */
1770 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
1772 int dimension
, pointer
, allocatable
, target
;
1773 symbol_attribute attr
;
1776 if (expr
->expr_type
!= EXPR_VARIABLE
)
1777 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1780 attr
= expr
->symtree
->n
.sym
->attr
;
1782 dimension
= attr
.dimension
;
1783 pointer
= attr
.pointer
;
1784 allocatable
= attr
.allocatable
;
1786 target
= attr
.target
;
1790 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1791 *ts
= expr
->symtree
->n
.sym
->ts
;
1793 for (; ref
; ref
= ref
->next
)
1798 switch (ref
->u
.ar
.type
)
1805 allocatable
= pointer
= 0;
1810 allocatable
= pointer
= 0;
1814 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1820 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1823 *ts
= ref
->u
.c
.component
->ts
;
1824 /* Don't set the string length if a substring reference
1826 if (ts
->type
== BT_CHARACTER
1827 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
1831 pointer
= ref
->u
.c
.component
->pointer
;
1832 allocatable
= ref
->u
.c
.component
->allocatable
;
1839 allocatable
= pointer
= 0;
1843 attr
.dimension
= dimension
;
1844 attr
.pointer
= pointer
;
1845 attr
.allocatable
= allocatable
;
1846 attr
.target
= target
;
1852 /* Return the attribute from a general expression. */
1855 gfc_expr_attr (gfc_expr
*e
)
1857 symbol_attribute attr
;
1859 switch (e
->expr_type
)
1862 attr
= gfc_variable_attr (e
, NULL
);
1866 gfc_clear_attr (&attr
);
1868 if (e
->value
.function
.esym
!= NULL
)
1869 attr
= e
->value
.function
.esym
->result
->attr
;
1871 /* TODO: NULL() returns pointers. May have to take care of this
1877 gfc_clear_attr (&attr
);
1885 /* Match a structure constructor. The initial symbol has already been
1889 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
1891 gfc_constructor
*head
, *tail
;
1892 gfc_component
*comp
;
1896 bool private_comp
= false;
1900 if (gfc_match_char ('(') != MATCH_YES
)
1903 where
= gfc_current_locus
;
1905 gfc_find_component (sym
, NULL
);
1907 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1909 if (comp
->access
== ACCESS_PRIVATE
)
1911 private_comp
= true;
1915 tail
= head
= gfc_get_constructor ();
1918 tail
->next
= gfc_get_constructor ();
1922 m
= gfc_match_expr (&tail
->expr
);
1925 if (m
== MATCH_ERROR
)
1928 if (gfc_match_char (',') == MATCH_YES
)
1930 if (comp
->next
== NULL
)
1932 gfc_error ("Too many components in structure constructor at %C");
1942 if (sym
->attr
.use_assoc
1943 && (sym
->component_access
== ACCESS_PRIVATE
|| private_comp
))
1945 gfc_error ("Structure constructor for '%s' at %C has PRIVATE "
1946 "components", sym
->name
);
1950 if (gfc_match_char (')') != MATCH_YES
)
1953 if (comp
->next
!= NULL
)
1955 gfc_error ("Too few components in structure constructor at %C");
1959 e
= gfc_get_expr ();
1961 e
->expr_type
= EXPR_STRUCTURE
;
1963 e
->ts
.type
= BT_DERIVED
;
1964 e
->ts
.derived
= sym
;
1967 e
->value
.constructor
= head
;
1973 gfc_error ("Syntax error in structure constructor at %C");
1976 gfc_free_constructor (head
);
1981 /* If the symbol is an implicit do loop index and implicitly typed,
1982 it should not be host associated. Provide a symtree from the
1983 current namespace. */
1985 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
1987 if ((*sym
)->attr
.flavor
== FL_VARIABLE
1988 && (*sym
)->ns
!= gfc_current_ns
1989 && (*sym
)->attr
.implied_index
1990 && (*sym
)->attr
.implicit_type
1991 && !(*sym
)->attr
.use_assoc
)
1994 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
);
1997 *sym
= (*st
)->n
.sym
;
2003 /* Matches a variable name followed by anything that might follow it--
2004 array reference, argument list of a function, etc. */
2007 gfc_match_rvalue (gfc_expr
**result
)
2009 gfc_actual_arglist
*actual_arglist
;
2010 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2013 gfc_symtree
*symtree
;
2014 locus where
, old_loc
;
2021 m
= gfc_match_name (name
);
2025 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2026 && !gfc_current_ns
->has_import_set
)
2027 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
2029 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2034 sym
= symtree
->n
.sym
;
2036 where
= gfc_current_locus
;
2038 /* If this is an implicit do loop index and implicitly typed,
2039 it should not be host associated. */
2040 m
= check_for_implicit_index (&symtree
, &sym
);
2044 gfc_set_sym_referenced (sym
);
2045 sym
->attr
.implied_index
= 0;
2047 if (sym
->attr
.function
&& sym
->result
== sym
)
2049 /* See if this is a directly recursive function call. */
2050 gfc_gobble_whitespace ();
2051 if (sym
->attr
.recursive
2052 && gfc_peek_char () == '('
2053 && gfc_current_ns
->proc_name
== sym
2054 && !sym
->attr
.dimension
)
2056 gfc_error ("'%s' at %C is the name of a recursive function "
2057 "and so refers to the result variable. Use an "
2058 "explicit RESULT variable for direct recursion "
2059 "(12.5.2.1)", sym
->name
);
2063 if (gfc_current_ns
->proc_name
== sym
2064 || (gfc_current_ns
->parent
!= NULL
2065 && gfc_current_ns
->parent
->proc_name
== sym
))
2069 && (sym
->ns
== gfc_current_ns
2070 || sym
->ns
== gfc_current_ns
->parent
))
2072 gfc_entry_list
*el
= NULL
;
2074 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2080 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2083 if (sym
->attr
.generic
)
2084 goto generic_function
;
2086 switch (sym
->attr
.flavor
)
2090 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
2091 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2092 gfc_set_default_type (sym
, 0, sym
->ns
);
2094 e
= gfc_get_expr ();
2096 e
->expr_type
= EXPR_VARIABLE
;
2097 e
->symtree
= symtree
;
2099 m
= match_varspec (e
, 0);
2103 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2104 end up here. Unfortunately, sym->value->expr_type is set to
2105 EXPR_CONSTANT, and so the if () branch would be followed without
2106 the !sym->as check. */
2107 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2108 e
= gfc_copy_expr (sym
->value
);
2111 e
= gfc_get_expr ();
2112 e
->expr_type
= EXPR_VARIABLE
;
2115 e
->symtree
= symtree
;
2116 m
= match_varspec (e
, 0);
2120 sym
= gfc_use_derived (sym
);
2124 m
= gfc_match_structure_constructor (sym
, &e
);
2127 /* If we're here, then the name is known to be the name of a
2128 procedure, yet it is not sure to be the name of a function. */
2130 if (sym
->attr
.subroutine
)
2132 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2138 /* At this point, the name has to be a non-statement function.
2139 If the name is the same as the current function being
2140 compiled, then we have a variable reference (to the function
2141 result) if the name is non-recursive. */
2143 st
= gfc_enclosing_unit (NULL
);
2145 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2147 && !sym
->attr
.recursive
)
2149 e
= gfc_get_expr ();
2150 e
->symtree
= symtree
;
2151 e
->expr_type
= EXPR_VARIABLE
;
2153 m
= match_varspec (e
, 0);
2157 /* Match a function reference. */
2159 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2162 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2163 gfc_error ("Statement function '%s' requires argument list at %C",
2166 gfc_error ("Function '%s' requires an argument list at %C",
2179 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2180 sym
= symtree
->n
.sym
;
2182 e
= gfc_get_expr ();
2183 e
->symtree
= symtree
;
2184 e
->expr_type
= EXPR_FUNCTION
;
2185 e
->value
.function
.actual
= actual_arglist
;
2186 e
->where
= gfc_current_locus
;
2188 if (sym
->as
!= NULL
)
2189 e
->rank
= sym
->as
->rank
;
2191 if (!sym
->attr
.function
2192 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2198 /* Check here for the existence of at least one argument for the
2199 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2200 argument(s) given will be checked in gfc_iso_c_func_interface,
2201 during resolution of the function call. */
2202 if (sym
->attr
.is_iso_c
== 1
2203 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2204 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2205 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2206 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2208 /* make sure we were given a param */
2209 if (actual_arglist
== NULL
)
2211 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2217 if (sym
->result
== NULL
)
2225 /* Special case for derived type variables that get their types
2226 via an IMPLICIT statement. This can't wait for the
2227 resolution phase. */
2229 if (gfc_peek_char () == '%'
2230 && sym
->ts
.type
== BT_UNKNOWN
2231 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2232 gfc_set_default_type (sym
, 0, sym
->ns
);
2234 /* If the symbol has a dimension attribute, the expression is a
2237 if (sym
->attr
.dimension
)
2239 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2240 sym
->name
, NULL
) == FAILURE
)
2246 e
= gfc_get_expr ();
2247 e
->symtree
= symtree
;
2248 e
->expr_type
= EXPR_VARIABLE
;
2249 m
= match_varspec (e
, 0);
2253 /* Name is not an array, so we peek to see if a '(' implies a
2254 function call or a substring reference. Otherwise the
2255 variable is just a scalar. */
2257 gfc_gobble_whitespace ();
2258 if (gfc_peek_char () != '(')
2260 /* Assume a scalar variable */
2261 e
= gfc_get_expr ();
2262 e
->symtree
= symtree
;
2263 e
->expr_type
= EXPR_VARIABLE
;
2265 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2266 sym
->name
, NULL
) == FAILURE
)
2272 /*FIXME:??? match_varspec does set this for us: */
2274 m
= match_varspec (e
, 0);
2278 /* See if this is a function reference with a keyword argument
2279 as first argument. We do this because otherwise a spurious
2280 symbol would end up in the symbol table. */
2282 old_loc
= gfc_current_locus
;
2283 m2
= gfc_match (" ( %n =", argname
);
2284 gfc_current_locus
= old_loc
;
2286 e
= gfc_get_expr ();
2287 e
->symtree
= symtree
;
2289 if (m2
!= MATCH_YES
)
2291 /* Try to figure out whether we're dealing with a character type.
2292 We're peeking ahead here, because we don't want to call
2293 match_substring if we're dealing with an implicitly typed
2294 non-character variable. */
2295 implicit_char
= false;
2296 if (sym
->ts
.type
== BT_UNKNOWN
)
2298 ts
= gfc_get_default_type (sym
,NULL
);
2299 if (ts
->type
== BT_CHARACTER
)
2300 implicit_char
= true;
2303 /* See if this could possibly be a substring reference of a name
2304 that we're not sure is a variable yet. */
2306 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
2307 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
2310 e
->expr_type
= EXPR_VARIABLE
;
2312 if (sym
->attr
.flavor
!= FL_VARIABLE
2313 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2314 sym
->name
, NULL
) == FAILURE
)
2320 if (sym
->ts
.type
== BT_UNKNOWN
2321 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2335 /* Give up, assume we have a function. */
2337 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2338 sym
= symtree
->n
.sym
;
2339 e
->expr_type
= EXPR_FUNCTION
;
2341 if (!sym
->attr
.function
2342 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2350 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2352 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2360 /* If our new function returns a character, array or structure
2361 type, it might have subsequent references. */
2363 m
= match_varspec (e
, 0);
2370 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2372 e
= gfc_get_expr ();
2373 e
->symtree
= symtree
;
2374 e
->expr_type
= EXPR_FUNCTION
;
2376 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2380 gfc_error ("Symbol at %C is not appropriate for an expression");
2396 /* Match a variable, ie something that can be assigned to. This
2397 starts as a symbol, can be a structure component or an array
2398 reference. It can be a function if the function doesn't have a
2399 separate RESULT variable. If the symbol has not been previously
2400 seen, we assume it is a variable.
2402 This function is called by two interface functions:
2403 gfc_match_variable, which has host_flag = 1, and
2404 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2405 match of the symbol to the local scope. */
2408 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
2416 /* Since nothing has any business being an lvalue in a module
2417 specification block, an interface block or a contains section,
2418 we force the changed_symbols mechanism to work by setting
2419 host_flag to 0. This prevents valid symbols that have the name
2420 of keywords, such as 'end', being turned into variables by
2421 failed matching to assignments for, eg., END INTERFACE. */
2422 if (gfc_current_state () == COMP_MODULE
2423 || gfc_current_state () == COMP_INTERFACE
2424 || gfc_current_state () == COMP_CONTAINS
)
2427 m
= gfc_match_sym_tree (&st
, host_flag
);
2430 where
= gfc_current_locus
;
2434 /* If this is an implicit do loop index and implicitly typed,
2435 it should not be host associated. */
2436 m
= check_for_implicit_index (&st
, &sym
);
2440 sym
->attr
.implied_index
= 0;
2442 gfc_set_sym_referenced (sym
);
2443 switch (sym
->attr
.flavor
)
2446 if (sym
->attr
.protected && sym
->attr
.use_assoc
)
2448 gfc_error ("Assigning to PROTECTED variable at %C");
2454 if (sym
->attr
.access
== ACCESS_PUBLIC
2455 || sym
->attr
.access
== ACCESS_PRIVATE
)
2457 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2458 sym
->name
, NULL
) == FAILURE
)
2464 gfc_error ("Named constant at %C in an EQUIVALENCE");
2466 gfc_error ("Cannot assign to a named constant at %C");
2471 /* Check for a nonrecursive function result */
2472 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
)
2473 && !sym
->attr
.external
)
2475 /* If a function result is a derived type, then the derived
2476 type may still have to be resolved. */
2478 if (sym
->ts
.type
== BT_DERIVED
2479 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2484 /* Fall through to error */
2487 gfc_error ("Expected VARIABLE at %C");
2491 /* Special case for derived type variables that get their types
2492 via an IMPLICIT statement. This can't wait for the
2493 resolution phase. */
2496 gfc_namespace
* implicit_ns
;
2498 if (gfc_current_ns
->proc_name
== sym
)
2499 implicit_ns
= gfc_current_ns
;
2501 implicit_ns
= sym
->ns
;
2503 if (gfc_peek_char () == '%'
2504 && sym
->ts
.type
== BT_UNKNOWN
2505 && gfc_get_default_type (sym
, implicit_ns
)->type
== BT_DERIVED
)
2506 gfc_set_default_type (sym
, 0, implicit_ns
);
2509 expr
= gfc_get_expr ();
2511 expr
->expr_type
= EXPR_VARIABLE
;
2514 expr
->where
= where
;
2516 /* Now see if we have to do more. */
2517 m
= match_varspec (expr
, equiv_flag
);
2520 gfc_free_expr (expr
);
2530 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
2532 return match_variable (result
, equiv_flag
, 1);
2537 gfc_match_equiv_variable (gfc_expr
**result
)
2539 return match_variable (result
, 1, 0);