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/>. */
30 #include "constructor.h"
32 /* Matches a kind-parameter expression, which is either a named
33 symbolic constant or a nonnegative integer constant. If
34 successful, sets the kind value to the correct integer. */
37 match_kind_param (int *kind)
39 char name[GFC_MAX_SYMBOL_LEN + 1];
44 m = gfc_match_small_literal_int (kind, NULL);
48 m = gfc_match_name (name);
52 if (gfc_find_symbol (name, NULL, 1, &sym))
58 if (sym->attr.flavor != FL_PARAMETER)
61 if (sym->value == NULL)
64 p = gfc_extract_int (sym->value, kind);
68 gfc_set_sym_referenced (sym);
77 /* Get a trailing kind-specification for non-character variables.
79 the integer kind value or:
80 -1 if an error was generated
81 -2 if no kind was found */
89 if (gfc_match_char ('_') != MATCH_YES)
92 m = match_kind_param (&kind);
94 gfc_error ("Missing kind-parameter at %C");
96 return (m == MATCH_YES) ? kind : -1;
100 /* Given a character and a radix, see if the character is a valid
101 digit in that radix. */
104 gfc_check_digit (char c, int radix)
111 r = ('0' <= c && c <= '1');
115 r = ('0' <= c && c <= '7');
119 r = ('0' <= c && c <= '9');
127 gfc_internal_error ("gfc_check_digit(): bad radix");
134 /* Match the digit string part of an integer if signflag is not set,
135 the signed digit string part if signflag is set. If the buffer
136 is NULL, we just count characters for the resolution pass. Returns
137 the number of characters matched, -1 for no match. */
140 match_digits (int signflag, int radix, char *buffer)
147 c = gfc_next_ascii_char ();
149 if (signflag && (c == '+' || c == '-'))
153 gfc_gobble_whitespace ();
154 c = gfc_next_ascii_char ();
158 if (!gfc_check_digit (c, radix))
167 old_loc = gfc_current_locus;
168 c = gfc_next_ascii_char ();
170 if (!gfc_check_digit (c, radix))
178 gfc_current_locus = old_loc;
184 /* Match an integer (digit string and optional kind).
185 A sign will be accepted if signflag is set. */
188 match_integer_constant (gfc_expr **result, int signflag)
195 old_loc = gfc_current_locus;
196 gfc_gobble_whitespace ();
198 length = match_digits (signflag, 10, NULL);
199 gfc_current_locus = old_loc;
203 buffer = (char *) alloca (length + 1);
204 memset (buffer, '\0', length + 1);
206 gfc_gobble_whitespace ();
208 match_digits (signflag, 10, buffer);
212 kind = gfc_default_integer_kind;
216 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
218 gfc_error ("Integer kind %d at %C not available", kind);
222 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
224 if (gfc_range_check (e) != ARITH_OK)
226 gfc_error ("Integer too big for its kind at %C. This check can be "
227 "disabled with the option -fno-range-check");
238 /* Match a Hollerith constant. */
241 match_hollerith_constant (gfc_expr **result)
249 old_loc = gfc_current_locus;
250 gfc_gobble_whitespace ();
252 if (match_integer_constant (&e, 0) == MATCH_YES
253 && gfc_match_char ('h') == MATCH_YES)
255 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
259 msg = gfc_extract_int (e, &num);
267 gfc_error ("Invalid Hollerith constant: %L must contain at least "
268 "one character", &old_loc);
271 if (e->ts.kind != gfc_default_integer_kind)
273 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
274 "should be default", &old_loc);
280 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
283 e->representation.string = XCNEWVEC (char, num + 1);
285 for (i = 0; i < num; i++)
287 gfc_char_t c = gfc_next_char_literal (1);
288 if (! gfc_wide_fits_in_byte (c))
290 gfc_error ("Invalid Hollerith constant at %L contains a "
291 "wide character", &old_loc);
295 e->representation.string[i] = (unsigned char) c;
298 e->representation.string[num] = '\0';
299 e->representation.length = num;
307 gfc_current_locus = old_loc;
316 /* Match a binary, octal or hexadecimal constant that can be found in
317 a DATA statement. The standard permits b'010...', o'73...', and
318 z'a1...' where b, o, and z can be capital letters. This function
319 also accepts postfixed forms of the constants: '01...'b, '73...'o,
320 and 'a1...'z. An additional extension is the use of x for z. */
323 match_boz_constant (gfc_expr **result)
325 int radix, length, x_hex, kind;
326 locus old_loc, start_loc;
327 char *buffer, post, delim;
330 start_loc = old_loc = gfc_current_locus;
331 gfc_gobble_whitespace ();
334 switch (post = gfc_next_ascii_char ())
356 radix = 16; /* Set to accept any valid digit string. */
362 /* No whitespace allowed here. */
365 delim = gfc_next_ascii_char ();
367 if (delim != '\'' && delim != '\"')
371 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
372 "constant at %C uses non-standard syntax")
376 old_loc = gfc_current_locus;
378 length = match_digits (0, radix, NULL);
381 gfc_error ("Empty set of digits in BOZ constant at %C");
385 if (gfc_next_ascii_char () != delim)
387 gfc_error ("Illegal character in BOZ constant at %C");
393 switch (gfc_next_ascii_char ())
410 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
411 "at %C uses non-standard postfix syntax")
416 gfc_current_locus = old_loc;
418 buffer = (char *) alloca (length + 1);
419 memset (buffer, '\0', length + 1);
421 match_digits (0, radix, buffer);
422 gfc_next_ascii_char (); /* Eat delimiter. */
424 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
426 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
427 "If a data-stmt-constant is a boz-literal-constant, the corresponding
428 variable shall be of type integer. The boz-literal-constant is treated
429 as if it were an int-literal-constant with a kind-param that specifies
430 the representation method with the largest decimal exponent range
431 supported by the processor." */
433 kind = gfc_max_integer_kind;
434 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
436 /* Mark as boz variable. */
439 if (gfc_range_check (e) != ARITH_OK)
441 gfc_error ("Integer too big for integer kind %i at %C", kind);
446 if (!gfc_in_match_data ()
447 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
456 gfc_current_locus = start_loc;
461 /* Match a real constant of some sort. Allow a signed constant if signflag
465 match_real_constant (gfc_expr **result, int signflag)
467 int kind, count, seen_dp, seen_digits;
468 locus old_loc, temp_loc;
469 char *p, *buffer, c, exp_char;
473 old_loc = gfc_current_locus;
474 gfc_gobble_whitespace ();
484 c = gfc_next_ascii_char ();
485 if (signflag && (c == '+' || c == '-'))
490 gfc_gobble_whitespace ();
491 c = gfc_next_ascii_char ();
494 /* Scan significand. */
495 for (;; c = gfc_next_ascii_char (), count++)
502 /* Check to see if "." goes with a following operator like
504 temp_loc = gfc_current_locus;
505 c = gfc_next_ascii_char ();
507 if (c == 'e' || c == 'd' || c == 'q')
509 c = gfc_next_ascii_char ();
511 goto done; /* Operator named .e. or .d. */
515 goto done; /* Distinguish 1.e9 from 1.eq.2 */
517 gfc_current_locus = temp_loc;
531 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
536 c = gfc_next_ascii_char ();
539 if (c == '+' || c == '-')
540 { /* optional sign */
541 c = gfc_next_ascii_char ();
547 gfc_error ("Missing exponent in real number at %C");
553 c = gfc_next_ascii_char ();
558 /* Check that we have a numeric constant. */
559 if (!seen_digits || (!seen_dp && exp_char == ' '))
561 gfc_current_locus = old_loc;
565 /* Convert the number. */
566 gfc_current_locus = old_loc;
567 gfc_gobble_whitespace ();
569 buffer = (char *) alloca (count + 1);
570 memset (buffer, '\0', count + 1);
573 c = gfc_next_ascii_char ();
574 if (c == '+' || c == '-')
576 gfc_gobble_whitespace ();
577 c = gfc_next_ascii_char ();
580 /* Hack for mpfr_set_str(). */
583 if (c == 'd' || c == 'q')
591 c = gfc_next_ascii_char ();
603 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
607 kind = gfc_default_double_kind;
612 kind = gfc_default_real_kind;
614 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
616 gfc_error ("Invalid real kind %d at %C", kind);
621 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
623 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
625 switch (gfc_range_check (e))
630 gfc_error ("Real constant overflows its kind at %C");
633 case ARITH_UNDERFLOW:
634 if (gfc_option.warn_underflow)
635 gfc_warning ("Real constant underflows its kind at %C");
636 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
640 gfc_internal_error ("gfc_range_check() returned bad value");
652 /* Match a substring reference. */
655 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
657 gfc_expr *start, *end;
665 old_loc = gfc_current_locus;
667 m = gfc_match_char ('(');
671 if (gfc_match_char (':') != MATCH_YES)
674 m = gfc_match_init_expr (&start);
676 m = gfc_match_expr (&start);
684 m = gfc_match_char (':');
689 if (gfc_match_char (')') != MATCH_YES)
692 m = gfc_match_init_expr (&end);
694 m = gfc_match_expr (&end);
698 if (m == MATCH_ERROR)
701 m = gfc_match_char (')');
706 /* Optimize away the (:) reference. */
707 if (start == NULL && end == NULL)
711 ref = gfc_get_ref ();
713 ref->type = REF_SUBSTRING;
715 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
716 ref->u.ss.start = start;
717 if (end == NULL && cl)
718 end = gfc_copy_expr (cl->length);
720 ref->u.ss.length = cl;
727 gfc_error ("Syntax error in SUBSTRING specification at %C");
731 gfc_free_expr (start);
734 gfc_current_locus = old_loc;
739 /* Reads the next character of a string constant, taking care to
740 return doubled delimiters on the input as a single instance of
743 Special return values for "ret" argument are:
744 -1 End of the string, as determined by the delimiter
745 -2 Unterminated string detected
747 Backslash codes are also expanded at this time. */
750 next_string_char (gfc_char_t delimiter, int *ret)
755 c = gfc_next_char_literal (1);
764 if (gfc_option.flag_backslash && c == '\\')
766 old_locus = gfc_current_locus;
768 if (gfc_match_special_char (&c) == MATCH_NO)
769 gfc_current_locus = old_locus;
771 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
772 gfc_warning ("Extension: backslash character at %C");
778 old_locus = gfc_current_locus;
779 c = gfc_next_char_literal (0);
783 gfc_current_locus = old_locus;
790 /* Special case of gfc_match_name() that matches a parameter kind name
791 before a string constant. This takes case of the weird but legal
796 where kind____ is a parameter. gfc_match_name() will happily slurp
797 up all the underscores, which leads to problems. If we return
798 MATCH_YES, the parse pointer points to the final underscore, which
799 is not part of the name. We never return MATCH_ERROR-- errors in
800 the name will be detected later. */
803 match_charkind_name (char *name)
809 gfc_gobble_whitespace ();
810 c = gfc_next_ascii_char ();
819 old_loc = gfc_current_locus;
820 c = gfc_next_ascii_char ();
824 peek = gfc_peek_ascii_char ();
826 if (peek == '\'' || peek == '\"')
828 gfc_current_locus = old_loc;
836 && (c != '$' || !gfc_option.flag_dollar_ok))
840 if (++len > GFC_MAX_SYMBOL_LEN)
848 /* See if the current input matches a character constant. Lots of
849 contortions have to be done to match the kind parameter which comes
850 before the actual string. The main consideration is that we don't
851 want to error out too quickly. For example, we don't actually do
852 any validation of the kinds until we have actually seen a legal
853 delimiter. Using match_kind_param() generates errors too quickly. */
856 match_string_constant (gfc_expr **result)
858 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
859 int i, kind, length, warn_ampersand, ret;
860 locus old_locus, start_locus;
865 gfc_char_t c, delimiter, *p;
867 old_locus = gfc_current_locus;
869 gfc_gobble_whitespace ();
871 c = gfc_next_char ();
872 if (c == '\'' || c == '"')
874 kind = gfc_default_character_kind;
875 start_locus = gfc_current_locus;
879 if (gfc_wide_is_digit (c))
883 while (gfc_wide_is_digit (c))
885 kind = kind * 10 + c - '0';
888 c = gfc_next_char ();
894 gfc_current_locus = old_locus;
896 m = match_charkind_name (name);
900 if (gfc_find_symbol (name, NULL, 1, &sym)
902 || sym->attr.flavor != FL_PARAMETER)
906 c = gfc_next_char ();
911 gfc_gobble_whitespace ();
912 c = gfc_next_char ();
918 gfc_gobble_whitespace ();
920 c = gfc_next_char ();
921 if (c != '\'' && c != '"')
924 start_locus = gfc_current_locus;
928 q = gfc_extract_int (sym->value, &kind);
934 gfc_set_sym_referenced (sym);
937 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
939 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
944 /* Scan the string into a block of memory by first figuring out how
945 long it is, allocating the structure, then re-reading it. This
946 isn't particularly efficient, but string constants aren't that
947 common in most code. TODO: Use obstacks? */
954 c = next_string_char (delimiter, &ret);
959 gfc_current_locus = start_locus;
960 gfc_error ("Unterminated character constant beginning at %C");
967 /* Peek at the next character to see if it is a b, o, z, or x for the
968 postfixed BOZ literal constants. */
969 peek = gfc_peek_ascii_char ();
970 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
973 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
975 e->ts.is_c_interop = 0;
978 gfc_current_locus = start_locus;
980 /* We disable the warning for the following loop as the warning has already
981 been printed in the loop above. */
982 warn_ampersand = gfc_option.warn_ampersand;
983 gfc_option.warn_ampersand = 0;
985 p = e->value.character.string;
986 for (i = 0; i < length; i++)
988 c = next_string_char (delimiter, &ret);
990 if (!gfc_check_character_range (c, kind))
992 gfc_error ("Character '%s' in string at %C is not representable "
993 "in character kind %d", gfc_print_wide_char (c), kind);
1000 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1001 gfc_option.warn_ampersand = warn_ampersand;
1003 next_string_char (delimiter, &ret);
1005 gfc_internal_error ("match_string_constant(): Delimiter not found");
1007 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1008 e->expr_type = EXPR_SUBSTRING;
1015 gfc_current_locus = old_locus;
1020 /* Match a .true. or .false. Returns 1 if a .true. was found,
1021 0 if a .false. was found, and -1 otherwise. */
1023 match_logical_constant_string (void)
1025 locus orig_loc = gfc_current_locus;
1027 gfc_gobble_whitespace ();
1028 if (gfc_next_ascii_char () == '.')
1030 char ch = gfc_next_ascii_char ();
1033 if (gfc_next_ascii_char () == 'a'
1034 && gfc_next_ascii_char () == 'l'
1035 && gfc_next_ascii_char () == 's'
1036 && gfc_next_ascii_char () == 'e'
1037 && gfc_next_ascii_char () == '.')
1038 /* Matched ".false.". */
1043 if (gfc_next_ascii_char () == 'r'
1044 && gfc_next_ascii_char () == 'u'
1045 && gfc_next_ascii_char () == 'e'
1046 && gfc_next_ascii_char () == '.')
1047 /* Matched ".true.". */
1051 gfc_current_locus = orig_loc;
1055 /* Match a .true. or .false. */
1058 match_logical_constant (gfc_expr **result)
1063 i = match_logical_constant_string ();
1071 kind = gfc_default_logical_kind;
1073 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1075 gfc_error ("Bad kind for logical constant at %C");
1079 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1080 e->ts.is_c_interop = 0;
1088 /* Match a real or imaginary part of a complex constant that is a
1089 symbolic constant. */
1092 match_sym_complex_part (gfc_expr **result)
1094 char name[GFC_MAX_SYMBOL_LEN + 1];
1099 m = gfc_match_name (name);
1103 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1106 if (sym->attr.flavor != FL_PARAMETER)
1108 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1112 if (!gfc_numeric_ts (&sym->value->ts))
1114 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1118 if (sym->value->rank != 0)
1120 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1124 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1125 "complex constant at %C") == FAILURE)
1128 switch (sym->value->ts.type)
1131 e = gfc_copy_expr (sym->value);
1135 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1141 e = gfc_int2real (sym->value, gfc_default_real_kind);
1147 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1150 *result = e; /* e is a scalar, real, constant expression. */
1154 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1159 /* Match a real or imaginary part of a complex number. */
1162 match_complex_part (gfc_expr **result)
1166 m = match_sym_complex_part (result);
1170 m = match_real_constant (result, 1);
1174 return match_integer_constant (result, 1);
1178 /* Try to match a complex constant. */
1181 match_complex_constant (gfc_expr **result)
1183 gfc_expr *e, *real, *imag;
1184 gfc_error_buf old_error;
1185 gfc_typespec target;
1190 old_loc = gfc_current_locus;
1191 real = imag = e = NULL;
1193 m = gfc_match_char ('(');
1197 gfc_push_error (&old_error);
1199 m = match_complex_part (&real);
1202 gfc_free_error (&old_error);
1206 if (gfc_match_char (',') == MATCH_NO)
1208 gfc_pop_error (&old_error);
1213 /* If m is error, then something was wrong with the real part and we
1214 assume we have a complex constant because we've seen the ','. An
1215 ambiguous case here is the start of an iterator list of some
1216 sort. These sort of lists are matched prior to coming here. */
1218 if (m == MATCH_ERROR)
1220 gfc_free_error (&old_error);
1223 gfc_pop_error (&old_error);
1225 m = match_complex_part (&imag);
1228 if (m == MATCH_ERROR)
1231 m = gfc_match_char (')');
1234 /* Give the matcher for implied do-loops a chance to run. This
1235 yields a much saner error message for (/ (i, 4=i, 6) /). */
1236 if (gfc_peek_ascii_char () == '=')
1245 if (m == MATCH_ERROR)
1248 /* Decide on the kind of this complex number. */
1249 if (real->ts.type == BT_REAL)
1251 if (imag->ts.type == BT_REAL)
1252 kind = gfc_kind_max (real, imag);
1254 kind = real->ts.kind;
1258 if (imag->ts.type == BT_REAL)
1259 kind = imag->ts.kind;
1261 kind = gfc_default_real_kind;
1263 target.type = BT_REAL;
1265 target.is_c_interop = 0;
1266 target.is_iso_c = 0;
1268 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1269 gfc_convert_type (real, &target, 2);
1270 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1271 gfc_convert_type (imag, &target, 2);
1273 e = gfc_convert_complex (real, imag, kind);
1274 e->where = gfc_current_locus;
1276 gfc_free_expr (real);
1277 gfc_free_expr (imag);
1283 gfc_error ("Syntax error in COMPLEX constant at %C");
1288 gfc_free_expr (real);
1289 gfc_free_expr (imag);
1290 gfc_current_locus = old_loc;
1296 /* Match constants in any of several forms. Returns nonzero for a
1297 match, zero for no match. */
1300 gfc_match_literal_constant (gfc_expr **result, int signflag)
1304 m = match_complex_constant (result);
1308 m = match_string_constant (result);
1312 m = match_boz_constant (result);
1316 m = match_real_constant (result, signflag);
1320 m = match_hollerith_constant (result);
1324 m = match_integer_constant (result, signflag);
1328 m = match_logical_constant (result);
1336 /* This checks if a symbol is the return value of an encompassing function.
1337 Function nesting can be maximally two levels deep, but we may have
1338 additional local namespaces like BLOCK etc. */
1341 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1343 if (!sym->attr.function || (sym->result != sym))
1347 if (ns->proc_name == sym)
1355 /* Match a single actual argument value. An actual argument is
1356 usually an expression, but can also be a procedure name. If the
1357 argument is a single name, it is not always possible to tell
1358 whether the name is a dummy procedure or not. We treat these cases
1359 by creating an argument that looks like a dummy procedure and
1360 fixing things later during resolution. */
1363 match_actual_arg (gfc_expr **result)
1365 char name[GFC_MAX_SYMBOL_LEN + 1];
1366 gfc_symtree *symtree;
1371 gfc_gobble_whitespace ();
1372 where = gfc_current_locus;
1374 switch (gfc_match_name (name))
1383 w = gfc_current_locus;
1384 gfc_gobble_whitespace ();
1385 c = gfc_next_ascii_char ();
1386 gfc_current_locus = w;
1388 if (c != ',' && c != ')')
1391 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1393 /* Handle error elsewhere. */
1395 /* Eliminate a couple of common cases where we know we don't
1396 have a function argument. */
1397 if (symtree == NULL)
1399 gfc_get_sym_tree (name, NULL, &symtree, false);
1400 gfc_set_sym_referenced (symtree->n.sym);
1406 sym = symtree->n.sym;
1407 gfc_set_sym_referenced (sym);
1408 if (sym->attr.flavor != FL_PROCEDURE
1409 && sym->attr.flavor != FL_UNKNOWN)
1412 if (sym->attr.in_common && !sym->attr.proc_pointer)
1414 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1419 /* If the symbol is a function with itself as the result and
1420 is being defined, then we have a variable. */
1421 if (sym->attr.function && sym->result == sym)
1423 if (gfc_is_function_return_value (sym, gfc_current_ns))
1427 && (sym->ns == gfc_current_ns
1428 || sym->ns == gfc_current_ns->parent))
1430 gfc_entry_list *el = NULL;
1432 for (el = sym->ns->entries; el; el = el->next)
1442 e = gfc_get_expr (); /* Leave it unknown for now */
1443 e->symtree = symtree;
1444 e->expr_type = EXPR_VARIABLE;
1445 e->ts.type = BT_PROCEDURE;
1452 gfc_current_locus = where;
1453 return gfc_match_expr (result);
1457 /* Match a keyword argument. */
1460 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1462 char name[GFC_MAX_SYMBOL_LEN + 1];
1463 gfc_actual_arglist *a;
1467 name_locus = gfc_current_locus;
1468 m = gfc_match_name (name);
1472 if (gfc_match_char ('=') != MATCH_YES)
1478 m = match_actual_arg (&actual->expr);
1482 /* Make sure this name has not appeared yet. */
1484 if (name[0] != '\0')
1486 for (a = base; a; a = a->next)
1487 if (a->name != NULL && strcmp (a->name, name) == 0)
1489 gfc_error ("Keyword '%s' at %C has already appeared in the "
1490 "current argument list", name);
1495 actual->name = gfc_get_string (name);
1499 gfc_current_locus = name_locus;
1504 /* Match an argument list function, such as %VAL. */
1507 match_arg_list_function (gfc_actual_arglist *result)
1509 char name[GFC_MAX_SYMBOL_LEN + 1];
1513 old_locus = gfc_current_locus;
1515 if (gfc_match_char ('%') != MATCH_YES)
1521 m = gfc_match ("%n (", name);
1525 if (name[0] != '\0')
1530 if (strncmp (name, "loc", 3) == 0)
1532 result->name = "%LOC";
1536 if (strncmp (name, "ref", 3) == 0)
1538 result->name = "%REF";
1542 if (strncmp (name, "val", 3) == 0)
1544 result->name = "%VAL";
1553 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1554 "function at %C") == FAILURE)
1560 m = match_actual_arg (&result->expr);
1564 if (gfc_match_char (')') != MATCH_YES)
1573 gfc_current_locus = old_locus;
1578 /* Matches an actual argument list of a function or subroutine, from
1579 the opening parenthesis to the closing parenthesis. The argument
1580 list is assumed to allow keyword arguments because we don't know if
1581 the symbol associated with the procedure has an implicit interface
1582 or not. We make sure keywords are unique. If sub_flag is set,
1583 we're matching the argument list of a subroutine. */
1586 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1588 gfc_actual_arglist *head, *tail;
1590 gfc_st_label *label;
1594 *argp = tail = NULL;
1595 old_loc = gfc_current_locus;
1599 if (gfc_match_char ('(') == MATCH_NO)
1600 return (sub_flag) ? MATCH_YES : MATCH_NO;
1602 if (gfc_match_char (')') == MATCH_YES)
1609 head = tail = gfc_get_actual_arglist ();
1612 tail->next = gfc_get_actual_arglist ();
1616 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1618 m = gfc_match_st_label (&label);
1620 gfc_error ("Expected alternate return label at %C");
1624 tail->label = label;
1628 /* After the first keyword argument is seen, the following
1629 arguments must also have keywords. */
1632 m = match_keyword_arg (tail, head);
1634 if (m == MATCH_ERROR)
1638 gfc_error ("Missing keyword name in actual argument list at %C");
1645 /* Try an argument list function, like %VAL. */
1646 m = match_arg_list_function (tail);
1647 if (m == MATCH_ERROR)
1650 /* See if we have the first keyword argument. */
1653 m = match_keyword_arg (tail, head);
1656 if (m == MATCH_ERROR)
1662 /* Try for a non-keyword argument. */
1663 m = match_actual_arg (&tail->expr);
1664 if (m == MATCH_ERROR)
1673 if (gfc_match_char (')') == MATCH_YES)
1675 if (gfc_match_char (',') != MATCH_YES)
1683 gfc_error ("Syntax error in argument list at %C");
1686 gfc_free_actual_arglist (head);
1687 gfc_current_locus = old_loc;
1693 /* Used by gfc_match_varspec() to extend the reference list by one
1697 extend_ref (gfc_expr *primary, gfc_ref *tail)
1699 if (primary->ref == NULL)
1700 primary->ref = tail = gfc_get_ref ();
1704 gfc_internal_error ("extend_ref(): Bad tail");
1705 tail->next = gfc_get_ref ();
1713 /* Match any additional specifications associated with the current
1714 variable like member references or substrings. If equiv_flag is
1715 set we only match stuff that is allowed inside an EQUIVALENCE
1716 statement. sub_flag tells whether we expect a type-bound procedure found
1717 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1718 components, 'ppc_arg' determines whether the PPC may be called (with an
1719 argument list), or whether it may just be referred to as a pointer. */
1722 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1725 char name[GFC_MAX_SYMBOL_LEN + 1];
1726 gfc_ref *substring, *tail;
1727 gfc_component *component;
1728 gfc_symbol *sym = primary->symtree->n.sym;
1734 gfc_gobble_whitespace ();
1736 if (gfc_peek_ascii_char () == '[')
1738 if (sym->attr.dimension)
1740 gfc_error ("Array section designator, e.g. '(:)', is required "
1741 "besides the coarray designator '[...]' at %C");
1744 if (!sym->attr.codimension)
1746 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1752 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1753 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1754 || (sym->attr.dimension && !sym->attr.proc_pointer
1755 && !gfc_is_proc_ptr_comp (primary, NULL)
1756 && !(gfc_matching_procptr_assignment
1757 && sym->attr.flavor == FL_PROCEDURE))
1758 || (sym->ts.type == BT_CLASS
1759 && sym->ts.u.derived->components->attr.dimension))
1761 /* In EQUIVALENCE, we don't know yet whether we are seeing
1762 an array, character variable or array of character
1763 variables. We'll leave the decision till resolve time. */
1764 tail = extend_ref (primary, tail);
1765 tail->type = REF_ARRAY;
1767 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1768 equiv_flag, sym->as ? sym->as->corank : 0);
1772 gfc_gobble_whitespace ();
1773 if (equiv_flag && gfc_peek_ascii_char () == '(')
1775 tail = extend_ref (primary, tail);
1776 tail->type = REF_ARRAY;
1778 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1784 primary->ts = sym->ts;
1789 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1790 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1791 gfc_set_default_type (sym, 0, sym->ns);
1793 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1794 || gfc_match_char ('%') != MATCH_YES)
1795 goto check_substring;
1797 sym = sym->ts.u.derived;
1804 m = gfc_match_name (name);
1806 gfc_error ("Expected structure component name at %C");
1810 if (sym->f2k_derived)
1811 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1817 gfc_symbol* tbp_sym;
1822 gcc_assert (!tail || !tail->next);
1823 gcc_assert (primary->expr_type == EXPR_VARIABLE);
1825 if (tbp->n.tb->is_generic)
1828 tbp_sym = tbp->n.tb->u.specific->n.sym;
1830 primary->expr_type = EXPR_COMPCALL;
1831 primary->value.compcall.tbp = tbp->n.tb;
1832 primary->value.compcall.name = tbp->name;
1833 primary->value.compcall.ignore_pass = 0;
1834 primary->value.compcall.assign = 0;
1835 primary->value.compcall.base_object = NULL;
1836 gcc_assert (primary->symtree->n.sym->attr.referenced);
1838 primary->ts = tbp_sym->ts;
1840 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1841 &primary->value.compcall.actual);
1842 if (m == MATCH_ERROR)
1847 primary->value.compcall.actual = NULL;
1850 gfc_error ("Expected argument list at %C");
1858 component = gfc_find_component (sym, name, false, false);
1859 if (component == NULL)
1862 tail = extend_ref (primary, tail);
1863 tail->type = REF_COMPONENT;
1865 tail->u.c.component = component;
1866 tail->u.c.sym = sym;
1868 primary->ts = component->ts;
1870 if (component->attr.proc_pointer && ppc_arg
1871 && !gfc_matching_procptr_assignment)
1873 m = gfc_match_actual_arglist (sub_flag,
1874 &primary->value.compcall.actual);
1875 if (m == MATCH_ERROR)
1878 primary->expr_type = EXPR_PPC;
1883 if (component->as != NULL && !component->attr.proc_pointer)
1885 tail = extend_ref (primary, tail);
1886 tail->type = REF_ARRAY;
1888 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
1889 component->as->corank);
1893 else if (component->ts.type == BT_CLASS
1894 && component->ts.u.derived->components->as != NULL
1895 && !component->attr.proc_pointer)
1897 tail = extend_ref (primary, tail);
1898 tail->type = REF_ARRAY;
1900 m = gfc_match_array_ref (&tail->u.ar,
1901 component->ts.u.derived->components->as,
1903 component->ts.u.derived->components->as->corank);
1908 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1909 || gfc_match_char ('%') != MATCH_YES)
1912 sym = component->ts.u.derived;
1917 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1919 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1921 gfc_set_default_type (sym, 0, sym->ns);
1922 primary->ts = sym->ts;
1927 if (primary->ts.type == BT_CHARACTER)
1929 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1933 primary->ref = substring;
1935 tail->next = substring;
1937 if (primary->expr_type == EXPR_CONSTANT)
1938 primary->expr_type = EXPR_SUBSTRING;
1941 primary->ts.u.cl = NULL;
1948 gfc_clear_ts (&primary->ts);
1949 gfc_clear_ts (&sym->ts);
1959 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
1961 gfc_error ("Coindexed procedure-pointer component at %C");
1969 /* Given an expression that is a variable, figure out what the
1970 ultimate variable's type and attribute is, traversing the reference
1971 structures if necessary.
1973 This subroutine is trickier than it looks. We start at the base
1974 symbol and store the attribute. Component references load a
1975 completely new attribute.
1977 A couple of rules come into play. Subobjects of targets are always
1978 targets themselves. If we see a component that goes through a
1979 pointer, then the expression must also be a target, since the
1980 pointer is associated with something (if it isn't core will soon be
1981 dumped). If we see a full part or section of an array, the
1982 expression is also an array.
1984 We can have at most one full array reference. */
1987 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1989 int dimension, pointer, allocatable, target;
1990 symbol_attribute attr;
1993 gfc_component *comp;
1995 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
1996 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1999 sym = expr->symtree->n.sym;
2002 if (sym->ts.type == BT_CLASS)
2004 dimension = sym->ts.u.derived->components->attr.dimension;
2005 pointer = sym->ts.u.derived->components->attr.pointer;
2006 allocatable = sym->ts.u.derived->components->attr.allocatable;
2010 dimension = attr.dimension;
2011 pointer = attr.pointer;
2012 allocatable = attr.allocatable;
2015 target = attr.target;
2016 if (pointer || attr.proc_pointer)
2019 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2022 for (; ref; ref = ref->next)
2027 switch (ref->u.ar.type)
2034 allocatable = pointer = 0;
2039 /* Handle coarrays. */
2040 if (ref->u.ar.dimen > 0)
2041 allocatable = pointer = 0;
2045 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2051 comp = ref->u.c.component;
2056 /* Don't set the string length if a substring reference
2058 if (ts->type == BT_CHARACTER
2059 && ref->next && ref->next->type == REF_SUBSTRING)
2063 if (comp->ts.type == BT_CLASS)
2065 pointer = comp->ts.u.derived->components->attr.pointer;
2066 allocatable = comp->ts.u.derived->components->attr.allocatable;
2070 pointer = comp->attr.pointer;
2071 allocatable = comp->attr.allocatable;
2073 if (pointer || attr.proc_pointer)
2079 allocatable = pointer = 0;
2083 attr.dimension = dimension;
2084 attr.pointer = pointer;
2085 attr.allocatable = allocatable;
2086 attr.target = target;
2092 /* Return the attribute from a general expression. */
2095 gfc_expr_attr (gfc_expr *e)
2097 symbol_attribute attr;
2099 switch (e->expr_type)
2102 attr = gfc_variable_attr (e, NULL);
2106 gfc_clear_attr (&attr);
2108 if (e->value.function.esym != NULL)
2110 gfc_symbol *sym = e->value.function.esym->result;
2112 if (sym->ts.type == BT_CLASS)
2114 attr.dimension = sym->ts.u.derived->components->attr.dimension;
2115 attr.pointer = sym->ts.u.derived->components->attr.pointer;
2116 attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
2120 attr = gfc_variable_attr (e, NULL);
2122 /* TODO: NULL() returns pointers. May have to take care of this
2128 gfc_clear_attr (&attr);
2136 /* Match a structure constructor. The initial symbol has already been
2139 typedef struct gfc_structure_ctor_component
2144 struct gfc_structure_ctor_component* next;
2146 gfc_structure_ctor_component;
2148 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2151 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2153 gfc_free (comp->name);
2154 gfc_free_expr (comp->val);
2158 /* Translate the component list into the actual constructor by sorting it in
2159 the order required; this also checks along the way that each and every
2160 component actually has an initializer and handles default initializers
2161 for components without explicit value given. */
2163 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2164 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2166 gfc_structure_ctor_component *comp_iter;
2167 gfc_component *comp;
2169 for (comp = sym->components; comp; comp = comp->next)
2171 gfc_structure_ctor_component **next_ptr;
2172 gfc_expr *value = NULL;
2174 /* Try to find the initializer for the current component by name. */
2175 next_ptr = comp_head;
2176 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2178 if (!strcmp (comp_iter->name, comp->name))
2180 next_ptr = &comp_iter->next;
2183 /* If an extension, try building the parent derived type by building
2184 a value expression for the parent derived type and calling self. */
2185 if (!comp_iter && comp == sym->components && sym->attr.extension)
2187 value = gfc_get_structure_constructor_expr (comp->ts.type,
2189 &gfc_current_locus);
2190 value->ts = comp->ts;
2192 if (build_actual_constructor (comp_head, &value->value.constructor,
2193 comp->ts.u.derived) == FAILURE)
2195 gfc_free_expr (value);
2199 gfc_constructor_append_expr (ctor_head, value, NULL);
2203 /* If it was not found, try the default initializer if there's any;
2204 otherwise, it's an error. */
2207 if (comp->initializer)
2209 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2210 " constructor with missing optional arguments"
2211 " at %C") == FAILURE)
2213 value = gfc_copy_expr (comp->initializer);
2217 gfc_error ("No initializer for component '%s' given in the"
2218 " structure constructor at %C!", comp->name);
2223 value = comp_iter->val;
2225 /* Add the value to the constructor chain built. */
2226 gfc_constructor_append_expr (ctor_head, value, NULL);
2228 /* Remove the entry from the component list. We don't want the expression
2229 value to be free'd, so set it to NULL. */
2232 *next_ptr = comp_iter->next;
2233 comp_iter->val = NULL;
2234 gfc_free_structure_ctor_component (comp_iter);
2241 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2244 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2245 gfc_constructor_base ctor_head = NULL;
2246 gfc_component *comp; /* Is set NULL when named component is first seen */
2250 const char* last_name = NULL;
2252 comp_tail = comp_head = NULL;
2254 if (!parent && gfc_match_char ('(') != MATCH_YES)
2257 where = gfc_current_locus;
2259 gfc_find_component (sym, NULL, false, true);
2261 /* Check that we're not about to construct an ABSTRACT type. */
2262 if (!parent && sym->attr.abstract)
2264 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2268 /* Match the component list and store it in a list together with the
2269 corresponding component names. Check for empty argument list first. */
2270 if (gfc_match_char (')') != MATCH_YES)
2272 comp = sym->components;
2275 gfc_component *this_comp = NULL;
2278 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2281 comp_tail->next = gfc_get_structure_ctor_component ();
2282 comp_tail = comp_tail->next;
2284 comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2285 comp_tail->val = NULL;
2286 comp_tail->where = gfc_current_locus;
2288 /* Try matching a component name. */
2289 if (gfc_match_name (comp_tail->name) == MATCH_YES
2290 && gfc_match_char ('=') == MATCH_YES)
2292 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2293 " constructor with named arguments at %C")
2297 last_name = comp_tail->name;
2302 /* Components without name are not allowed after the first named
2303 component initializer! */
2307 gfc_error ("Component initializer without name after"
2308 " component named %s at %C!", last_name);
2310 gfc_error ("Too many components in structure constructor at"
2315 gfc_current_locus = comp_tail->where;
2316 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2319 /* Find the current component in the structure definition and check
2320 its access is not private. */
2322 this_comp = gfc_find_component (sym, comp->name, false, false);
2325 this_comp = gfc_find_component (sym,
2326 (const char *)comp_tail->name,
2328 comp = NULL; /* Reset needed! */
2331 /* Here we can check if a component name is given which does not
2332 correspond to any component of the defined structure. */
2336 /* Check if this component is already given a value. */
2337 for (comp_iter = comp_head; comp_iter != comp_tail;
2338 comp_iter = comp_iter->next)
2340 gcc_assert (comp_iter);
2341 if (!strcmp (comp_iter->name, comp_tail->name))
2343 gfc_error ("Component '%s' is initialized twice in the"
2344 " structure constructor at %C!", comp_tail->name);
2349 /* Match the current initializer expression. */
2350 m = gfc_match_expr (&comp_tail->val);
2353 if (m == MATCH_ERROR)
2356 /* F2008, R457/C725, for PURE C1283. */
2357 if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
2359 gfc_error ("Coindexed expression to pointer component '%s' in "
2360 "structure constructor at %C!", comp_tail->name);
2365 /* If not explicitly a parent constructor, gather up the components
2367 if (comp && comp == sym->components
2368 && sym->attr.extension
2369 && (comp_tail->val->ts.type != BT_DERIVED
2371 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2373 gfc_current_locus = where;
2374 gfc_free_expr (comp_tail->val);
2375 comp_tail->val = NULL;
2377 m = gfc_match_structure_constructor (comp->ts.u.derived,
2378 &comp_tail->val, true);
2381 if (m == MATCH_ERROR)
2388 if (parent && !comp)
2392 while (gfc_match_char (',') == MATCH_YES);
2394 if (!parent && gfc_match_char (')') != MATCH_YES)
2398 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2401 /* No component should be left, as this should have caused an error in the
2402 loop constructing the component-list (name that does not correspond to any
2403 component in the structure definition). */
2404 if (comp_head && sym->attr.extension)
2406 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2408 gfc_error ("component '%s' at %L has already been set by a "
2409 "parent derived type constructor", comp_iter->name,
2415 gcc_assert (!comp_head);
2417 e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
2418 e->ts.u.derived = sym;
2419 e->value.constructor = ctor_head;
2425 gfc_error ("Syntax error in structure constructor at %C");
2428 for (comp_iter = comp_head; comp_iter; )
2430 gfc_structure_ctor_component *next = comp_iter->next;
2431 gfc_free_structure_ctor_component (comp_iter);
2434 gfc_constructor_free (ctor_head);
2439 /* If the symbol is an implicit do loop index and implicitly typed,
2440 it should not be host associated. Provide a symtree from the
2441 current namespace. */
2443 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2445 if ((*sym)->attr.flavor == FL_VARIABLE
2446 && (*sym)->ns != gfc_current_ns
2447 && (*sym)->attr.implied_index
2448 && (*sym)->attr.implicit_type
2449 && !(*sym)->attr.use_assoc)
2452 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2455 *sym = (*st)->n.sym;
2461 /* Procedure pointer as function result: Replace the function symbol by the
2462 auto-generated hidden result variable named "ppr@". */
2465 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2467 /* Check for procedure pointer result variable. */
2468 if ((*sym)->attr.function && !(*sym)->attr.external
2469 && (*sym)->result && (*sym)->result != *sym
2470 && (*sym)->result->attr.proc_pointer
2471 && (*sym) == gfc_current_ns->proc_name
2472 && (*sym) == (*sym)->result->ns->proc_name
2473 && strcmp ("ppr@", (*sym)->result->name) == 0)
2475 /* Automatic replacement with "hidden" result variable. */
2476 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2477 *sym = (*sym)->result;
2478 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2485 /* Matches a variable name followed by anything that might follow it--
2486 array reference, argument list of a function, etc. */
2489 gfc_match_rvalue (gfc_expr **result)
2491 gfc_actual_arglist *actual_arglist;
2492 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2495 gfc_symtree *symtree;
2496 locus where, old_loc;
2504 m = gfc_match_name (name);
2508 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2509 && !gfc_current_ns->has_import_set)
2510 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2512 i = gfc_get_ha_sym_tree (name, &symtree);
2517 sym = symtree->n.sym;
2519 where = gfc_current_locus;
2521 replace_hidden_procptr_result (&sym, &symtree);
2523 /* If this is an implicit do loop index and implicitly typed,
2524 it should not be host associated. */
2525 m = check_for_implicit_index (&symtree, &sym);
2529 gfc_set_sym_referenced (sym);
2530 sym->attr.implied_index = 0;
2532 if (sym->attr.function && sym->result == sym)
2534 /* See if this is a directly recursive function call. */
2535 gfc_gobble_whitespace ();
2536 if (sym->attr.recursive
2537 && gfc_peek_ascii_char () == '('
2538 && gfc_current_ns->proc_name == sym
2539 && !sym->attr.dimension)
2541 gfc_error ("'%s' at %C is the name of a recursive function "
2542 "and so refers to the result variable. Use an "
2543 "explicit RESULT variable for direct recursion "
2544 "(12.5.2.1)", sym->name);
2548 if (gfc_is_function_return_value (sym, gfc_current_ns))
2552 && (sym->ns == gfc_current_ns
2553 || sym->ns == gfc_current_ns->parent))
2555 gfc_entry_list *el = NULL;
2557 for (el = sym->ns->entries; el; el = el->next)
2563 if (gfc_matching_procptr_assignment)
2566 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2569 if (sym->attr.generic)
2570 goto generic_function;
2572 switch (sym->attr.flavor)
2576 e = gfc_get_expr ();
2578 e->expr_type = EXPR_VARIABLE;
2579 e->symtree = symtree;
2581 m = gfc_match_varspec (e, 0, false, true);
2585 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2586 end up here. Unfortunately, sym->value->expr_type is set to
2587 EXPR_CONSTANT, and so the if () branch would be followed without
2588 the !sym->as check. */
2589 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2590 e = gfc_copy_expr (sym->value);
2593 e = gfc_get_expr ();
2594 e->expr_type = EXPR_VARIABLE;
2597 e->symtree = symtree;
2598 m = gfc_match_varspec (e, 0, false, true);
2600 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2603 /* Variable array references to derived type parameters cause
2604 all sorts of headaches in simplification. Treating such
2605 expressions as variable works just fine for all array
2607 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2609 for (ref = e->ref; ref; ref = ref->next)
2610 if (ref->type == REF_ARRAY)
2613 if (ref == NULL || ref->u.ar.type == AR_FULL)
2619 e = gfc_get_expr ();
2620 e->expr_type = EXPR_VARIABLE;
2621 e->symtree = symtree;
2628 sym = gfc_use_derived (sym);
2632 m = gfc_match_structure_constructor (sym, &e, false);
2635 /* If we're here, then the name is known to be the name of a
2636 procedure, yet it is not sure to be the name of a function. */
2639 /* Procedure Pointer Assignments. */
2641 if (gfc_matching_procptr_assignment)
2643 gfc_gobble_whitespace ();
2644 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2645 /* Parse functions returning a procptr. */
2648 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2649 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2650 sym->attr.intrinsic = 1;
2651 e = gfc_get_expr ();
2652 e->expr_type = EXPR_VARIABLE;
2653 e->symtree = symtree;
2654 m = gfc_match_varspec (e, 0, false, true);
2658 if (sym->attr.subroutine)
2660 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2666 /* At this point, the name has to be a non-statement function.
2667 If the name is the same as the current function being
2668 compiled, then we have a variable reference (to the function
2669 result) if the name is non-recursive. */
2671 st = gfc_enclosing_unit (NULL);
2673 if (st != NULL && st->state == COMP_FUNCTION
2675 && !sym->attr.recursive)
2677 e = gfc_get_expr ();
2678 e->symtree = symtree;
2679 e->expr_type = EXPR_VARIABLE;
2681 m = gfc_match_varspec (e, 0, false, true);
2685 /* Match a function reference. */
2687 m = gfc_match_actual_arglist (0, &actual_arglist);
2690 if (sym->attr.proc == PROC_ST_FUNCTION)
2691 gfc_error ("Statement function '%s' requires argument list at %C",
2694 gfc_error ("Function '%s' requires an argument list at %C",
2707 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2708 sym = symtree->n.sym;
2710 replace_hidden_procptr_result (&sym, &symtree);
2712 e = gfc_get_expr ();
2713 e->symtree = symtree;
2714 e->expr_type = EXPR_FUNCTION;
2715 e->value.function.actual = actual_arglist;
2716 e->where = gfc_current_locus;
2718 if (sym->as != NULL)
2719 e->rank = sym->as->rank;
2721 if (!sym->attr.function
2722 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2728 /* Check here for the existence of at least one argument for the
2729 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2730 argument(s) given will be checked in gfc_iso_c_func_interface,
2731 during resolution of the function call. */
2732 if (sym->attr.is_iso_c == 1
2733 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2734 && (sym->intmod_sym_id == ISOCBINDING_LOC
2735 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2736 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2738 /* make sure we were given a param */
2739 if (actual_arglist == NULL)
2741 gfc_error ("Missing argument to '%s' at %C", sym->name);
2747 if (sym->result == NULL)
2755 /* Special case for derived type variables that get their types
2756 via an IMPLICIT statement. This can't wait for the
2757 resolution phase. */
2759 if (gfc_peek_ascii_char () == '%'
2760 && sym->ts.type == BT_UNKNOWN
2761 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2762 gfc_set_default_type (sym, 0, sym->ns);
2764 /* If the symbol has a dimension attribute, the expression is a
2767 if (sym->attr.dimension)
2769 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2770 sym->name, NULL) == FAILURE)
2776 e = gfc_get_expr ();
2777 e->symtree = symtree;
2778 e->expr_type = EXPR_VARIABLE;
2779 m = gfc_match_varspec (e, 0, false, true);
2783 /* Name is not an array, so we peek to see if a '(' implies a
2784 function call or a substring reference. Otherwise the
2785 variable is just a scalar. */
2787 gfc_gobble_whitespace ();
2788 if (gfc_peek_ascii_char () != '(')
2790 /* Assume a scalar variable */
2791 e = gfc_get_expr ();
2792 e->symtree = symtree;
2793 e->expr_type = EXPR_VARIABLE;
2795 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2796 sym->name, NULL) == FAILURE)
2802 /*FIXME:??? gfc_match_varspec does set this for us: */
2804 m = gfc_match_varspec (e, 0, false, true);
2808 /* See if this is a function reference with a keyword argument
2809 as first argument. We do this because otherwise a spurious
2810 symbol would end up in the symbol table. */
2812 old_loc = gfc_current_locus;
2813 m2 = gfc_match (" ( %n =", argname);
2814 gfc_current_locus = old_loc;
2816 e = gfc_get_expr ();
2817 e->symtree = symtree;
2819 if (m2 != MATCH_YES)
2821 /* Try to figure out whether we're dealing with a character type.
2822 We're peeking ahead here, because we don't want to call
2823 match_substring if we're dealing with an implicitly typed
2824 non-character variable. */
2825 implicit_char = false;
2826 if (sym->ts.type == BT_UNKNOWN)
2828 ts = gfc_get_default_type (sym->name, NULL);
2829 if (ts->type == BT_CHARACTER)
2830 implicit_char = true;
2833 /* See if this could possibly be a substring reference of a name
2834 that we're not sure is a variable yet. */
2836 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2837 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2840 e->expr_type = EXPR_VARIABLE;
2842 if (sym->attr.flavor != FL_VARIABLE
2843 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2844 sym->name, NULL) == FAILURE)
2850 if (sym->ts.type == BT_UNKNOWN
2851 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2865 /* Give up, assume we have a function. */
2867 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2868 sym = symtree->n.sym;
2869 e->expr_type = EXPR_FUNCTION;
2871 if (!sym->attr.function
2872 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2880 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2882 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2890 /* If our new function returns a character, array or structure
2891 type, it might have subsequent references. */
2893 m = gfc_match_varspec (e, 0, false, true);
2900 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2902 e = gfc_get_expr ();
2903 e->symtree = symtree;
2904 e->expr_type = EXPR_FUNCTION;
2906 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2910 gfc_error ("Symbol at %C is not appropriate for an expression");
2926 /* Match a variable, i.e. something that can be assigned to. This
2927 starts as a symbol, can be a structure component or an array
2928 reference. It can be a function if the function doesn't have a
2929 separate RESULT variable. If the symbol has not been previously
2930 seen, we assume it is a variable.
2932 This function is called by two interface functions:
2933 gfc_match_variable, which has host_flag = 1, and
2934 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2935 match of the symbol to the local scope. */
2938 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2946 /* Since nothing has any business being an lvalue in a module
2947 specification block, an interface block or a contains section,
2948 we force the changed_symbols mechanism to work by setting
2949 host_flag to 0. This prevents valid symbols that have the name
2950 of keywords, such as 'end', being turned into variables by
2951 failed matching to assignments for, e.g., END INTERFACE. */
2952 if (gfc_current_state () == COMP_MODULE
2953 || gfc_current_state () == COMP_INTERFACE
2954 || gfc_current_state () == COMP_CONTAINS)
2957 where = gfc_current_locus;
2958 m = gfc_match_sym_tree (&st, host_flag);
2964 /* If this is an implicit do loop index and implicitly typed,
2965 it should not be host associated. */
2966 m = check_for_implicit_index (&st, &sym);
2970 sym->attr.implied_index = 0;
2972 gfc_set_sym_referenced (sym);
2973 switch (sym->attr.flavor)
2976 if (sym->attr.is_protected && sym->attr.use_assoc)
2978 gfc_error ("Assigning to PROTECTED variable at %C");
2985 sym_flavor flavor = FL_UNKNOWN;
2987 gfc_gobble_whitespace ();
2989 if (sym->attr.external || sym->attr.procedure
2990 || sym->attr.function || sym->attr.subroutine)
2991 flavor = FL_PROCEDURE;
2993 /* If it is not a procedure, is not typed and is host associated,
2994 we cannot give it a flavor yet. */
2995 else if (sym->ns == gfc_current_ns->parent
2996 && sym->ts.type == BT_UNKNOWN)
2999 /* These are definitive indicators that this is a variable. */
3000 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3001 || sym->attr.pointer || sym->as != NULL)
3002 flavor = FL_VARIABLE;
3004 if (flavor != FL_UNKNOWN
3005 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3012 gfc_error ("Named constant at %C in an EQUIVALENCE");
3014 gfc_error ("Cannot assign to a named constant at %C");
3019 /* Check for a nonrecursive function result variable. */
3020 if (sym->attr.function
3021 && !sym->attr.external
3022 && sym->result == sym
3023 && (gfc_is_function_return_value (sym, gfc_current_ns)
3025 && sym->ns == gfc_current_ns)
3027 && sym->ns == gfc_current_ns->parent)))
3029 /* If a function result is a derived type, then the derived
3030 type may still have to be resolved. */
3032 if (sym->ts.type == BT_DERIVED
3033 && gfc_use_derived (sym->ts.u.derived) == NULL)
3038 if (sym->attr.proc_pointer
3039 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3042 /* Fall through to error */
3045 gfc_error ("'%s' at %C is not a variable", sym->name);
3049 /* Special case for derived type variables that get their types
3050 via an IMPLICIT statement. This can't wait for the
3051 resolution phase. */
3054 gfc_namespace * implicit_ns;
3056 if (gfc_current_ns->proc_name == sym)
3057 implicit_ns = gfc_current_ns;
3059 implicit_ns = sym->ns;
3061 if (gfc_peek_ascii_char () == '%'
3062 && sym->ts.type == BT_UNKNOWN
3063 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3064 gfc_set_default_type (sym, 0, implicit_ns);
3067 expr = gfc_get_expr ();
3069 expr->expr_type = EXPR_VARIABLE;
3072 expr->where = where;
3074 /* Now see if we have to do more. */
3075 m = gfc_match_varspec (expr, equiv_flag, false, false);
3078 gfc_free_expr (expr);
3088 gfc_match_variable (gfc_expr **result, int equiv_flag)
3090 return match_variable (result, equiv_flag, 1);
3095 gfc_match_equiv_variable (gfc_expr **result)
3097 return match_variable (result, 1, 0);