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);
2170 /* Translate the component list into the actual constructor by sorting it in
2171 the order required; this also checks along the way that each and every
2172 component actually has an initializer and handles default initializers
2173 for components without explicit value given. */
2175 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2176 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2178 gfc_structure_ctor_component *comp_iter;
2179 gfc_component *comp;
2181 for (comp = sym->components; comp; comp = comp->next)
2183 gfc_structure_ctor_component **next_ptr;
2184 gfc_expr *value = NULL;
2186 /* Try to find the initializer for the current component by name. */
2187 next_ptr = comp_head;
2188 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2190 if (!strcmp (comp_iter->name, comp->name))
2192 next_ptr = &comp_iter->next;
2195 /* If an extension, try building the parent derived type by building
2196 a value expression for the parent derived type and calling self. */
2197 if (!comp_iter && comp == sym->components && sym->attr.extension)
2199 value = gfc_get_structure_constructor_expr (comp->ts.type,
2201 &gfc_current_locus);
2202 value->ts = comp->ts;
2204 if (build_actual_constructor (comp_head, &value->value.constructor,
2205 comp->ts.u.derived) == FAILURE)
2207 gfc_free_expr (value);
2211 gfc_constructor_append_expr (ctor_head, value, NULL);
2215 /* If it was not found, try the default initializer if there's any;
2216 otherwise, it's an error. */
2219 if (comp->initializer)
2221 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2222 " constructor with missing optional arguments"
2223 " at %C") == FAILURE)
2225 value = gfc_copy_expr (comp->initializer);
2229 gfc_error ("No initializer for component '%s' given in the"
2230 " structure constructor at %C!", comp->name);
2235 value = comp_iter->val;
2237 /* Add the value to the constructor chain built. */
2238 gfc_constructor_append_expr (ctor_head, value, NULL);
2240 /* Remove the entry from the component list. We don't want the expression
2241 value to be free'd, so set it to NULL. */
2244 *next_ptr = comp_iter->next;
2245 comp_iter->val = NULL;
2246 gfc_free_structure_ctor_component (comp_iter);
2253 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2256 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2257 gfc_constructor_base ctor_head = NULL;
2258 gfc_component *comp; /* Is set NULL when named component is first seen */
2262 const char* last_name = NULL;
2264 comp_tail = comp_head = NULL;
2266 if (!parent && gfc_match_char ('(') != MATCH_YES)
2269 where = gfc_current_locus;
2271 gfc_find_component (sym, NULL, false, true);
2273 /* Check that we're not about to construct an ABSTRACT type. */
2274 if (!parent && sym->attr.abstract)
2276 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2280 /* Match the component list and store it in a list together with the
2281 corresponding component names. Check for empty argument list first. */
2282 if (gfc_match_char (')') != MATCH_YES)
2284 comp = sym->components;
2287 gfc_component *this_comp = NULL;
2290 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2293 comp_tail->next = gfc_get_structure_ctor_component ();
2294 comp_tail = comp_tail->next;
2296 comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2297 comp_tail->val = NULL;
2298 comp_tail->where = gfc_current_locus;
2300 /* Try matching a component name. */
2301 if (gfc_match_name (comp_tail->name) == MATCH_YES
2302 && gfc_match_char ('=') == MATCH_YES)
2304 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2305 " constructor with named arguments at %C")
2309 last_name = comp_tail->name;
2314 /* Components without name are not allowed after the first named
2315 component initializer! */
2319 gfc_error ("Component initializer without name after"
2320 " component named %s at %C!", last_name);
2322 gfc_error ("Too many components in structure constructor at"
2327 gfc_current_locus = comp_tail->where;
2328 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2331 /* Find the current component in the structure definition and check
2332 its access is not private. */
2334 this_comp = gfc_find_component (sym, comp->name, false, false);
2337 this_comp = gfc_find_component (sym,
2338 (const char *)comp_tail->name,
2340 comp = NULL; /* Reset needed! */
2343 /* Here we can check if a component name is given which does not
2344 correspond to any component of the defined structure. */
2348 /* Check if this component is already given a value. */
2349 for (comp_iter = comp_head; comp_iter != comp_tail;
2350 comp_iter = comp_iter->next)
2352 gcc_assert (comp_iter);
2353 if (!strcmp (comp_iter->name, comp_tail->name))
2355 gfc_error ("Component '%s' is initialized twice in the"
2356 " structure constructor at %C!", comp_tail->name);
2361 /* Match the current initializer expression. */
2362 m = gfc_match_expr (&comp_tail->val);
2365 if (m == MATCH_ERROR)
2368 /* F2008, R457/C725, for PURE C1283. */
2369 if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
2371 gfc_error ("Coindexed expression to pointer component '%s' in "
2372 "structure constructor at %C!", comp_tail->name);
2377 /* If not explicitly a parent constructor, gather up the components
2379 if (comp && comp == sym->components
2380 && sym->attr.extension
2381 && (comp_tail->val->ts.type != BT_DERIVED
2383 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2385 gfc_current_locus = where;
2386 gfc_free_expr (comp_tail->val);
2387 comp_tail->val = NULL;
2389 m = gfc_match_structure_constructor (comp->ts.u.derived,
2390 &comp_tail->val, true);
2393 if (m == MATCH_ERROR)
2400 if (parent && !comp)
2404 while (gfc_match_char (',') == MATCH_YES);
2406 if (!parent && gfc_match_char (')') != MATCH_YES)
2410 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2413 /* No component should be left, as this should have caused an error in the
2414 loop constructing the component-list (name that does not correspond to any
2415 component in the structure definition). */
2416 if (comp_head && sym->attr.extension)
2418 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2420 gfc_error ("component '%s' at %L has already been set by a "
2421 "parent derived type constructor", comp_iter->name,
2427 gcc_assert (!comp_head);
2429 e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
2430 e->ts.u.derived = sym;
2431 e->value.constructor = ctor_head;
2437 gfc_error ("Syntax error in structure constructor at %C");
2440 for (comp_iter = comp_head; comp_iter; )
2442 gfc_structure_ctor_component *next = comp_iter->next;
2443 gfc_free_structure_ctor_component (comp_iter);
2446 gfc_constructor_free (ctor_head);
2451 /* If the symbol is an implicit do loop index and implicitly typed,
2452 it should not be host associated. Provide a symtree from the
2453 current namespace. */
2455 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2457 if ((*sym)->attr.flavor == FL_VARIABLE
2458 && (*sym)->ns != gfc_current_ns
2459 && (*sym)->attr.implied_index
2460 && (*sym)->attr.implicit_type
2461 && !(*sym)->attr.use_assoc)
2464 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2467 *sym = (*st)->n.sym;
2473 /* Procedure pointer as function result: Replace the function symbol by the
2474 auto-generated hidden result variable named "ppr@". */
2477 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2479 /* Check for procedure pointer result variable. */
2480 if ((*sym)->attr.function && !(*sym)->attr.external
2481 && (*sym)->result && (*sym)->result != *sym
2482 && (*sym)->result->attr.proc_pointer
2483 && (*sym) == gfc_current_ns->proc_name
2484 && (*sym) == (*sym)->result->ns->proc_name
2485 && strcmp ("ppr@", (*sym)->result->name) == 0)
2487 /* Automatic replacement with "hidden" result variable. */
2488 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2489 *sym = (*sym)->result;
2490 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2497 /* Matches a variable name followed by anything that might follow it--
2498 array reference, argument list of a function, etc. */
2501 gfc_match_rvalue (gfc_expr **result)
2503 gfc_actual_arglist *actual_arglist;
2504 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2507 gfc_symtree *symtree;
2508 locus where, old_loc;
2516 m = gfc_match_name (name);
2520 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2521 && !gfc_current_ns->has_import_set)
2522 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2524 i = gfc_get_ha_sym_tree (name, &symtree);
2529 sym = symtree->n.sym;
2531 where = gfc_current_locus;
2533 replace_hidden_procptr_result (&sym, &symtree);
2535 /* If this is an implicit do loop index and implicitly typed,
2536 it should not be host associated. */
2537 m = check_for_implicit_index (&symtree, &sym);
2541 gfc_set_sym_referenced (sym);
2542 sym->attr.implied_index = 0;
2544 if (sym->attr.function && sym->result == sym)
2546 /* See if this is a directly recursive function call. */
2547 gfc_gobble_whitespace ();
2548 if (sym->attr.recursive
2549 && gfc_peek_ascii_char () == '('
2550 && gfc_current_ns->proc_name == sym
2551 && !sym->attr.dimension)
2553 gfc_error ("'%s' at %C is the name of a recursive function "
2554 "and so refers to the result variable. Use an "
2555 "explicit RESULT variable for direct recursion "
2556 "(12.5.2.1)", sym->name);
2560 if (gfc_is_function_return_value (sym, gfc_current_ns))
2564 && (sym->ns == gfc_current_ns
2565 || sym->ns == gfc_current_ns->parent))
2567 gfc_entry_list *el = NULL;
2569 for (el = sym->ns->entries; el; el = el->next)
2575 if (gfc_matching_procptr_assignment)
2578 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2581 if (sym->attr.generic)
2582 goto generic_function;
2584 switch (sym->attr.flavor)
2588 e = gfc_get_expr ();
2590 e->expr_type = EXPR_VARIABLE;
2591 e->symtree = symtree;
2593 m = gfc_match_varspec (e, 0, false, true);
2597 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2598 end up here. Unfortunately, sym->value->expr_type is set to
2599 EXPR_CONSTANT, and so the if () branch would be followed without
2600 the !sym->as check. */
2601 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2602 e = gfc_copy_expr (sym->value);
2605 e = gfc_get_expr ();
2606 e->expr_type = EXPR_VARIABLE;
2609 e->symtree = symtree;
2610 m = gfc_match_varspec (e, 0, false, true);
2612 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2615 /* Variable array references to derived type parameters cause
2616 all sorts of headaches in simplification. Treating such
2617 expressions as variable works just fine for all array
2619 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2621 for (ref = e->ref; ref; ref = ref->next)
2622 if (ref->type == REF_ARRAY)
2625 if (ref == NULL || ref->u.ar.type == AR_FULL)
2631 e = gfc_get_expr ();
2632 e->expr_type = EXPR_VARIABLE;
2633 e->symtree = symtree;
2640 sym = gfc_use_derived (sym);
2644 m = gfc_match_structure_constructor (sym, &e, false);
2647 /* If we're here, then the name is known to be the name of a
2648 procedure, yet it is not sure to be the name of a function. */
2651 /* Procedure Pointer Assignments. */
2653 if (gfc_matching_procptr_assignment)
2655 gfc_gobble_whitespace ();
2656 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2657 /* Parse functions returning a procptr. */
2660 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2661 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2662 sym->attr.intrinsic = 1;
2663 e = gfc_get_expr ();
2664 e->expr_type = EXPR_VARIABLE;
2665 e->symtree = symtree;
2666 m = gfc_match_varspec (e, 0, false, true);
2670 if (sym->attr.subroutine)
2672 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2678 /* At this point, the name has to be a non-statement function.
2679 If the name is the same as the current function being
2680 compiled, then we have a variable reference (to the function
2681 result) if the name is non-recursive. */
2683 st = gfc_enclosing_unit (NULL);
2685 if (st != NULL && st->state == COMP_FUNCTION
2687 && !sym->attr.recursive)
2689 e = gfc_get_expr ();
2690 e->symtree = symtree;
2691 e->expr_type = EXPR_VARIABLE;
2693 m = gfc_match_varspec (e, 0, false, true);
2697 /* Match a function reference. */
2699 m = gfc_match_actual_arglist (0, &actual_arglist);
2702 if (sym->attr.proc == PROC_ST_FUNCTION)
2703 gfc_error ("Statement function '%s' requires argument list at %C",
2706 gfc_error ("Function '%s' requires an argument list at %C",
2719 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2720 sym = symtree->n.sym;
2722 replace_hidden_procptr_result (&sym, &symtree);
2724 e = gfc_get_expr ();
2725 e->symtree = symtree;
2726 e->expr_type = EXPR_FUNCTION;
2727 e->value.function.actual = actual_arglist;
2728 e->where = gfc_current_locus;
2730 if (sym->as != NULL)
2731 e->rank = sym->as->rank;
2733 if (!sym->attr.function
2734 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2740 /* Check here for the existence of at least one argument for the
2741 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2742 argument(s) given will be checked in gfc_iso_c_func_interface,
2743 during resolution of the function call. */
2744 if (sym->attr.is_iso_c == 1
2745 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2746 && (sym->intmod_sym_id == ISOCBINDING_LOC
2747 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2748 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2750 /* make sure we were given a param */
2751 if (actual_arglist == NULL)
2753 gfc_error ("Missing argument to '%s' at %C", sym->name);
2759 if (sym->result == NULL)
2767 /* Special case for derived type variables that get their types
2768 via an IMPLICIT statement. This can't wait for the
2769 resolution phase. */
2771 if (gfc_peek_ascii_char () == '%'
2772 && sym->ts.type == BT_UNKNOWN
2773 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2774 gfc_set_default_type (sym, 0, sym->ns);
2776 /* If the symbol has a dimension attribute, the expression is a
2779 if (sym->attr.dimension)
2781 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2782 sym->name, NULL) == FAILURE)
2788 e = gfc_get_expr ();
2789 e->symtree = symtree;
2790 e->expr_type = EXPR_VARIABLE;
2791 m = gfc_match_varspec (e, 0, false, true);
2795 /* Name is not an array, so we peek to see if a '(' implies a
2796 function call or a substring reference. Otherwise the
2797 variable is just a scalar. */
2799 gfc_gobble_whitespace ();
2800 if (gfc_peek_ascii_char () != '(')
2802 /* Assume a scalar variable */
2803 e = gfc_get_expr ();
2804 e->symtree = symtree;
2805 e->expr_type = EXPR_VARIABLE;
2807 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2808 sym->name, NULL) == FAILURE)
2814 /*FIXME:??? gfc_match_varspec does set this for us: */
2816 m = gfc_match_varspec (e, 0, false, true);
2820 /* See if this is a function reference with a keyword argument
2821 as first argument. We do this because otherwise a spurious
2822 symbol would end up in the symbol table. */
2824 old_loc = gfc_current_locus;
2825 m2 = gfc_match (" ( %n =", argname);
2826 gfc_current_locus = old_loc;
2828 e = gfc_get_expr ();
2829 e->symtree = symtree;
2831 if (m2 != MATCH_YES)
2833 /* Try to figure out whether we're dealing with a character type.
2834 We're peeking ahead here, because we don't want to call
2835 match_substring if we're dealing with an implicitly typed
2836 non-character variable. */
2837 implicit_char = false;
2838 if (sym->ts.type == BT_UNKNOWN)
2840 ts = gfc_get_default_type (sym->name, NULL);
2841 if (ts->type == BT_CHARACTER)
2842 implicit_char = true;
2845 /* See if this could possibly be a substring reference of a name
2846 that we're not sure is a variable yet. */
2848 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2849 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2852 e->expr_type = EXPR_VARIABLE;
2854 if (sym->attr.flavor != FL_VARIABLE
2855 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2856 sym->name, NULL) == FAILURE)
2862 if (sym->ts.type == BT_UNKNOWN
2863 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2877 /* Give up, assume we have a function. */
2879 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2880 sym = symtree->n.sym;
2881 e->expr_type = EXPR_FUNCTION;
2883 if (!sym->attr.function
2884 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2892 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2894 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2902 /* If our new function returns a character, array or structure
2903 type, it might have subsequent references. */
2905 m = gfc_match_varspec (e, 0, false, true);
2912 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2914 e = gfc_get_expr ();
2915 e->symtree = symtree;
2916 e->expr_type = EXPR_FUNCTION;
2918 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2922 gfc_error ("Symbol at %C is not appropriate for an expression");
2938 /* Match a variable, i.e. something that can be assigned to. This
2939 starts as a symbol, can be a structure component or an array
2940 reference. It can be a function if the function doesn't have a
2941 separate RESULT variable. If the symbol has not been previously
2942 seen, we assume it is a variable.
2944 This function is called by two interface functions:
2945 gfc_match_variable, which has host_flag = 1, and
2946 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2947 match of the symbol to the local scope. */
2950 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2958 /* Since nothing has any business being an lvalue in a module
2959 specification block, an interface block or a contains section,
2960 we force the changed_symbols mechanism to work by setting
2961 host_flag to 0. This prevents valid symbols that have the name
2962 of keywords, such as 'end', being turned into variables by
2963 failed matching to assignments for, e.g., END INTERFACE. */
2964 if (gfc_current_state () == COMP_MODULE
2965 || gfc_current_state () == COMP_INTERFACE
2966 || gfc_current_state () == COMP_CONTAINS)
2969 where = gfc_current_locus;
2970 m = gfc_match_sym_tree (&st, host_flag);
2976 /* If this is an implicit do loop index and implicitly typed,
2977 it should not be host associated. */
2978 m = check_for_implicit_index (&st, &sym);
2982 sym->attr.implied_index = 0;
2984 gfc_set_sym_referenced (sym);
2985 switch (sym->attr.flavor)
2988 /* Everything is alright. */
2993 sym_flavor flavor = FL_UNKNOWN;
2995 gfc_gobble_whitespace ();
2997 if (sym->attr.external || sym->attr.procedure
2998 || sym->attr.function || sym->attr.subroutine)
2999 flavor = FL_PROCEDURE;
3001 /* If it is not a procedure, is not typed and is host associated,
3002 we cannot give it a flavor yet. */
3003 else if (sym->ns == gfc_current_ns->parent
3004 && sym->ts.type == BT_UNKNOWN)
3007 /* These are definitive indicators that this is a variable. */
3008 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3009 || sym->attr.pointer || sym->as != NULL)
3010 flavor = FL_VARIABLE;
3012 if (flavor != FL_UNKNOWN
3013 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3021 gfc_error ("Named constant at %C in an EQUIVALENCE");
3024 /* Otherwise this is checked for and an error given in the
3025 variable definition context checks. */
3029 /* Check for a nonrecursive function result variable. */
3030 if (sym->attr.function
3031 && !sym->attr.external
3032 && sym->result == sym
3033 && (gfc_is_function_return_value (sym, gfc_current_ns)
3035 && sym->ns == gfc_current_ns)
3037 && sym->ns == gfc_current_ns->parent)))
3039 /* If a function result is a derived type, then the derived
3040 type may still have to be resolved. */
3042 if (sym->ts.type == BT_DERIVED
3043 && gfc_use_derived (sym->ts.u.derived) == NULL)
3048 if (sym->attr.proc_pointer
3049 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3052 /* Fall through to error */
3055 gfc_error ("'%s' at %C is not a variable", sym->name);
3059 /* Special case for derived type variables that get their types
3060 via an IMPLICIT statement. This can't wait for the
3061 resolution phase. */
3064 gfc_namespace * implicit_ns;
3066 if (gfc_current_ns->proc_name == sym)
3067 implicit_ns = gfc_current_ns;
3069 implicit_ns = sym->ns;
3071 if (gfc_peek_ascii_char () == '%'
3072 && sym->ts.type == BT_UNKNOWN
3073 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3074 gfc_set_default_type (sym, 0, implicit_ns);
3077 expr = gfc_get_expr ();
3079 expr->expr_type = EXPR_VARIABLE;
3082 expr->where = where;
3084 /* Now see if we have to do more. */
3085 m = gfc_match_varspec (expr, equiv_flag, false, false);
3088 gfc_free_expr (expr);
3098 gfc_match_variable (gfc_expr **result, int equiv_flag)
3100 return match_variable (result, equiv_flag, 1);
3105 gfc_match_equiv_variable (gfc_expr **result)
3107 return match_variable (result, 1, 0);