1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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/>. */
29 #include "constructor.h"
31 /* Matches a kind-parameter expression, which is either a named
32 symbolic constant or a nonnegative integer constant. If
33 successful, sets the kind value to the correct integer. */
36 match_kind_param (int *kind)
38 char name[GFC_MAX_SYMBOL_LEN + 1];
43 m = gfc_match_small_literal_int (kind, NULL);
47 m = gfc_match_name (name);
51 if (gfc_find_symbol (name, NULL, 1, &sym))
57 if (sym->attr.flavor != FL_PARAMETER)
60 if (sym->value == NULL)
63 p = gfc_extract_int (sym->value, kind);
67 gfc_set_sym_referenced (sym);
76 /* Get a trailing kind-specification for non-character variables.
78 the integer kind value or:
79 -1 if an error was generated
80 -2 if no kind was found */
88 if (gfc_match_char ('_') != MATCH_YES)
91 m = match_kind_param (&kind);
93 gfc_error ("Missing kind-parameter at %C");
95 return (m == MATCH_YES) ? kind : -1;
99 /* Given a character and a radix, see if the character is a valid
100 digit in that radix. */
103 gfc_check_digit (char c, int radix)
110 r = ('0' <= c && c <= '1');
114 r = ('0' <= c && c <= '7');
118 r = ('0' <= c && c <= '9');
126 gfc_internal_error ("gfc_check_digit(): bad radix");
133 /* Match the digit string part of an integer if signflag is not set,
134 the signed digit string part if signflag is set. If the buffer
135 is NULL, we just count characters for the resolution pass. Returns
136 the number of characters matched, -1 for no match. */
139 match_digits (int signflag, int radix, char *buffer)
146 c = gfc_next_ascii_char ();
148 if (signflag && (c == '+' || c == '-'))
152 gfc_gobble_whitespace ();
153 c = gfc_next_ascii_char ();
157 if (!gfc_check_digit (c, radix))
166 old_loc = gfc_current_locus;
167 c = gfc_next_ascii_char ();
169 if (!gfc_check_digit (c, radix))
177 gfc_current_locus = old_loc;
183 /* Match an integer (digit string and optional kind).
184 A sign will be accepted if signflag is set. */
187 match_integer_constant (gfc_expr **result, int signflag)
194 old_loc = gfc_current_locus;
195 gfc_gobble_whitespace ();
197 length = match_digits (signflag, 10, NULL);
198 gfc_current_locus = old_loc;
202 buffer = (char *) alloca (length + 1);
203 memset (buffer, '\0', length + 1);
205 gfc_gobble_whitespace ();
207 match_digits (signflag, 10, buffer);
211 kind = gfc_default_integer_kind;
215 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
217 gfc_error ("Integer kind %d at %C not available", kind);
221 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
223 if (gfc_range_check (e) != ARITH_OK)
225 gfc_error ("Integer too big for its kind at %C. This check can be "
226 "disabled with the option -fno-range-check");
237 /* Match a Hollerith constant. */
240 match_hollerith_constant (gfc_expr **result)
248 old_loc = gfc_current_locus;
249 gfc_gobble_whitespace ();
251 if (match_integer_constant (&e, 0) == MATCH_YES
252 && gfc_match_char ('h') == MATCH_YES)
254 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
258 msg = gfc_extract_int (e, &num);
266 gfc_error ("Invalid Hollerith constant: %L must contain at least "
267 "one character", &old_loc);
270 if (e->ts.kind != gfc_default_integer_kind)
272 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
273 "should be default", &old_loc);
279 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
282 /* Calculate padding needed to fit default integer memory. */
283 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
285 e->representation.string = XCNEWVEC (char, num + pad + 1);
287 for (i = 0; i < num; i++)
289 gfc_char_t c = gfc_next_char_literal (1);
290 if (! gfc_wide_fits_in_byte (c))
292 gfc_error ("Invalid Hollerith constant at %L contains a "
293 "wide character", &old_loc);
297 e->representation.string[i] = (unsigned char) c;
300 /* Now pad with blanks and end with a null char. */
301 for (i = 0; i < pad; i++)
302 e->representation.string[num + i] = ' ';
304 e->representation.string[num + i] = '\0';
305 e->representation.length = num + pad;
314 gfc_current_locus = old_loc;
323 /* Match a binary, octal or hexadecimal constant that can be found in
324 a DATA statement. The standard permits b'010...', o'73...', and
325 z'a1...' where b, o, and z can be capital letters. This function
326 also accepts postfixed forms of the constants: '01...'b, '73...'o,
327 and 'a1...'z. An additional extension is the use of x for z. */
330 match_boz_constant (gfc_expr **result)
332 int radix, length, x_hex, kind;
333 locus old_loc, start_loc;
334 char *buffer, post, delim;
337 start_loc = old_loc = gfc_current_locus;
338 gfc_gobble_whitespace ();
341 switch (post = gfc_next_ascii_char ())
363 radix = 16; /* Set to accept any valid digit string. */
369 /* No whitespace allowed here. */
372 delim = gfc_next_ascii_char ();
374 if (delim != '\'' && delim != '\"')
378 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
379 "constant at %C uses non-standard syntax")
383 old_loc = gfc_current_locus;
385 length = match_digits (0, radix, NULL);
388 gfc_error ("Empty set of digits in BOZ constant at %C");
392 if (gfc_next_ascii_char () != delim)
394 gfc_error ("Illegal character in BOZ constant at %C");
400 switch (gfc_next_ascii_char ())
417 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
418 "at %C uses non-standard postfix syntax")
423 gfc_current_locus = old_loc;
425 buffer = (char *) alloca (length + 1);
426 memset (buffer, '\0', length + 1);
428 match_digits (0, radix, buffer);
429 gfc_next_ascii_char (); /* Eat delimiter. */
431 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
433 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
434 "If a data-stmt-constant is a boz-literal-constant, the corresponding
435 variable shall be of type integer. The boz-literal-constant is treated
436 as if it were an int-literal-constant with a kind-param that specifies
437 the representation method with the largest decimal exponent range
438 supported by the processor." */
440 kind = gfc_max_integer_kind;
441 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
443 /* Mark as boz variable. */
446 if (gfc_range_check (e) != ARITH_OK)
448 gfc_error ("Integer too big for integer kind %i at %C", kind);
453 if (!gfc_in_match_data ()
454 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
463 gfc_current_locus = start_loc;
468 /* Match a real constant of some sort. Allow a signed constant if signflag
472 match_real_constant (gfc_expr **result, int signflag)
474 int kind, count, seen_dp, seen_digits;
475 locus old_loc, temp_loc;
476 char *p, *buffer, c, exp_char;
480 old_loc = gfc_current_locus;
481 gfc_gobble_whitespace ();
491 c = gfc_next_ascii_char ();
492 if (signflag && (c == '+' || c == '-'))
497 gfc_gobble_whitespace ();
498 c = gfc_next_ascii_char ();
501 /* Scan significand. */
502 for (;; c = gfc_next_ascii_char (), count++)
509 /* Check to see if "." goes with a following operator like
511 temp_loc = gfc_current_locus;
512 c = gfc_next_ascii_char ();
514 if (c == 'e' || c == 'd' || c == 'q')
516 c = gfc_next_ascii_char ();
518 goto done; /* Operator named .e. or .d. */
522 goto done; /* Distinguish 1.e9 from 1.eq.2 */
524 gfc_current_locus = temp_loc;
538 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
543 c = gfc_next_ascii_char ();
546 if (c == '+' || c == '-')
547 { /* optional sign */
548 c = gfc_next_ascii_char ();
554 gfc_error ("Missing exponent in real number at %C");
560 c = gfc_next_ascii_char ();
565 /* Check that we have a numeric constant. */
566 if (!seen_digits || (!seen_dp && exp_char == ' '))
568 gfc_current_locus = old_loc;
572 /* Convert the number. */
573 gfc_current_locus = old_loc;
574 gfc_gobble_whitespace ();
576 buffer = (char *) alloca (count + 1);
577 memset (buffer, '\0', count + 1);
580 c = gfc_next_ascii_char ();
581 if (c == '+' || c == '-')
583 gfc_gobble_whitespace ();
584 c = gfc_next_ascii_char ();
587 /* Hack for mpfr_set_str(). */
590 if (c == 'd' || c == 'q')
598 c = gfc_next_ascii_char ();
610 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
614 kind = gfc_default_double_kind;
619 kind = gfc_default_real_kind;
621 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
623 gfc_error ("Invalid real kind %d at %C", kind);
628 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
630 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
632 switch (gfc_range_check (e))
637 gfc_error ("Real constant overflows its kind at %C");
640 case ARITH_UNDERFLOW:
641 if (gfc_option.warn_underflow)
642 gfc_warning ("Real constant underflows its kind at %C");
643 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
647 gfc_internal_error ("gfc_range_check() returned bad value");
659 /* Match a substring reference. */
662 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
664 gfc_expr *start, *end;
672 old_loc = gfc_current_locus;
674 m = gfc_match_char ('(');
678 if (gfc_match_char (':') != MATCH_YES)
681 m = gfc_match_init_expr (&start);
683 m = gfc_match_expr (&start);
691 m = gfc_match_char (':');
696 if (gfc_match_char (')') != MATCH_YES)
699 m = gfc_match_init_expr (&end);
701 m = gfc_match_expr (&end);
705 if (m == MATCH_ERROR)
708 m = gfc_match_char (')');
713 /* Optimize away the (:) reference. */
714 if (start == NULL && end == NULL)
718 ref = gfc_get_ref ();
720 ref->type = REF_SUBSTRING;
722 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
723 ref->u.ss.start = start;
724 if (end == NULL && cl)
725 end = gfc_copy_expr (cl->length);
727 ref->u.ss.length = cl;
734 gfc_error ("Syntax error in SUBSTRING specification at %C");
738 gfc_free_expr (start);
741 gfc_current_locus = old_loc;
746 /* Reads the next character of a string constant, taking care to
747 return doubled delimiters on the input as a single instance of
750 Special return values for "ret" argument are:
751 -1 End of the string, as determined by the delimiter
752 -2 Unterminated string detected
754 Backslash codes are also expanded at this time. */
757 next_string_char (gfc_char_t delimiter, int *ret)
762 c = gfc_next_char_literal (1);
771 if (gfc_option.flag_backslash && c == '\\')
773 old_locus = gfc_current_locus;
775 if (gfc_match_special_char (&c) == MATCH_NO)
776 gfc_current_locus = old_locus;
778 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
779 gfc_warning ("Extension: backslash character at %C");
785 old_locus = gfc_current_locus;
786 c = gfc_next_char_literal (0);
790 gfc_current_locus = old_locus;
797 /* Special case of gfc_match_name() that matches a parameter kind name
798 before a string constant. This takes case of the weird but legal
803 where kind____ is a parameter. gfc_match_name() will happily slurp
804 up all the underscores, which leads to problems. If we return
805 MATCH_YES, the parse pointer points to the final underscore, which
806 is not part of the name. We never return MATCH_ERROR-- errors in
807 the name will be detected later. */
810 match_charkind_name (char *name)
816 gfc_gobble_whitespace ();
817 c = gfc_next_ascii_char ();
826 old_loc = gfc_current_locus;
827 c = gfc_next_ascii_char ();
831 peek = gfc_peek_ascii_char ();
833 if (peek == '\'' || peek == '\"')
835 gfc_current_locus = old_loc;
843 && (c != '$' || !gfc_option.flag_dollar_ok))
847 if (++len > GFC_MAX_SYMBOL_LEN)
855 /* See if the current input matches a character constant. Lots of
856 contortions have to be done to match the kind parameter which comes
857 before the actual string. The main consideration is that we don't
858 want to error out too quickly. For example, we don't actually do
859 any validation of the kinds until we have actually seen a legal
860 delimiter. Using match_kind_param() generates errors too quickly. */
863 match_string_constant (gfc_expr **result)
865 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
866 int i, kind, length, warn_ampersand, ret;
867 locus old_locus, start_locus;
872 gfc_char_t c, delimiter, *p;
874 old_locus = gfc_current_locus;
876 gfc_gobble_whitespace ();
878 c = gfc_next_char ();
879 if (c == '\'' || c == '"')
881 kind = gfc_default_character_kind;
882 start_locus = gfc_current_locus;
886 if (gfc_wide_is_digit (c))
890 while (gfc_wide_is_digit (c))
892 kind = kind * 10 + c - '0';
895 c = gfc_next_char ();
901 gfc_current_locus = old_locus;
903 m = match_charkind_name (name);
907 if (gfc_find_symbol (name, NULL, 1, &sym)
909 || sym->attr.flavor != FL_PARAMETER)
913 c = gfc_next_char ();
918 gfc_gobble_whitespace ();
919 c = gfc_next_char ();
925 gfc_gobble_whitespace ();
927 c = gfc_next_char ();
928 if (c != '\'' && c != '"')
931 start_locus = gfc_current_locus;
935 q = gfc_extract_int (sym->value, &kind);
941 gfc_set_sym_referenced (sym);
944 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
946 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
951 /* Scan the string into a block of memory by first figuring out how
952 long it is, allocating the structure, then re-reading it. This
953 isn't particularly efficient, but string constants aren't that
954 common in most code. TODO: Use obstacks? */
961 c = next_string_char (delimiter, &ret);
966 gfc_current_locus = start_locus;
967 gfc_error ("Unterminated character constant beginning at %C");
974 /* Peek at the next character to see if it is a b, o, z, or x for the
975 postfixed BOZ literal constants. */
976 peek = gfc_peek_ascii_char ();
977 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
980 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
982 e->ts.is_c_interop = 0;
985 gfc_current_locus = start_locus;
987 /* We disable the warning for the following loop as the warning has already
988 been printed in the loop above. */
989 warn_ampersand = gfc_option.warn_ampersand;
990 gfc_option.warn_ampersand = 0;
992 p = e->value.character.string;
993 for (i = 0; i < length; i++)
995 c = next_string_char (delimiter, &ret);
997 if (!gfc_check_character_range (c, kind))
999 gfc_error ("Character '%s' in string at %C is not representable "
1000 "in character kind %d", gfc_print_wide_char (c), kind);
1007 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1008 gfc_option.warn_ampersand = warn_ampersand;
1010 next_string_char (delimiter, &ret);
1012 gfc_internal_error ("match_string_constant(): Delimiter not found");
1014 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1015 e->expr_type = EXPR_SUBSTRING;
1022 gfc_current_locus = old_locus;
1027 /* Match a .true. or .false. Returns 1 if a .true. was found,
1028 0 if a .false. was found, and -1 otherwise. */
1030 match_logical_constant_string (void)
1032 locus orig_loc = gfc_current_locus;
1034 gfc_gobble_whitespace ();
1035 if (gfc_next_ascii_char () == '.')
1037 char ch = gfc_next_ascii_char ();
1040 if (gfc_next_ascii_char () == 'a'
1041 && gfc_next_ascii_char () == 'l'
1042 && gfc_next_ascii_char () == 's'
1043 && gfc_next_ascii_char () == 'e'
1044 && gfc_next_ascii_char () == '.')
1045 /* Matched ".false.". */
1050 if (gfc_next_ascii_char () == 'r'
1051 && gfc_next_ascii_char () == 'u'
1052 && gfc_next_ascii_char () == 'e'
1053 && gfc_next_ascii_char () == '.')
1054 /* Matched ".true.". */
1058 gfc_current_locus = orig_loc;
1062 /* Match a .true. or .false. */
1065 match_logical_constant (gfc_expr **result)
1070 i = match_logical_constant_string ();
1078 kind = gfc_default_logical_kind;
1080 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1082 gfc_error ("Bad kind for logical constant at %C");
1086 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1087 e->ts.is_c_interop = 0;
1095 /* Match a real or imaginary part of a complex constant that is a
1096 symbolic constant. */
1099 match_sym_complex_part (gfc_expr **result)
1101 char name[GFC_MAX_SYMBOL_LEN + 1];
1106 m = gfc_match_name (name);
1110 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1113 if (sym->attr.flavor != FL_PARAMETER)
1115 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1119 if (!gfc_numeric_ts (&sym->value->ts))
1121 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1125 if (sym->value->rank != 0)
1127 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1131 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1132 "complex constant at %C") == FAILURE)
1135 switch (sym->value->ts.type)
1138 e = gfc_copy_expr (sym->value);
1142 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1148 e = gfc_int2real (sym->value, gfc_default_real_kind);
1154 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1157 *result = e; /* e is a scalar, real, constant expression. */
1161 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1166 /* Match a real or imaginary part of a complex number. */
1169 match_complex_part (gfc_expr **result)
1173 m = match_sym_complex_part (result);
1177 m = match_real_constant (result, 1);
1181 return match_integer_constant (result, 1);
1185 /* Try to match a complex constant. */
1188 match_complex_constant (gfc_expr **result)
1190 gfc_expr *e, *real, *imag;
1191 gfc_error_buf old_error;
1192 gfc_typespec target;
1197 old_loc = gfc_current_locus;
1198 real = imag = e = NULL;
1200 m = gfc_match_char ('(');
1204 gfc_push_error (&old_error);
1206 m = match_complex_part (&real);
1209 gfc_free_error (&old_error);
1213 if (gfc_match_char (',') == MATCH_NO)
1215 gfc_pop_error (&old_error);
1220 /* If m is error, then something was wrong with the real part and we
1221 assume we have a complex constant because we've seen the ','. An
1222 ambiguous case here is the start of an iterator list of some
1223 sort. These sort of lists are matched prior to coming here. */
1225 if (m == MATCH_ERROR)
1227 gfc_free_error (&old_error);
1230 gfc_pop_error (&old_error);
1232 m = match_complex_part (&imag);
1235 if (m == MATCH_ERROR)
1238 m = gfc_match_char (')');
1241 /* Give the matcher for implied do-loops a chance to run. This
1242 yields a much saner error message for (/ (i, 4=i, 6) /). */
1243 if (gfc_peek_ascii_char () == '=')
1252 if (m == MATCH_ERROR)
1255 /* Decide on the kind of this complex number. */
1256 if (real->ts.type == BT_REAL)
1258 if (imag->ts.type == BT_REAL)
1259 kind = gfc_kind_max (real, imag);
1261 kind = real->ts.kind;
1265 if (imag->ts.type == BT_REAL)
1266 kind = imag->ts.kind;
1268 kind = gfc_default_real_kind;
1270 target.type = BT_REAL;
1272 target.is_c_interop = 0;
1273 target.is_iso_c = 0;
1275 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1276 gfc_convert_type (real, &target, 2);
1277 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1278 gfc_convert_type (imag, &target, 2);
1280 e = gfc_convert_complex (real, imag, kind);
1281 e->where = gfc_current_locus;
1283 gfc_free_expr (real);
1284 gfc_free_expr (imag);
1290 gfc_error ("Syntax error in COMPLEX constant at %C");
1295 gfc_free_expr (real);
1296 gfc_free_expr (imag);
1297 gfc_current_locus = old_loc;
1303 /* Match constants in any of several forms. Returns nonzero for a
1304 match, zero for no match. */
1307 gfc_match_literal_constant (gfc_expr **result, int signflag)
1311 m = match_complex_constant (result);
1315 m = match_string_constant (result);
1319 m = match_boz_constant (result);
1323 m = match_real_constant (result, signflag);
1327 m = match_hollerith_constant (result);
1331 m = match_integer_constant (result, signflag);
1335 m = match_logical_constant (result);
1343 /* This checks if a symbol is the return value of an encompassing function.
1344 Function nesting can be maximally two levels deep, but we may have
1345 additional local namespaces like BLOCK etc. */
1348 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1350 if (!sym->attr.function || (sym->result != sym))
1354 if (ns->proc_name == sym)
1362 /* Match a single actual argument value. An actual argument is
1363 usually an expression, but can also be a procedure name. If the
1364 argument is a single name, it is not always possible to tell
1365 whether the name is a dummy procedure or not. We treat these cases
1366 by creating an argument that looks like a dummy procedure and
1367 fixing things later during resolution. */
1370 match_actual_arg (gfc_expr **result)
1372 char name[GFC_MAX_SYMBOL_LEN + 1];
1373 gfc_symtree *symtree;
1378 gfc_gobble_whitespace ();
1379 where = gfc_current_locus;
1381 switch (gfc_match_name (name))
1390 w = gfc_current_locus;
1391 gfc_gobble_whitespace ();
1392 c = gfc_next_ascii_char ();
1393 gfc_current_locus = w;
1395 if (c != ',' && c != ')')
1398 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1400 /* Handle error elsewhere. */
1402 /* Eliminate a couple of common cases where we know we don't
1403 have a function argument. */
1404 if (symtree == NULL)
1406 gfc_get_sym_tree (name, NULL, &symtree, false);
1407 gfc_set_sym_referenced (symtree->n.sym);
1413 sym = symtree->n.sym;
1414 gfc_set_sym_referenced (sym);
1415 if (sym->attr.flavor != FL_PROCEDURE
1416 && sym->attr.flavor != FL_UNKNOWN)
1419 if (sym->attr.in_common && !sym->attr.proc_pointer)
1421 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1426 /* If the symbol is a function with itself as the result and
1427 is being defined, then we have a variable. */
1428 if (sym->attr.function && sym->result == sym)
1430 if (gfc_is_function_return_value (sym, gfc_current_ns))
1434 && (sym->ns == gfc_current_ns
1435 || sym->ns == gfc_current_ns->parent))
1437 gfc_entry_list *el = NULL;
1439 for (el = sym->ns->entries; el; el = el->next)
1449 e = gfc_get_expr (); /* Leave it unknown for now */
1450 e->symtree = symtree;
1451 e->expr_type = EXPR_VARIABLE;
1452 e->ts.type = BT_PROCEDURE;
1459 gfc_current_locus = where;
1460 return gfc_match_expr (result);
1464 /* Match a keyword argument. */
1467 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1469 char name[GFC_MAX_SYMBOL_LEN + 1];
1470 gfc_actual_arglist *a;
1474 name_locus = gfc_current_locus;
1475 m = gfc_match_name (name);
1479 if (gfc_match_char ('=') != MATCH_YES)
1485 m = match_actual_arg (&actual->expr);
1489 /* Make sure this name has not appeared yet. */
1491 if (name[0] != '\0')
1493 for (a = base; a; a = a->next)
1494 if (a->name != NULL && strcmp (a->name, name) == 0)
1496 gfc_error ("Keyword '%s' at %C has already appeared in the "
1497 "current argument list", name);
1502 actual->name = gfc_get_string (name);
1506 gfc_current_locus = name_locus;
1511 /* Match an argument list function, such as %VAL. */
1514 match_arg_list_function (gfc_actual_arglist *result)
1516 char name[GFC_MAX_SYMBOL_LEN + 1];
1520 old_locus = gfc_current_locus;
1522 if (gfc_match_char ('%') != MATCH_YES)
1528 m = gfc_match ("%n (", name);
1532 if (name[0] != '\0')
1537 if (strncmp (name, "loc", 3) == 0)
1539 result->name = "%LOC";
1543 if (strncmp (name, "ref", 3) == 0)
1545 result->name = "%REF";
1549 if (strncmp (name, "val", 3) == 0)
1551 result->name = "%VAL";
1560 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1561 "function at %C") == FAILURE)
1567 m = match_actual_arg (&result->expr);
1571 if (gfc_match_char (')') != MATCH_YES)
1580 gfc_current_locus = old_locus;
1585 /* Matches an actual argument list of a function or subroutine, from
1586 the opening parenthesis to the closing parenthesis. The argument
1587 list is assumed to allow keyword arguments because we don't know if
1588 the symbol associated with the procedure has an implicit interface
1589 or not. We make sure keywords are unique. If sub_flag is set,
1590 we're matching the argument list of a subroutine. */
1593 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1595 gfc_actual_arglist *head, *tail;
1597 gfc_st_label *label;
1601 *argp = tail = NULL;
1602 old_loc = gfc_current_locus;
1606 if (gfc_match_char ('(') == MATCH_NO)
1607 return (sub_flag) ? MATCH_YES : MATCH_NO;
1609 if (gfc_match_char (')') == MATCH_YES)
1616 head = tail = gfc_get_actual_arglist ();
1619 tail->next = gfc_get_actual_arglist ();
1623 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1625 m = gfc_match_st_label (&label);
1627 gfc_error ("Expected alternate return label at %C");
1631 tail->label = label;
1635 /* After the first keyword argument is seen, the following
1636 arguments must also have keywords. */
1639 m = match_keyword_arg (tail, head);
1641 if (m == MATCH_ERROR)
1645 gfc_error ("Missing keyword name in actual argument list at %C");
1652 /* Try an argument list function, like %VAL. */
1653 m = match_arg_list_function (tail);
1654 if (m == MATCH_ERROR)
1657 /* See if we have the first keyword argument. */
1660 m = match_keyword_arg (tail, head);
1663 if (m == MATCH_ERROR)
1669 /* Try for a non-keyword argument. */
1670 m = match_actual_arg (&tail->expr);
1671 if (m == MATCH_ERROR)
1680 if (gfc_match_char (')') == MATCH_YES)
1682 if (gfc_match_char (',') != MATCH_YES)
1690 gfc_error ("Syntax error in argument list at %C");
1693 gfc_free_actual_arglist (head);
1694 gfc_current_locus = old_loc;
1700 /* Used by gfc_match_varspec() to extend the reference list by one
1704 extend_ref (gfc_expr *primary, gfc_ref *tail)
1706 if (primary->ref == NULL)
1707 primary->ref = tail = gfc_get_ref ();
1711 gfc_internal_error ("extend_ref(): Bad tail");
1712 tail->next = gfc_get_ref ();
1720 /* Match any additional specifications associated with the current
1721 variable like member references or substrings. If equiv_flag is
1722 set we only match stuff that is allowed inside an EQUIVALENCE
1723 statement. sub_flag tells whether we expect a type-bound procedure found
1724 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1725 components, 'ppc_arg' determines whether the PPC may be called (with an
1726 argument list), or whether it may just be referred to as a pointer. */
1729 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1732 char name[GFC_MAX_SYMBOL_LEN + 1];
1733 gfc_ref *substring, *tail;
1734 gfc_component *component;
1735 gfc_symbol *sym = primary->symtree->n.sym;
1741 gfc_gobble_whitespace ();
1743 if (gfc_peek_ascii_char () == '[')
1745 if (sym->attr.dimension)
1747 gfc_error ("Array section designator, e.g. '(:)', is required "
1748 "besides the coarray designator '[...]' at %C");
1751 if (!sym->attr.codimension)
1753 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1759 /* For associate names, we may not yet know whether they are arrays or not.
1760 Thus if we have one and parentheses follow, we have to assume that it
1761 actually is one for now. The final decision will be made at
1762 resolution time, of course. */
1763 if (sym->assoc && gfc_peek_ascii_char () == '(')
1764 sym->attr.dimension = 1;
1766 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1767 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1768 || (sym->attr.dimension && !sym->attr.proc_pointer
1769 && !gfc_is_proc_ptr_comp (primary, NULL)
1770 && !(gfc_matching_procptr_assignment
1771 && sym->attr.flavor == FL_PROCEDURE))
1772 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension))
1774 /* In EQUIVALENCE, we don't know yet whether we are seeing
1775 an array, character variable or array of character
1776 variables. We'll leave the decision till resolve time. */
1777 tail = extend_ref (primary, tail);
1778 tail->type = REF_ARRAY;
1780 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1781 equiv_flag, sym->as ? sym->as->corank : 0);
1785 gfc_gobble_whitespace ();
1786 if (equiv_flag && gfc_peek_ascii_char () == '(')
1788 tail = extend_ref (primary, tail);
1789 tail->type = REF_ARRAY;
1791 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1797 primary->ts = sym->ts;
1802 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1803 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1804 gfc_set_default_type (sym, 0, sym->ns);
1806 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1807 || gfc_match_char ('%') != MATCH_YES)
1808 goto check_substring;
1810 sym = sym->ts.u.derived;
1817 m = gfc_match_name (name);
1819 gfc_error ("Expected structure component name at %C");
1823 if (sym->f2k_derived)
1824 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1830 gfc_symbol* tbp_sym;
1835 gcc_assert (!tail || !tail->next);
1836 gcc_assert (primary->expr_type == EXPR_VARIABLE);
1838 if (tbp->n.tb->is_generic)
1841 tbp_sym = tbp->n.tb->u.specific->n.sym;
1843 primary->expr_type = EXPR_COMPCALL;
1844 primary->value.compcall.tbp = tbp->n.tb;
1845 primary->value.compcall.name = tbp->name;
1846 primary->value.compcall.ignore_pass = 0;
1847 primary->value.compcall.assign = 0;
1848 primary->value.compcall.base_object = NULL;
1849 gcc_assert (primary->symtree->n.sym->attr.referenced);
1851 primary->ts = tbp_sym->ts;
1853 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1854 &primary->value.compcall.actual);
1855 if (m == MATCH_ERROR)
1860 primary->value.compcall.actual = NULL;
1863 gfc_error ("Expected argument list at %C");
1871 component = gfc_find_component (sym, name, false, false);
1872 if (component == NULL)
1875 tail = extend_ref (primary, tail);
1876 tail->type = REF_COMPONENT;
1878 tail->u.c.component = component;
1879 tail->u.c.sym = sym;
1881 primary->ts = component->ts;
1883 if (component->attr.proc_pointer && ppc_arg
1884 && !gfc_matching_procptr_assignment)
1886 m = gfc_match_actual_arglist (sub_flag,
1887 &primary->value.compcall.actual);
1888 if (m == MATCH_ERROR)
1891 primary->expr_type = EXPR_PPC;
1896 if (component->as != NULL && !component->attr.proc_pointer)
1898 tail = extend_ref (primary, tail);
1899 tail->type = REF_ARRAY;
1901 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
1902 component->as->corank);
1906 else if (component->ts.type == BT_CLASS
1907 && CLASS_DATA (component)->as != NULL
1908 && !component->attr.proc_pointer)
1910 tail = extend_ref (primary, tail);
1911 tail->type = REF_ARRAY;
1913 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
1915 CLASS_DATA (component)->as->corank);
1920 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1921 || gfc_match_char ('%') != MATCH_YES)
1924 sym = component->ts.u.derived;
1929 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1931 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1933 gfc_set_default_type (sym, 0, sym->ns);
1934 primary->ts = sym->ts;
1939 if (primary->ts.type == BT_CHARACTER)
1941 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1945 primary->ref = substring;
1947 tail->next = substring;
1949 if (primary->expr_type == EXPR_CONSTANT)
1950 primary->expr_type = EXPR_SUBSTRING;
1953 primary->ts.u.cl = NULL;
1960 gfc_clear_ts (&primary->ts);
1961 gfc_clear_ts (&sym->ts);
1971 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
1973 gfc_error ("Coindexed procedure-pointer component at %C");
1981 /* Given an expression that is a variable, figure out what the
1982 ultimate variable's type and attribute is, traversing the reference
1983 structures if necessary.
1985 This subroutine is trickier than it looks. We start at the base
1986 symbol and store the attribute. Component references load a
1987 completely new attribute.
1989 A couple of rules come into play. Subobjects of targets are always
1990 targets themselves. If we see a component that goes through a
1991 pointer, then the expression must also be a target, since the
1992 pointer is associated with something (if it isn't core will soon be
1993 dumped). If we see a full part or section of an array, the
1994 expression is also an array.
1996 We can have at most one full array reference. */
1999 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2001 int dimension, pointer, allocatable, target;
2002 symbol_attribute attr;
2005 gfc_component *comp;
2007 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2008 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2010 sym = expr->symtree->n.sym;
2013 if (sym->ts.type == BT_CLASS)
2015 dimension = CLASS_DATA (sym)->attr.dimension;
2016 pointer = CLASS_DATA (sym)->attr.class_pointer;
2017 allocatable = CLASS_DATA (sym)->attr.allocatable;
2021 dimension = attr.dimension;
2022 pointer = attr.pointer;
2023 allocatable = attr.allocatable;
2026 target = attr.target;
2027 if (pointer || attr.proc_pointer)
2030 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2033 for (ref = expr->ref; ref; ref = ref->next)
2038 switch (ref->u.ar.type)
2045 allocatable = pointer = 0;
2050 /* Handle coarrays. */
2051 if (ref->u.ar.dimen > 0)
2052 allocatable = pointer = 0;
2056 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2062 comp = ref->u.c.component;
2067 /* Don't set the string length if a substring reference
2069 if (ts->type == BT_CHARACTER
2070 && ref->next && ref->next->type == REF_SUBSTRING)
2074 if (comp->ts.type == BT_CLASS)
2076 pointer = CLASS_DATA (comp)->attr.class_pointer;
2077 allocatable = CLASS_DATA (comp)->attr.allocatable;
2081 pointer = comp->attr.pointer;
2082 allocatable = comp->attr.allocatable;
2084 if (pointer || attr.proc_pointer)
2090 allocatable = pointer = 0;
2094 attr.dimension = dimension;
2095 attr.pointer = pointer;
2096 attr.allocatable = allocatable;
2097 attr.target = target;
2098 attr.save = sym->attr.save;
2104 /* Return the attribute from a general expression. */
2107 gfc_expr_attr (gfc_expr *e)
2109 symbol_attribute attr;
2111 switch (e->expr_type)
2114 attr = gfc_variable_attr (e, NULL);
2118 gfc_clear_attr (&attr);
2120 if (e->value.function.esym != NULL)
2122 gfc_symbol *sym = e->value.function.esym->result;
2124 if (sym->ts.type == BT_CLASS)
2126 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2127 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2128 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2132 attr = gfc_variable_attr (e, NULL);
2134 /* TODO: NULL() returns pointers. May have to take care of this
2140 gfc_clear_attr (&attr);
2148 /* Match a structure constructor. The initial symbol has already been
2151 typedef struct gfc_structure_ctor_component
2156 struct gfc_structure_ctor_component* next;
2158 gfc_structure_ctor_component;
2160 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2163 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2165 gfc_free (comp->name);
2166 gfc_free_expr (comp->val);
2171 /* Translate the component list into the actual constructor by sorting it in
2172 the order required; this also checks along the way that each and every
2173 component actually has an initializer and handles default initializers
2174 for components without explicit value given. */
2176 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2177 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2179 gfc_structure_ctor_component *comp_iter;
2180 gfc_component *comp;
2182 for (comp = sym->components; comp; comp = comp->next)
2184 gfc_structure_ctor_component **next_ptr;
2185 gfc_expr *value = NULL;
2187 /* Try to find the initializer for the current component by name. */
2188 next_ptr = comp_head;
2189 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2191 if (!strcmp (comp_iter->name, comp->name))
2193 next_ptr = &comp_iter->next;
2196 /* If an extension, try building the parent derived type by building
2197 a value expression for the parent derived type and calling self. */
2198 if (!comp_iter && comp == sym->components && sym->attr.extension)
2200 value = gfc_get_structure_constructor_expr (comp->ts.type,
2202 &gfc_current_locus);
2203 value->ts = comp->ts;
2205 if (build_actual_constructor (comp_head, &value->value.constructor,
2206 comp->ts.u.derived) == FAILURE)
2208 gfc_free_expr (value);
2212 gfc_constructor_append_expr (ctor_head, value, NULL);
2216 /* If it was not found, try the default initializer if there's any;
2217 otherwise, it's an error. */
2220 if (comp->initializer)
2222 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2223 " constructor with missing optional arguments"
2224 " at %C") == FAILURE)
2226 value = gfc_copy_expr (comp->initializer);
2230 gfc_error ("No initializer for component '%s' given in the"
2231 " structure constructor at %C!", comp->name);
2236 value = comp_iter->val;
2238 /* Add the value to the constructor chain built. */
2239 gfc_constructor_append_expr (ctor_head, value, NULL);
2241 /* Remove the entry from the component list. We don't want the expression
2242 value to be free'd, so set it to NULL. */
2245 *next_ptr = comp_iter->next;
2246 comp_iter->val = NULL;
2247 gfc_free_structure_ctor_component (comp_iter);
2254 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2257 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2258 gfc_constructor_base ctor_head = NULL;
2259 gfc_component *comp; /* Is set NULL when named component is first seen */
2263 const char* last_name = NULL;
2265 comp_tail = comp_head = NULL;
2267 if (!parent && gfc_match_char ('(') != MATCH_YES)
2270 where = gfc_current_locus;
2272 gfc_find_component (sym, NULL, false, true);
2274 /* Check that we're not about to construct an ABSTRACT type. */
2275 if (!parent && sym->attr.abstract)
2277 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2281 /* Match the component list and store it in a list together with the
2282 corresponding component names. Check for empty argument list first. */
2283 if (gfc_match_char (')') != MATCH_YES)
2285 comp = sym->components;
2288 gfc_component *this_comp = NULL;
2291 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2294 comp_tail->next = gfc_get_structure_ctor_component ();
2295 comp_tail = comp_tail->next;
2297 comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2298 comp_tail->val = NULL;
2299 comp_tail->where = gfc_current_locus;
2301 /* Try matching a component name. */
2302 if (gfc_match_name (comp_tail->name) == MATCH_YES
2303 && gfc_match_char ('=') == MATCH_YES)
2305 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2306 " constructor with named arguments at %C")
2310 last_name = comp_tail->name;
2315 /* Components without name are not allowed after the first named
2316 component initializer! */
2320 gfc_error ("Component initializer without name after"
2321 " component named %s at %C!", last_name);
2323 gfc_error ("Too many components in structure constructor at"
2328 gfc_current_locus = comp_tail->where;
2329 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2332 /* Find the current component in the structure definition and check
2333 its access is not private. */
2335 this_comp = gfc_find_component (sym, comp->name, false, false);
2338 this_comp = gfc_find_component (sym,
2339 (const char *)comp_tail->name,
2341 comp = NULL; /* Reset needed! */
2344 /* Here we can check if a component name is given which does not
2345 correspond to any component of the defined structure. */
2349 /* Check if this component is already given a value. */
2350 for (comp_iter = comp_head; comp_iter != comp_tail;
2351 comp_iter = comp_iter->next)
2353 gcc_assert (comp_iter);
2354 if (!strcmp (comp_iter->name, comp_tail->name))
2356 gfc_error ("Component '%s' is initialized twice in the"
2357 " structure constructor at %C!", comp_tail->name);
2362 /* Match the current initializer expression. */
2363 m = gfc_match_expr (&comp_tail->val);
2366 if (m == MATCH_ERROR)
2369 /* F2008, R457/C725, for PURE C1283. */
2370 if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
2372 gfc_error ("Coindexed expression to pointer component '%s' in "
2373 "structure constructor at %C!", comp_tail->name);
2378 /* If not explicitly a parent constructor, gather up the components
2380 if (comp && comp == sym->components
2381 && sym->attr.extension
2382 && (comp_tail->val->ts.type != BT_DERIVED
2384 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2386 gfc_current_locus = where;
2387 gfc_free_expr (comp_tail->val);
2388 comp_tail->val = NULL;
2390 m = gfc_match_structure_constructor (comp->ts.u.derived,
2391 &comp_tail->val, true);
2394 if (m == MATCH_ERROR)
2401 if (parent && !comp)
2405 while (gfc_match_char (',') == MATCH_YES);
2407 if (!parent && gfc_match_char (')') != MATCH_YES)
2411 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2414 /* No component should be left, as this should have caused an error in the
2415 loop constructing the component-list (name that does not correspond to any
2416 component in the structure definition). */
2417 if (comp_head && sym->attr.extension)
2419 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2421 gfc_error ("component '%s' at %L has already been set by a "
2422 "parent derived type constructor", comp_iter->name,
2428 gcc_assert (!comp_head);
2430 e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
2431 e->ts.u.derived = sym;
2432 e->value.constructor = ctor_head;
2438 gfc_error ("Syntax error in structure constructor at %C");
2441 for (comp_iter = comp_head; comp_iter; )
2443 gfc_structure_ctor_component *next = comp_iter->next;
2444 gfc_free_structure_ctor_component (comp_iter);
2447 gfc_constructor_free (ctor_head);
2452 /* If the symbol is an implicit do loop index and implicitly typed,
2453 it should not be host associated. Provide a symtree from the
2454 current namespace. */
2456 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2458 if ((*sym)->attr.flavor == FL_VARIABLE
2459 && (*sym)->ns != gfc_current_ns
2460 && (*sym)->attr.implied_index
2461 && (*sym)->attr.implicit_type
2462 && !(*sym)->attr.use_assoc)
2465 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2468 *sym = (*st)->n.sym;
2474 /* Procedure pointer as function result: Replace the function symbol by the
2475 auto-generated hidden result variable named "ppr@". */
2478 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2480 /* Check for procedure pointer result variable. */
2481 if ((*sym)->attr.function && !(*sym)->attr.external
2482 && (*sym)->result && (*sym)->result != *sym
2483 && (*sym)->result->attr.proc_pointer
2484 && (*sym) == gfc_current_ns->proc_name
2485 && (*sym) == (*sym)->result->ns->proc_name
2486 && strcmp ("ppr@", (*sym)->result->name) == 0)
2488 /* Automatic replacement with "hidden" result variable. */
2489 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2490 *sym = (*sym)->result;
2491 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2498 /* Matches a variable name followed by anything that might follow it--
2499 array reference, argument list of a function, etc. */
2502 gfc_match_rvalue (gfc_expr **result)
2504 gfc_actual_arglist *actual_arglist;
2505 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2508 gfc_symtree *symtree;
2509 locus where, old_loc;
2517 m = gfc_match_name (name);
2521 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2522 && !gfc_current_ns->has_import_set)
2523 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2525 i = gfc_get_ha_sym_tree (name, &symtree);
2530 sym = symtree->n.sym;
2532 where = gfc_current_locus;
2534 replace_hidden_procptr_result (&sym, &symtree);
2536 /* If this is an implicit do loop index and implicitly typed,
2537 it should not be host associated. */
2538 m = check_for_implicit_index (&symtree, &sym);
2542 gfc_set_sym_referenced (sym);
2543 sym->attr.implied_index = 0;
2545 if (sym->attr.function && sym->result == sym)
2547 /* See if this is a directly recursive function call. */
2548 gfc_gobble_whitespace ();
2549 if (sym->attr.recursive
2550 && gfc_peek_ascii_char () == '('
2551 && gfc_current_ns->proc_name == sym
2552 && !sym->attr.dimension)
2554 gfc_error ("'%s' at %C is the name of a recursive function "
2555 "and so refers to the result variable. Use an "
2556 "explicit RESULT variable for direct recursion "
2557 "(12.5.2.1)", sym->name);
2561 if (gfc_is_function_return_value (sym, gfc_current_ns))
2565 && (sym->ns == gfc_current_ns
2566 || sym->ns == gfc_current_ns->parent))
2568 gfc_entry_list *el = NULL;
2570 for (el = sym->ns->entries; el; el = el->next)
2576 if (gfc_matching_procptr_assignment)
2579 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2582 if (sym->attr.generic)
2583 goto generic_function;
2585 switch (sym->attr.flavor)
2589 e = gfc_get_expr ();
2591 e->expr_type = EXPR_VARIABLE;
2592 e->symtree = symtree;
2594 m = gfc_match_varspec (e, 0, false, true);
2598 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2599 end up here. Unfortunately, sym->value->expr_type is set to
2600 EXPR_CONSTANT, and so the if () branch would be followed without
2601 the !sym->as check. */
2602 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2603 e = gfc_copy_expr (sym->value);
2606 e = gfc_get_expr ();
2607 e->expr_type = EXPR_VARIABLE;
2610 e->symtree = symtree;
2611 m = gfc_match_varspec (e, 0, false, true);
2613 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2616 /* Variable array references to derived type parameters cause
2617 all sorts of headaches in simplification. Treating such
2618 expressions as variable works just fine for all array
2620 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2622 for (ref = e->ref; ref; ref = ref->next)
2623 if (ref->type == REF_ARRAY)
2626 if (ref == NULL || ref->u.ar.type == AR_FULL)
2632 e = gfc_get_expr ();
2633 e->expr_type = EXPR_VARIABLE;
2634 e->symtree = symtree;
2641 sym = gfc_use_derived (sym);
2645 m = gfc_match_structure_constructor (sym, &e, false);
2648 /* If we're here, then the name is known to be the name of a
2649 procedure, yet it is not sure to be the name of a function. */
2652 /* Procedure Pointer Assignments. */
2654 if (gfc_matching_procptr_assignment)
2656 gfc_gobble_whitespace ();
2657 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2658 /* Parse functions returning a procptr. */
2661 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2662 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2663 sym->attr.intrinsic = 1;
2664 e = gfc_get_expr ();
2665 e->expr_type = EXPR_VARIABLE;
2666 e->symtree = symtree;
2667 m = gfc_match_varspec (e, 0, false, true);
2671 if (sym->attr.subroutine)
2673 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2679 /* At this point, the name has to be a non-statement function.
2680 If the name is the same as the current function being
2681 compiled, then we have a variable reference (to the function
2682 result) if the name is non-recursive. */
2684 st = gfc_enclosing_unit (NULL);
2686 if (st != NULL && st->state == COMP_FUNCTION
2688 && !sym->attr.recursive)
2690 e = gfc_get_expr ();
2691 e->symtree = symtree;
2692 e->expr_type = EXPR_VARIABLE;
2694 m = gfc_match_varspec (e, 0, false, true);
2698 /* Match a function reference. */
2700 m = gfc_match_actual_arglist (0, &actual_arglist);
2703 if (sym->attr.proc == PROC_ST_FUNCTION)
2704 gfc_error ("Statement function '%s' requires argument list at %C",
2707 gfc_error ("Function '%s' requires an argument list at %C",
2720 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2721 sym = symtree->n.sym;
2723 replace_hidden_procptr_result (&sym, &symtree);
2725 e = gfc_get_expr ();
2726 e->symtree = symtree;
2727 e->expr_type = EXPR_FUNCTION;
2728 e->value.function.actual = actual_arglist;
2729 e->where = gfc_current_locus;
2731 if (sym->as != NULL)
2732 e->rank = sym->as->rank;
2734 if (!sym->attr.function
2735 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2741 /* Check here for the existence of at least one argument for the
2742 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2743 argument(s) given will be checked in gfc_iso_c_func_interface,
2744 during resolution of the function call. */
2745 if (sym->attr.is_iso_c == 1
2746 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2747 && (sym->intmod_sym_id == ISOCBINDING_LOC
2748 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2749 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2751 /* make sure we were given a param */
2752 if (actual_arglist == NULL)
2754 gfc_error ("Missing argument to '%s' at %C", sym->name);
2760 if (sym->result == NULL)
2768 /* Special case for derived type variables that get their types
2769 via an IMPLICIT statement. This can't wait for the
2770 resolution phase. */
2772 if (gfc_peek_ascii_char () == '%'
2773 && sym->ts.type == BT_UNKNOWN
2774 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2775 gfc_set_default_type (sym, 0, sym->ns);
2777 /* If the symbol has a dimension attribute, the expression is a
2780 if (sym->attr.dimension)
2782 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2783 sym->name, NULL) == FAILURE)
2789 e = gfc_get_expr ();
2790 e->symtree = symtree;
2791 e->expr_type = EXPR_VARIABLE;
2792 m = gfc_match_varspec (e, 0, false, true);
2796 /* Name is not an array, so we peek to see if a '(' implies a
2797 function call or a substring reference. Otherwise the
2798 variable is just a scalar. */
2800 gfc_gobble_whitespace ();
2801 if (gfc_peek_ascii_char () != '(')
2803 /* Assume a scalar variable */
2804 e = gfc_get_expr ();
2805 e->symtree = symtree;
2806 e->expr_type = EXPR_VARIABLE;
2808 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2809 sym->name, NULL) == FAILURE)
2815 /*FIXME:??? gfc_match_varspec does set this for us: */
2817 m = gfc_match_varspec (e, 0, false, true);
2821 /* See if this is a function reference with a keyword argument
2822 as first argument. We do this because otherwise a spurious
2823 symbol would end up in the symbol table. */
2825 old_loc = gfc_current_locus;
2826 m2 = gfc_match (" ( %n =", argname);
2827 gfc_current_locus = old_loc;
2829 e = gfc_get_expr ();
2830 e->symtree = symtree;
2832 if (m2 != MATCH_YES)
2834 /* Try to figure out whether we're dealing with a character type.
2835 We're peeking ahead here, because we don't want to call
2836 match_substring if we're dealing with an implicitly typed
2837 non-character variable. */
2838 implicit_char = false;
2839 if (sym->ts.type == BT_UNKNOWN)
2841 ts = gfc_get_default_type (sym->name, NULL);
2842 if (ts->type == BT_CHARACTER)
2843 implicit_char = true;
2846 /* See if this could possibly be a substring reference of a name
2847 that we're not sure is a variable yet. */
2849 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2850 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2853 e->expr_type = EXPR_VARIABLE;
2855 if (sym->attr.flavor != FL_VARIABLE
2856 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2857 sym->name, NULL) == FAILURE)
2863 if (sym->ts.type == BT_UNKNOWN
2864 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2878 /* Give up, assume we have a function. */
2880 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2881 sym = symtree->n.sym;
2882 e->expr_type = EXPR_FUNCTION;
2884 if (!sym->attr.function
2885 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2893 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2895 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2903 /* If our new function returns a character, array or structure
2904 type, it might have subsequent references. */
2906 m = gfc_match_varspec (e, 0, false, true);
2913 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2915 e = gfc_get_expr ();
2916 e->symtree = symtree;
2917 e->expr_type = EXPR_FUNCTION;
2919 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2923 gfc_error ("Symbol at %C is not appropriate for an expression");
2939 /* Match a variable, i.e. something that can be assigned to. This
2940 starts as a symbol, can be a structure component or an array
2941 reference. It can be a function if the function doesn't have a
2942 separate RESULT variable. If the symbol has not been previously
2943 seen, we assume it is a variable.
2945 This function is called by two interface functions:
2946 gfc_match_variable, which has host_flag = 1, and
2947 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2948 match of the symbol to the local scope. */
2951 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2959 /* Since nothing has any business being an lvalue in a module
2960 specification block, an interface block or a contains section,
2961 we force the changed_symbols mechanism to work by setting
2962 host_flag to 0. This prevents valid symbols that have the name
2963 of keywords, such as 'end', being turned into variables by
2964 failed matching to assignments for, e.g., END INTERFACE. */
2965 if (gfc_current_state () == COMP_MODULE
2966 || gfc_current_state () == COMP_INTERFACE
2967 || gfc_current_state () == COMP_CONTAINS)
2970 where = gfc_current_locus;
2971 m = gfc_match_sym_tree (&st, host_flag);
2977 /* If this is an implicit do loop index and implicitly typed,
2978 it should not be host associated. */
2979 m = check_for_implicit_index (&st, &sym);
2983 sym->attr.implied_index = 0;
2985 gfc_set_sym_referenced (sym);
2986 switch (sym->attr.flavor)
2989 /* Everything is alright. */
2994 sym_flavor flavor = FL_UNKNOWN;
2996 gfc_gobble_whitespace ();
2998 if (sym->attr.external || sym->attr.procedure
2999 || sym->attr.function || sym->attr.subroutine)
3000 flavor = FL_PROCEDURE;
3002 /* If it is not a procedure, is not typed and is host associated,
3003 we cannot give it a flavor yet. */
3004 else if (sym->ns == gfc_current_ns->parent
3005 && sym->ts.type == BT_UNKNOWN)
3008 /* These are definitive indicators that this is a variable. */
3009 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3010 || sym->attr.pointer || sym->as != NULL)
3011 flavor = FL_VARIABLE;
3013 if (flavor != FL_UNKNOWN
3014 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3022 gfc_error ("Named constant at %C in an EQUIVALENCE");
3025 /* Otherwise this is checked for and an error given in the
3026 variable definition context checks. */
3030 /* Check for a nonrecursive function result variable. */
3031 if (sym->attr.function
3032 && !sym->attr.external
3033 && sym->result == sym
3034 && (gfc_is_function_return_value (sym, gfc_current_ns)
3036 && sym->ns == gfc_current_ns)
3038 && sym->ns == gfc_current_ns->parent)))
3040 /* If a function result is a derived type, then the derived
3041 type may still have to be resolved. */
3043 if (sym->ts.type == BT_DERIVED
3044 && gfc_use_derived (sym->ts.u.derived) == NULL)
3049 if (sym->attr.proc_pointer
3050 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3053 /* Fall through to error */
3056 gfc_error ("'%s' at %C is not a variable", sym->name);
3060 /* Special case for derived type variables that get their types
3061 via an IMPLICIT statement. This can't wait for the
3062 resolution phase. */
3065 gfc_namespace * implicit_ns;
3067 if (gfc_current_ns->proc_name == sym)
3068 implicit_ns = gfc_current_ns;
3070 implicit_ns = sym->ns;
3072 if (gfc_peek_ascii_char () == '%'
3073 && sym->ts.type == BT_UNKNOWN
3074 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3075 gfc_set_default_type (sym, 0, implicit_ns);
3078 expr = gfc_get_expr ();
3080 expr->expr_type = EXPR_VARIABLE;
3083 expr->where = where;
3085 /* Now see if we have to do more. */
3086 m = gfc_match_varspec (expr, equiv_flag, false, false);
3089 gfc_free_expr (expr);
3099 gfc_match_variable (gfc_expr **result, int equiv_flag)
3101 return match_variable (result, equiv_flag, 1);
3106 gfc_match_equiv_variable (gfc_expr **result)
3108 return match_variable (result, 1, 0);