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 int matching_actual_arglist = 0;
33 /* Matches a kind-parameter expression, which is either a named
34 symbolic constant or a nonnegative integer constant. If
35 successful, sets the kind value to the correct integer. */
38 match_kind_param (int *kind)
40 char name[GFC_MAX_SYMBOL_LEN + 1];
45 m = gfc_match_small_literal_int (kind, NULL);
49 m = gfc_match_name (name);
53 if (gfc_find_symbol (name, NULL, 1, &sym))
59 if (sym->attr.flavor != FL_PARAMETER)
62 if (sym->value == NULL)
65 p = gfc_extract_int (sym->value, kind);
69 gfc_set_sym_referenced (sym);
78 /* Get a trailing kind-specification for non-character variables.
80 the integer kind value or:
81 -1 if an error was generated
82 -2 if no kind was found */
90 if (gfc_match_char ('_') != MATCH_YES)
93 m = match_kind_param (&kind);
95 gfc_error ("Missing kind-parameter at %C");
97 return (m == MATCH_YES) ? kind : -1;
101 /* Given a character and a radix, see if the character is a valid
102 digit in that radix. */
105 gfc_check_digit (char c, int radix)
112 r = ('0' <= c && c <= '1');
116 r = ('0' <= c && c <= '7');
120 r = ('0' <= c && c <= '9');
128 gfc_internal_error ("gfc_check_digit(): bad radix");
135 /* Match the digit string part of an integer if signflag is not set,
136 the signed digit string part if signflag is set. If the buffer
137 is NULL, we just count characters for the resolution pass. Returns
138 the number of characters matched, -1 for no match. */
141 match_digits (int signflag, int radix, char *buffer)
148 c = gfc_next_ascii_char ();
150 if (signflag && (c == '+' || c == '-'))
154 gfc_gobble_whitespace ();
155 c = gfc_next_ascii_char ();
159 if (!gfc_check_digit (c, radix))
168 old_loc = gfc_current_locus;
169 c = gfc_next_ascii_char ();
171 if (!gfc_check_digit (c, radix))
179 gfc_current_locus = old_loc;
185 /* Match an integer (digit string and optional kind).
186 A sign will be accepted if signflag is set. */
189 match_integer_constant (gfc_expr **result, int signflag)
196 old_loc = gfc_current_locus;
197 gfc_gobble_whitespace ();
199 length = match_digits (signflag, 10, NULL);
200 gfc_current_locus = old_loc;
204 buffer = (char *) alloca (length + 1);
205 memset (buffer, '\0', length + 1);
207 gfc_gobble_whitespace ();
209 match_digits (signflag, 10, buffer);
213 kind = gfc_default_integer_kind;
217 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
219 gfc_error ("Integer kind %d at %C not available", kind);
223 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
225 if (gfc_range_check (e) != ARITH_OK)
227 gfc_error ("Integer too big for its kind at %C. This check can be "
228 "disabled with the option -fno-range-check");
239 /* Match a Hollerith constant. */
242 match_hollerith_constant (gfc_expr **result)
250 old_loc = gfc_current_locus;
251 gfc_gobble_whitespace ();
253 if (match_integer_constant (&e, 0) == MATCH_YES
254 && gfc_match_char ('h') == MATCH_YES)
256 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
260 msg = gfc_extract_int (e, &num);
268 gfc_error ("Invalid Hollerith constant: %L must contain at least "
269 "one character", &old_loc);
272 if (e->ts.kind != gfc_default_integer_kind)
274 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
275 "should be default", &old_loc);
281 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
284 /* Calculate padding needed to fit default integer memory. */
285 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
287 e->representation.string = XCNEWVEC (char, num + pad + 1);
289 for (i = 0; i < num; i++)
291 gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
292 if (! gfc_wide_fits_in_byte (c))
294 gfc_error ("Invalid Hollerith constant at %L contains a "
295 "wide character", &old_loc);
299 e->representation.string[i] = (unsigned char) c;
302 /* Now pad with blanks and end with a null char. */
303 for (i = 0; i < pad; i++)
304 e->representation.string[num + i] = ' ';
306 e->representation.string[num + i] = '\0';
307 e->representation.length = num + pad;
316 gfc_current_locus = old_loc;
325 /* Match a binary, octal or hexadecimal constant that can be found in
326 a DATA statement. The standard permits b'010...', o'73...', and
327 z'a1...' where b, o, and z can be capital letters. This function
328 also accepts postfixed forms of the constants: '01...'b, '73...'o,
329 and 'a1...'z. An additional extension is the use of x for z. */
332 match_boz_constant (gfc_expr **result)
334 int radix, length, x_hex, kind;
335 locus old_loc, start_loc;
336 char *buffer, post, delim;
339 start_loc = old_loc = gfc_current_locus;
340 gfc_gobble_whitespace ();
343 switch (post = gfc_next_ascii_char ())
365 radix = 16; /* Set to accept any valid digit string. */
371 /* No whitespace allowed here. */
374 delim = gfc_next_ascii_char ();
376 if (delim != '\'' && delim != '\"')
380 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
381 "constant at %C uses non-standard syntax")
385 old_loc = gfc_current_locus;
387 length = match_digits (0, radix, NULL);
390 gfc_error ("Empty set of digits in BOZ constant at %C");
394 if (gfc_next_ascii_char () != delim)
396 gfc_error ("Illegal character in BOZ constant at %C");
402 switch (gfc_next_ascii_char ())
419 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
420 "at %C uses non-standard postfix syntax")
425 gfc_current_locus = old_loc;
427 buffer = (char *) alloca (length + 1);
428 memset (buffer, '\0', length + 1);
430 match_digits (0, radix, buffer);
431 gfc_next_ascii_char (); /* Eat delimiter. */
433 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
435 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
436 "If a data-stmt-constant is a boz-literal-constant, the corresponding
437 variable shall be of type integer. The boz-literal-constant is treated
438 as if it were an int-literal-constant with a kind-param that specifies
439 the representation method with the largest decimal exponent range
440 supported by the processor." */
442 kind = gfc_max_integer_kind;
443 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
445 /* Mark as boz variable. */
448 if (gfc_range_check (e) != ARITH_OK)
450 gfc_error ("Integer too big for integer kind %i at %C", kind);
455 if (!gfc_in_match_data ()
456 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
465 gfc_current_locus = start_loc;
470 /* Match a real constant of some sort. Allow a signed constant if signflag
474 match_real_constant (gfc_expr **result, int signflag)
476 int kind, count, seen_dp, seen_digits;
477 locus old_loc, temp_loc;
478 char *p, *buffer, c, exp_char;
482 old_loc = gfc_current_locus;
483 gfc_gobble_whitespace ();
493 c = gfc_next_ascii_char ();
494 if (signflag && (c == '+' || c == '-'))
499 gfc_gobble_whitespace ();
500 c = gfc_next_ascii_char ();
503 /* Scan significand. */
504 for (;; c = gfc_next_ascii_char (), count++)
511 /* Check to see if "." goes with a following operator like
513 temp_loc = gfc_current_locus;
514 c = gfc_next_ascii_char ();
516 if (c == 'e' || c == 'd' || c == 'q')
518 c = gfc_next_ascii_char ();
520 goto done; /* Operator named .e. or .d. */
524 goto done; /* Distinguish 1.e9 from 1.eq.2 */
526 gfc_current_locus = temp_loc;
540 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
545 c = gfc_next_ascii_char ();
548 if (c == '+' || c == '-')
549 { /* optional sign */
550 c = gfc_next_ascii_char ();
556 gfc_error ("Missing exponent in real number at %C");
562 c = gfc_next_ascii_char ();
567 /* Check that we have a numeric constant. */
568 if (!seen_digits || (!seen_dp && exp_char == ' '))
570 gfc_current_locus = old_loc;
574 /* Convert the number. */
575 gfc_current_locus = old_loc;
576 gfc_gobble_whitespace ();
578 buffer = (char *) alloca (count + 1);
579 memset (buffer, '\0', count + 1);
582 c = gfc_next_ascii_char ();
583 if (c == '+' || c == '-')
585 gfc_gobble_whitespace ();
586 c = gfc_next_ascii_char ();
589 /* Hack for mpfr_set_str(). */
592 if (c == 'd' || c == 'q')
600 c = gfc_next_ascii_char ();
612 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
616 kind = gfc_default_double_kind;
621 kind = gfc_default_real_kind;
623 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
625 gfc_error ("Invalid real kind %d at %C", kind);
630 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
632 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
634 switch (gfc_range_check (e))
639 gfc_error ("Real constant overflows its kind at %C");
642 case ARITH_UNDERFLOW:
643 if (gfc_option.warn_underflow)
644 gfc_warning ("Real constant underflows its kind at %C");
645 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
649 gfc_internal_error ("gfc_range_check() returned bad value");
661 /* Match a substring reference. */
664 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
666 gfc_expr *start, *end;
674 old_loc = gfc_current_locus;
676 m = gfc_match_char ('(');
680 if (gfc_match_char (':') != MATCH_YES)
683 m = gfc_match_init_expr (&start);
685 m = gfc_match_expr (&start);
693 m = gfc_match_char (':');
698 if (gfc_match_char (')') != MATCH_YES)
701 m = gfc_match_init_expr (&end);
703 m = gfc_match_expr (&end);
707 if (m == MATCH_ERROR)
710 m = gfc_match_char (')');
715 /* Optimize away the (:) reference. */
716 if (start == NULL && end == NULL)
720 ref = gfc_get_ref ();
722 ref->type = REF_SUBSTRING;
724 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
725 ref->u.ss.start = start;
726 if (end == NULL && cl)
727 end = gfc_copy_expr (cl->length);
729 ref->u.ss.length = cl;
736 gfc_error ("Syntax error in SUBSTRING specification at %C");
740 gfc_free_expr (start);
743 gfc_current_locus = old_loc;
748 /* Reads the next character of a string constant, taking care to
749 return doubled delimiters on the input as a single instance of
752 Special return values for "ret" argument are:
753 -1 End of the string, as determined by the delimiter
754 -2 Unterminated string detected
756 Backslash codes are also expanded at this time. */
759 next_string_char (gfc_char_t delimiter, int *ret)
764 c = gfc_next_char_literal (INSTRING_WARN);
773 if (gfc_option.flag_backslash && c == '\\')
775 old_locus = gfc_current_locus;
777 if (gfc_match_special_char (&c) == MATCH_NO)
778 gfc_current_locus = old_locus;
780 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
781 gfc_warning ("Extension: backslash character at %C");
787 old_locus = gfc_current_locus;
788 c = gfc_next_char_literal (NONSTRING);
792 gfc_current_locus = old_locus;
799 /* Special case of gfc_match_name() that matches a parameter kind name
800 before a string constant. This takes case of the weird but legal
805 where kind____ is a parameter. gfc_match_name() will happily slurp
806 up all the underscores, which leads to problems. If we return
807 MATCH_YES, the parse pointer points to the final underscore, which
808 is not part of the name. We never return MATCH_ERROR-- errors in
809 the name will be detected later. */
812 match_charkind_name (char *name)
818 gfc_gobble_whitespace ();
819 c = gfc_next_ascii_char ();
828 old_loc = gfc_current_locus;
829 c = gfc_next_ascii_char ();
833 peek = gfc_peek_ascii_char ();
835 if (peek == '\'' || peek == '\"')
837 gfc_current_locus = old_loc;
845 && (c != '$' || !gfc_option.flag_dollar_ok))
849 if (++len > GFC_MAX_SYMBOL_LEN)
857 /* See if the current input matches a character constant. Lots of
858 contortions have to be done to match the kind parameter which comes
859 before the actual string. The main consideration is that we don't
860 want to error out too quickly. For example, we don't actually do
861 any validation of the kinds until we have actually seen a legal
862 delimiter. Using match_kind_param() generates errors too quickly. */
865 match_string_constant (gfc_expr **result)
867 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
868 int i, kind, length, warn_ampersand, ret;
869 locus old_locus, start_locus;
874 gfc_char_t c, delimiter, *p;
876 old_locus = gfc_current_locus;
878 gfc_gobble_whitespace ();
880 c = gfc_next_char ();
881 if (c == '\'' || c == '"')
883 kind = gfc_default_character_kind;
884 start_locus = gfc_current_locus;
888 if (gfc_wide_is_digit (c))
892 while (gfc_wide_is_digit (c))
894 kind = kind * 10 + c - '0';
897 c = gfc_next_char ();
903 gfc_current_locus = old_locus;
905 m = match_charkind_name (name);
909 if (gfc_find_symbol (name, NULL, 1, &sym)
911 || sym->attr.flavor != FL_PARAMETER)
915 c = gfc_next_char ();
920 gfc_gobble_whitespace ();
921 c = gfc_next_char ();
927 gfc_gobble_whitespace ();
929 c = gfc_next_char ();
930 if (c != '\'' && c != '"')
933 start_locus = gfc_current_locus;
937 q = gfc_extract_int (sym->value, &kind);
943 gfc_set_sym_referenced (sym);
946 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
948 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
953 /* Scan the string into a block of memory by first figuring out how
954 long it is, allocating the structure, then re-reading it. This
955 isn't particularly efficient, but string constants aren't that
956 common in most code. TODO: Use obstacks? */
963 c = next_string_char (delimiter, &ret);
968 gfc_current_locus = start_locus;
969 gfc_error ("Unterminated character constant beginning at %C");
976 /* Peek at the next character to see if it is a b, o, z, or x for the
977 postfixed BOZ literal constants. */
978 peek = gfc_peek_ascii_char ();
979 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
982 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
984 gfc_current_locus = start_locus;
986 /* We disable the warning for the following loop as the warning has already
987 been printed in the loop above. */
988 warn_ampersand = gfc_option.warn_ampersand;
989 gfc_option.warn_ampersand = 0;
991 p = e->value.character.string;
992 for (i = 0; i < length; i++)
994 c = next_string_char (delimiter, &ret);
996 if (!gfc_check_character_range (c, kind))
998 gfc_error ("Character '%s' in string at %C is not representable "
999 "in character kind %d", gfc_print_wide_char (c), kind);
1006 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1007 gfc_option.warn_ampersand = warn_ampersand;
1009 next_string_char (delimiter, &ret);
1011 gfc_internal_error ("match_string_constant(): Delimiter not found");
1013 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1014 e->expr_type = EXPR_SUBSTRING;
1021 gfc_current_locus = old_locus;
1026 /* Match a .true. or .false. Returns 1 if a .true. was found,
1027 0 if a .false. was found, and -1 otherwise. */
1029 match_logical_constant_string (void)
1031 locus orig_loc = gfc_current_locus;
1033 gfc_gobble_whitespace ();
1034 if (gfc_next_ascii_char () == '.')
1036 char ch = gfc_next_ascii_char ();
1039 if (gfc_next_ascii_char () == 'a'
1040 && gfc_next_ascii_char () == 'l'
1041 && gfc_next_ascii_char () == 's'
1042 && gfc_next_ascii_char () == 'e'
1043 && gfc_next_ascii_char () == '.')
1044 /* Matched ".false.". */
1049 if (gfc_next_ascii_char () == 'r'
1050 && gfc_next_ascii_char () == 'u'
1051 && gfc_next_ascii_char () == 'e'
1052 && gfc_next_ascii_char () == '.')
1053 /* Matched ".true.". */
1057 gfc_current_locus = orig_loc;
1061 /* Match a .true. or .false. */
1064 match_logical_constant (gfc_expr **result)
1069 i = match_logical_constant_string ();
1077 kind = gfc_default_logical_kind;
1079 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1081 gfc_error ("Bad kind for logical constant at %C");
1085 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1092 /* Match a real or imaginary part of a complex constant that is a
1093 symbolic constant. */
1096 match_sym_complex_part (gfc_expr **result)
1098 char name[GFC_MAX_SYMBOL_LEN + 1];
1103 m = gfc_match_name (name);
1107 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1110 if (sym->attr.flavor != FL_PARAMETER)
1112 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1116 if (!gfc_numeric_ts (&sym->value->ts))
1118 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1122 if (sym->value->rank != 0)
1124 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1128 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1129 "complex constant at %C") == FAILURE)
1132 switch (sym->value->ts.type)
1135 e = gfc_copy_expr (sym->value);
1139 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1145 e = gfc_int2real (sym->value, gfc_default_real_kind);
1151 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1154 *result = e; /* e is a scalar, real, constant expression. */
1158 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1163 /* Match a real or imaginary part of a complex number. */
1166 match_complex_part (gfc_expr **result)
1170 m = match_sym_complex_part (result);
1174 m = match_real_constant (result, 1);
1178 return match_integer_constant (result, 1);
1182 /* Try to match a complex constant. */
1185 match_complex_constant (gfc_expr **result)
1187 gfc_expr *e, *real, *imag;
1188 gfc_error_buf old_error;
1189 gfc_typespec target;
1194 old_loc = gfc_current_locus;
1195 real = imag = e = NULL;
1197 m = gfc_match_char ('(');
1201 gfc_push_error (&old_error);
1203 m = match_complex_part (&real);
1206 gfc_free_error (&old_error);
1210 if (gfc_match_char (',') == MATCH_NO)
1212 gfc_pop_error (&old_error);
1217 /* If m is error, then something was wrong with the real part and we
1218 assume we have a complex constant because we've seen the ','. An
1219 ambiguous case here is the start of an iterator list of some
1220 sort. These sort of lists are matched prior to coming here. */
1222 if (m == MATCH_ERROR)
1224 gfc_free_error (&old_error);
1227 gfc_pop_error (&old_error);
1229 m = match_complex_part (&imag);
1232 if (m == MATCH_ERROR)
1235 m = gfc_match_char (')');
1238 /* Give the matcher for implied do-loops a chance to run. This
1239 yields a much saner error message for (/ (i, 4=i, 6) /). */
1240 if (gfc_peek_ascii_char () == '=')
1249 if (m == MATCH_ERROR)
1252 /* Decide on the kind of this complex number. */
1253 if (real->ts.type == BT_REAL)
1255 if (imag->ts.type == BT_REAL)
1256 kind = gfc_kind_max (real, imag);
1258 kind = real->ts.kind;
1262 if (imag->ts.type == BT_REAL)
1263 kind = imag->ts.kind;
1265 kind = gfc_default_real_kind;
1267 gfc_clear_ts (&target);
1268 target.type = BT_REAL;
1271 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1272 gfc_convert_type (real, &target, 2);
1273 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1274 gfc_convert_type (imag, &target, 2);
1276 e = gfc_convert_complex (real, imag, kind);
1277 e->where = gfc_current_locus;
1279 gfc_free_expr (real);
1280 gfc_free_expr (imag);
1286 gfc_error ("Syntax error in COMPLEX constant at %C");
1291 gfc_free_expr (real);
1292 gfc_free_expr (imag);
1293 gfc_current_locus = old_loc;
1299 /* Match constants in any of several forms. Returns nonzero for a
1300 match, zero for no match. */
1303 gfc_match_literal_constant (gfc_expr **result, int signflag)
1307 m = match_complex_constant (result);
1311 m = match_string_constant (result);
1315 m = match_boz_constant (result);
1319 m = match_real_constant (result, signflag);
1323 m = match_hollerith_constant (result);
1327 m = match_integer_constant (result, signflag);
1331 m = match_logical_constant (result);
1339 /* This checks if a symbol is the return value of an encompassing function.
1340 Function nesting can be maximally two levels deep, but we may have
1341 additional local namespaces like BLOCK etc. */
1344 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1346 if (!sym->attr.function || (sym->result != sym))
1350 if (ns->proc_name == sym)
1358 /* Match a single actual argument value. An actual argument is
1359 usually an expression, but can also be a procedure name. If the
1360 argument is a single name, it is not always possible to tell
1361 whether the name is a dummy procedure or not. We treat these cases
1362 by creating an argument that looks like a dummy procedure and
1363 fixing things later during resolution. */
1366 match_actual_arg (gfc_expr **result)
1368 char name[GFC_MAX_SYMBOL_LEN + 1];
1369 gfc_symtree *symtree;
1374 gfc_gobble_whitespace ();
1375 where = gfc_current_locus;
1377 switch (gfc_match_name (name))
1386 w = gfc_current_locus;
1387 gfc_gobble_whitespace ();
1388 c = gfc_next_ascii_char ();
1389 gfc_current_locus = w;
1391 if (c != ',' && c != ')')
1394 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1396 /* Handle error elsewhere. */
1398 /* Eliminate a couple of common cases where we know we don't
1399 have a function argument. */
1400 if (symtree == NULL)
1402 gfc_get_sym_tree (name, NULL, &symtree, false);
1403 gfc_set_sym_referenced (symtree->n.sym);
1409 sym = symtree->n.sym;
1410 gfc_set_sym_referenced (sym);
1411 if (sym->attr.flavor != FL_PROCEDURE
1412 && sym->attr.flavor != FL_UNKNOWN)
1415 if (sym->attr.in_common && !sym->attr.proc_pointer)
1417 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1422 /* If the symbol is a function with itself as the result and
1423 is being defined, then we have a variable. */
1424 if (sym->attr.function && sym->result == sym)
1426 if (gfc_is_function_return_value (sym, gfc_current_ns))
1430 && (sym->ns == gfc_current_ns
1431 || sym->ns == gfc_current_ns->parent))
1433 gfc_entry_list *el = NULL;
1435 for (el = sym->ns->entries; el; el = el->next)
1445 e = gfc_get_expr (); /* Leave it unknown for now */
1446 e->symtree = symtree;
1447 e->expr_type = EXPR_VARIABLE;
1448 e->ts.type = BT_PROCEDURE;
1455 gfc_current_locus = where;
1456 return gfc_match_expr (result);
1460 /* Match a keyword argument. */
1463 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1465 char name[GFC_MAX_SYMBOL_LEN + 1];
1466 gfc_actual_arglist *a;
1470 name_locus = gfc_current_locus;
1471 m = gfc_match_name (name);
1475 if (gfc_match_char ('=') != MATCH_YES)
1481 m = match_actual_arg (&actual->expr);
1485 /* Make sure this name has not appeared yet. */
1487 if (name[0] != '\0')
1489 for (a = base; a; a = a->next)
1490 if (a->name != NULL && strcmp (a->name, name) == 0)
1492 gfc_error ("Keyword '%s' at %C has already appeared in the "
1493 "current argument list", name);
1498 actual->name = gfc_get_string (name);
1502 gfc_current_locus = name_locus;
1507 /* Match an argument list function, such as %VAL. */
1510 match_arg_list_function (gfc_actual_arglist *result)
1512 char name[GFC_MAX_SYMBOL_LEN + 1];
1516 old_locus = gfc_current_locus;
1518 if (gfc_match_char ('%') != MATCH_YES)
1524 m = gfc_match ("%n (", name);
1528 if (name[0] != '\0')
1533 if (strncmp (name, "loc", 3) == 0)
1535 result->name = "%LOC";
1539 if (strncmp (name, "ref", 3) == 0)
1541 result->name = "%REF";
1545 if (strncmp (name, "val", 3) == 0)
1547 result->name = "%VAL";
1556 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1557 "function at %C") == FAILURE)
1563 m = match_actual_arg (&result->expr);
1567 if (gfc_match_char (')') != MATCH_YES)
1576 gfc_current_locus = old_locus;
1581 /* Matches an actual argument list of a function or subroutine, from
1582 the opening parenthesis to the closing parenthesis. The argument
1583 list is assumed to allow keyword arguments because we don't know if
1584 the symbol associated with the procedure has an implicit interface
1585 or not. We make sure keywords are unique. If sub_flag is set,
1586 we're matching the argument list of a subroutine. */
1589 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1591 gfc_actual_arglist *head, *tail;
1593 gfc_st_label *label;
1597 *argp = tail = NULL;
1598 old_loc = gfc_current_locus;
1602 if (gfc_match_char ('(') == MATCH_NO)
1603 return (sub_flag) ? MATCH_YES : MATCH_NO;
1605 if (gfc_match_char (')') == MATCH_YES)
1609 matching_actual_arglist++;
1614 head = tail = gfc_get_actual_arglist ();
1617 tail->next = gfc_get_actual_arglist ();
1621 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1623 m = gfc_match_st_label (&label);
1625 gfc_error ("Expected alternate return label at %C");
1629 tail->label = label;
1633 /* After the first keyword argument is seen, the following
1634 arguments must also have keywords. */
1637 m = match_keyword_arg (tail, head);
1639 if (m == MATCH_ERROR)
1643 gfc_error ("Missing keyword name in actual argument list at %C");
1650 /* Try an argument list function, like %VAL. */
1651 m = match_arg_list_function (tail);
1652 if (m == MATCH_ERROR)
1655 /* See if we have the first keyword argument. */
1658 m = match_keyword_arg (tail, head);
1661 if (m == MATCH_ERROR)
1667 /* Try for a non-keyword argument. */
1668 m = match_actual_arg (&tail->expr);
1669 if (m == MATCH_ERROR)
1678 if (gfc_match_char (')') == MATCH_YES)
1680 if (gfc_match_char (',') != MATCH_YES)
1685 matching_actual_arglist--;
1689 gfc_error ("Syntax error in argument list at %C");
1692 gfc_free_actual_arglist (head);
1693 gfc_current_locus = old_loc;
1694 matching_actual_arglist--;
1699 /* Used by gfc_match_varspec() to extend the reference list by one
1703 extend_ref (gfc_expr *primary, gfc_ref *tail)
1705 if (primary->ref == NULL)
1706 primary->ref = tail = gfc_get_ref ();
1710 gfc_internal_error ("extend_ref(): Bad tail");
1711 tail->next = gfc_get_ref ();
1719 /* Match any additional specifications associated with the current
1720 variable like member references or substrings. If equiv_flag is
1721 set we only match stuff that is allowed inside an EQUIVALENCE
1722 statement. sub_flag tells whether we expect a type-bound procedure found
1723 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1724 components, 'ppc_arg' determines whether the PPC may be called (with an
1725 argument list), or whether it may just be referred to as a pointer. */
1728 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1731 char name[GFC_MAX_SYMBOL_LEN + 1];
1732 gfc_ref *substring, *tail;
1733 gfc_component *component;
1734 gfc_symbol *sym = primary->symtree->n.sym;
1740 gfc_gobble_whitespace ();
1742 if (gfc_peek_ascii_char () == '[')
1744 if (sym->attr.dimension)
1746 gfc_error ("Array section designator, e.g. '(:)', is required "
1747 "besides the coarray designator '[...]' at %C");
1750 if (!sym->attr.codimension)
1752 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1758 /* For associate names, we may not yet know whether they are arrays or not.
1759 Thus if we have one and parentheses follow, we have to assume that it
1760 actually is one for now. The final decision will be made at
1761 resolution time, of course. */
1762 if (sym->assoc && gfc_peek_ascii_char () == '(')
1763 sym->attr.dimension = 1;
1765 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1766 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1767 || (sym->attr.dimension && sym->ts.type != BT_CLASS
1768 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL)
1769 && !(gfc_matching_procptr_assignment
1770 && sym->attr.flavor == FL_PROCEDURE))
1771 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1772 && 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,
1782 sym->ts.type == BT_CLASS
1783 ? (CLASS_DATA (sym)->as
1784 ? CLASS_DATA (sym)->as->corank : 0)
1785 : (sym->as ? sym->as->corank : 0));
1789 gfc_gobble_whitespace ();
1790 if (equiv_flag && gfc_peek_ascii_char () == '(')
1792 tail = extend_ref (primary, tail);
1793 tail->type = REF_ARRAY;
1795 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1801 primary->ts = sym->ts;
1806 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1807 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1808 gfc_set_default_type (sym, 0, sym->ns);
1810 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1811 || gfc_match_char ('%') != MATCH_YES)
1812 goto check_substring;
1814 sym = sym->ts.u.derived;
1821 m = gfc_match_name (name);
1823 gfc_error ("Expected structure component name at %C");
1827 if (sym->f2k_derived)
1828 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1834 gfc_symbol* tbp_sym;
1839 gcc_assert (!tail || !tail->next);
1840 gcc_assert (primary->expr_type == EXPR_VARIABLE
1841 || (primary->expr_type == EXPR_STRUCTURE
1842 && primary->symtree && primary->symtree->n.sym
1843 && primary->symtree->n.sym->attr.flavor));
1845 if (tbp->n.tb->is_generic)
1848 tbp_sym = tbp->n.tb->u.specific->n.sym;
1850 primary->expr_type = EXPR_COMPCALL;
1851 primary->value.compcall.tbp = tbp->n.tb;
1852 primary->value.compcall.name = tbp->name;
1853 primary->value.compcall.ignore_pass = 0;
1854 primary->value.compcall.assign = 0;
1855 primary->value.compcall.base_object = NULL;
1856 gcc_assert (primary->symtree->n.sym->attr.referenced);
1858 primary->ts = tbp_sym->ts;
1860 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1861 &primary->value.compcall.actual);
1862 if (m == MATCH_ERROR)
1867 primary->value.compcall.actual = NULL;
1870 gfc_error ("Expected argument list at %C");
1878 component = gfc_find_component (sym, name, false, false);
1879 if (component == NULL)
1882 tail = extend_ref (primary, tail);
1883 tail->type = REF_COMPONENT;
1885 tail->u.c.component = component;
1886 tail->u.c.sym = sym;
1888 primary->ts = component->ts;
1890 if (component->attr.proc_pointer && ppc_arg
1891 && !gfc_matching_procptr_assignment)
1893 /* Procedure pointer component call: Look for argument list. */
1894 m = gfc_match_actual_arglist (sub_flag,
1895 &primary->value.compcall.actual);
1896 if (m == MATCH_ERROR)
1899 if (m == MATCH_NO && !gfc_matching_ptr_assignment
1900 && !matching_actual_arglist)
1902 gfc_error ("Procedure pointer component '%s' requires an "
1903 "argument list at %C", component->name);
1908 primary->expr_type = EXPR_PPC;
1913 if (component->as != NULL && !component->attr.proc_pointer)
1915 tail = extend_ref (primary, tail);
1916 tail->type = REF_ARRAY;
1918 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
1919 component->as->corank);
1923 else if (component->ts.type == BT_CLASS
1924 && CLASS_DATA (component)->as != NULL
1925 && !component->attr.proc_pointer)
1927 tail = extend_ref (primary, tail);
1928 tail->type = REF_ARRAY;
1930 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
1932 CLASS_DATA (component)->as->corank);
1937 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1938 || gfc_match_char ('%') != MATCH_YES)
1941 sym = component->ts.u.derived;
1946 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1948 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1950 gfc_set_default_type (sym, 0, sym->ns);
1951 primary->ts = sym->ts;
1956 if (primary->ts.type == BT_CHARACTER)
1958 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1962 primary->ref = substring;
1964 tail->next = substring;
1966 if (primary->expr_type == EXPR_CONSTANT)
1967 primary->expr_type = EXPR_SUBSTRING;
1970 primary->ts.u.cl = NULL;
1977 gfc_clear_ts (&primary->ts);
1978 gfc_clear_ts (&sym->ts);
1988 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
1990 gfc_error ("Coindexed procedure-pointer component at %C");
1998 /* Given an expression that is a variable, figure out what the
1999 ultimate variable's type and attribute is, traversing the reference
2000 structures if necessary.
2002 This subroutine is trickier than it looks. We start at the base
2003 symbol and store the attribute. Component references load a
2004 completely new attribute.
2006 A couple of rules come into play. Subobjects of targets are always
2007 targets themselves. If we see a component that goes through a
2008 pointer, then the expression must also be a target, since the
2009 pointer is associated with something (if it isn't core will soon be
2010 dumped). If we see a full part or section of an array, the
2011 expression is also an array.
2013 We can have at most one full array reference. */
2016 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2018 int dimension, pointer, allocatable, target;
2019 symbol_attribute attr;
2022 gfc_component *comp;
2024 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2025 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2027 sym = expr->symtree->n.sym;
2030 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2032 dimension = CLASS_DATA (sym)->attr.dimension;
2033 pointer = CLASS_DATA (sym)->attr.class_pointer;
2034 allocatable = CLASS_DATA (sym)->attr.allocatable;
2038 dimension = attr.dimension;
2039 pointer = attr.pointer;
2040 allocatable = attr.allocatable;
2043 target = attr.target;
2044 if (pointer || attr.proc_pointer)
2047 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2050 for (ref = expr->ref; ref; ref = ref->next)
2055 switch (ref->u.ar.type)
2062 allocatable = pointer = 0;
2067 /* Handle coarrays. */
2068 if (ref->u.ar.dimen > 0)
2069 allocatable = pointer = 0;
2073 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2079 comp = ref->u.c.component;
2084 /* Don't set the string length if a substring reference
2086 if (ts->type == BT_CHARACTER
2087 && ref->next && ref->next->type == REF_SUBSTRING)
2091 if (comp->ts.type == BT_CLASS)
2093 pointer = CLASS_DATA (comp)->attr.class_pointer;
2094 allocatable = CLASS_DATA (comp)->attr.allocatable;
2098 pointer = comp->attr.pointer;
2099 allocatable = comp->attr.allocatable;
2101 if (pointer || attr.proc_pointer)
2107 allocatable = pointer = 0;
2111 attr.dimension = dimension;
2112 attr.pointer = pointer;
2113 attr.allocatable = allocatable;
2114 attr.target = target;
2115 attr.save = sym->attr.save;
2121 /* Return the attribute from a general expression. */
2124 gfc_expr_attr (gfc_expr *e)
2126 symbol_attribute attr;
2128 switch (e->expr_type)
2131 attr = gfc_variable_attr (e, NULL);
2135 gfc_clear_attr (&attr);
2137 if (e->value.function.esym != NULL)
2139 gfc_symbol *sym = e->value.function.esym->result;
2141 if (sym->ts.type == BT_CLASS)
2143 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2144 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2145 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2149 attr = gfc_variable_attr (e, NULL);
2151 /* TODO: NULL() returns pointers. May have to take care of this
2157 gfc_clear_attr (&attr);
2165 /* Match a structure constructor. The initial symbol has already been
2168 typedef struct gfc_structure_ctor_component
2173 struct gfc_structure_ctor_component* next;
2175 gfc_structure_ctor_component;
2177 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2180 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2182 gfc_free (comp->name);
2183 gfc_free_expr (comp->val);
2188 /* Translate the component list into the actual constructor by sorting it in
2189 the order required; this also checks along the way that each and every
2190 component actually has an initializer and handles default initializers
2191 for components without explicit value given. */
2193 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2194 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2196 gfc_structure_ctor_component *comp_iter;
2197 gfc_component *comp;
2199 for (comp = sym->components; comp; comp = comp->next)
2201 gfc_structure_ctor_component **next_ptr;
2202 gfc_expr *value = NULL;
2204 /* Try to find the initializer for the current component by name. */
2205 next_ptr = comp_head;
2206 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2208 if (!strcmp (comp_iter->name, comp->name))
2210 next_ptr = &comp_iter->next;
2213 /* If an extension, try building the parent derived type by building
2214 a value expression for the parent derived type and calling self. */
2215 if (!comp_iter && comp == sym->components && sym->attr.extension)
2217 value = gfc_get_structure_constructor_expr (comp->ts.type,
2219 &gfc_current_locus);
2220 value->ts = comp->ts;
2222 if (build_actual_constructor (comp_head, &value->value.constructor,
2223 comp->ts.u.derived) == FAILURE)
2225 gfc_free_expr (value);
2229 gfc_constructor_append_expr (ctor_head, value, NULL);
2233 /* If it was not found, try the default initializer if there's any;
2234 otherwise, it's an error. */
2237 if (comp->initializer)
2239 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2240 " constructor with missing optional arguments"
2241 " at %C") == FAILURE)
2243 value = gfc_copy_expr (comp->initializer);
2247 gfc_error ("No initializer for component '%s' given in the"
2248 " structure constructor at %C!", comp->name);
2253 value = comp_iter->val;
2255 /* Add the value to the constructor chain built. */
2256 gfc_constructor_append_expr (ctor_head, value, NULL);
2258 /* Remove the entry from the component list. We don't want the expression
2259 value to be free'd, so set it to NULL. */
2262 *next_ptr = comp_iter->next;
2263 comp_iter->val = NULL;
2264 gfc_free_structure_ctor_component (comp_iter);
2271 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2274 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2275 gfc_constructor_base ctor_head = NULL;
2276 gfc_component *comp; /* Is set NULL when named component is first seen */
2280 const char* last_name = NULL;
2282 comp_tail = comp_head = NULL;
2284 if (!parent && gfc_match_char ('(') != MATCH_YES)
2287 where = gfc_current_locus;
2289 gfc_find_component (sym, NULL, false, true);
2291 /* Check that we're not about to construct an ABSTRACT type. */
2292 if (!parent && sym->attr.abstract)
2294 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2298 /* Match the component list and store it in a list together with the
2299 corresponding component names. Check for empty argument list first. */
2300 if (gfc_match_char (')') != MATCH_YES)
2302 comp = sym->components;
2305 gfc_component *this_comp = NULL;
2307 if (comp == sym->components && sym->attr.extension
2308 && comp->ts.type == BT_DERIVED
2309 && comp->ts.u.derived->attr.zero_comp)
2310 /* Skip empty parents. */
2314 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2317 comp_tail->next = gfc_get_structure_ctor_component ();
2318 comp_tail = comp_tail->next;
2320 comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2321 comp_tail->val = NULL;
2322 comp_tail->where = gfc_current_locus;
2324 /* Try matching a component name. */
2325 if (gfc_match_name (comp_tail->name) == MATCH_YES
2326 && gfc_match_char ('=') == MATCH_YES)
2328 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2329 " constructor with named arguments at %C")
2333 last_name = comp_tail->name;
2338 /* Components without name are not allowed after the first named
2339 component initializer! */
2343 gfc_error ("Component initializer without name after"
2344 " component named %s at %C!", last_name);
2346 gfc_error ("Too many components in structure constructor at"
2351 gfc_current_locus = comp_tail->where;
2352 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2355 /* Find the current component in the structure definition and check
2356 its access is not private. */
2358 this_comp = gfc_find_component (sym, comp->name, false, false);
2361 this_comp = gfc_find_component (sym,
2362 (const char *)comp_tail->name,
2364 comp = NULL; /* Reset needed! */
2367 /* Here we can check if a component name is given which does not
2368 correspond to any component of the defined structure. */
2372 /* Check if this component is already given a value. */
2373 for (comp_iter = comp_head; comp_iter != comp_tail;
2374 comp_iter = comp_iter->next)
2376 gcc_assert (comp_iter);
2377 if (!strcmp (comp_iter->name, comp_tail->name))
2379 gfc_error ("Component '%s' is initialized twice in the"
2380 " structure constructor at %C!", comp_tail->name);
2385 /* Match the current initializer expression. */
2386 m = gfc_match_expr (&comp_tail->val);
2389 if (m == MATCH_ERROR)
2392 /* F2008, R457/C725, for PURE C1283. */
2393 if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
2395 gfc_error ("Coindexed expression to pointer component '%s' in "
2396 "structure constructor at %C!", comp_tail->name);
2401 /* If not explicitly a parent constructor, gather up the components
2403 if (comp && comp == sym->components
2404 && sym->attr.extension
2405 && (comp_tail->val->ts.type != BT_DERIVED
2407 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2409 gfc_current_locus = where;
2410 gfc_free_expr (comp_tail->val);
2411 comp_tail->val = NULL;
2413 m = gfc_match_structure_constructor (comp->ts.u.derived,
2414 &comp_tail->val, true);
2417 if (m == MATCH_ERROR)
2424 if (parent && !comp)
2428 while (gfc_match_char (',') == MATCH_YES);
2430 if (!parent && gfc_match_char (')') != MATCH_YES)
2434 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2437 /* No component should be left, as this should have caused an error in the
2438 loop constructing the component-list (name that does not correspond to any
2439 component in the structure definition). */
2442 gcc_assert (sym->attr.extension);
2443 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2445 gfc_error ("component '%s' at %L has already been set by a "
2446 "parent derived type constructor", comp_iter->name,
2452 e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
2453 e->ts.u.derived = sym;
2454 e->value.constructor = ctor_head;
2460 gfc_error ("Syntax error in structure constructor at %C");
2463 for (comp_iter = comp_head; comp_iter; )
2465 gfc_structure_ctor_component *next = comp_iter->next;
2466 gfc_free_structure_ctor_component (comp_iter);
2469 gfc_constructor_free (ctor_head);
2474 /* If the symbol is an implicit do loop index and implicitly typed,
2475 it should not be host associated. Provide a symtree from the
2476 current namespace. */
2478 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2480 if ((*sym)->attr.flavor == FL_VARIABLE
2481 && (*sym)->ns != gfc_current_ns
2482 && (*sym)->attr.implied_index
2483 && (*sym)->attr.implicit_type
2484 && !(*sym)->attr.use_assoc)
2487 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2490 *sym = (*st)->n.sym;
2496 /* Procedure pointer as function result: Replace the function symbol by the
2497 auto-generated hidden result variable named "ppr@". */
2500 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2502 /* Check for procedure pointer result variable. */
2503 if ((*sym)->attr.function && !(*sym)->attr.external
2504 && (*sym)->result && (*sym)->result != *sym
2505 && (*sym)->result->attr.proc_pointer
2506 && (*sym) == gfc_current_ns->proc_name
2507 && (*sym) == (*sym)->result->ns->proc_name
2508 && strcmp ("ppr@", (*sym)->result->name) == 0)
2510 /* Automatic replacement with "hidden" result variable. */
2511 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2512 *sym = (*sym)->result;
2513 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2520 /* Matches a variable name followed by anything that might follow it--
2521 array reference, argument list of a function, etc. */
2524 gfc_match_rvalue (gfc_expr **result)
2526 gfc_actual_arglist *actual_arglist;
2527 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2530 gfc_symtree *symtree;
2531 locus where, old_loc;
2539 m = gfc_match_name (name);
2543 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2544 && !gfc_current_ns->has_import_set)
2545 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2547 i = gfc_get_ha_sym_tree (name, &symtree);
2552 sym = symtree->n.sym;
2554 where = gfc_current_locus;
2556 replace_hidden_procptr_result (&sym, &symtree);
2558 /* If this is an implicit do loop index and implicitly typed,
2559 it should not be host associated. */
2560 m = check_for_implicit_index (&symtree, &sym);
2564 gfc_set_sym_referenced (sym);
2565 sym->attr.implied_index = 0;
2567 if (sym->attr.function && sym->result == sym)
2569 /* See if this is a directly recursive function call. */
2570 gfc_gobble_whitespace ();
2571 if (sym->attr.recursive
2572 && gfc_peek_ascii_char () == '('
2573 && gfc_current_ns->proc_name == sym
2574 && !sym->attr.dimension)
2576 gfc_error ("'%s' at %C is the name of a recursive function "
2577 "and so refers to the result variable. Use an "
2578 "explicit RESULT variable for direct recursion "
2579 "(12.5.2.1)", sym->name);
2583 if (gfc_is_function_return_value (sym, gfc_current_ns))
2587 && (sym->ns == gfc_current_ns
2588 || sym->ns == gfc_current_ns->parent))
2590 gfc_entry_list *el = NULL;
2592 for (el = sym->ns->entries; el; el = el->next)
2598 if (gfc_matching_procptr_assignment)
2601 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2604 if (sym->attr.generic)
2605 goto generic_function;
2607 switch (sym->attr.flavor)
2611 e = gfc_get_expr ();
2613 e->expr_type = EXPR_VARIABLE;
2614 e->symtree = symtree;
2616 m = gfc_match_varspec (e, 0, false, true);
2620 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2621 end up here. Unfortunately, sym->value->expr_type is set to
2622 EXPR_CONSTANT, and so the if () branch would be followed without
2623 the !sym->as check. */
2624 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2625 e = gfc_copy_expr (sym->value);
2628 e = gfc_get_expr ();
2629 e->expr_type = EXPR_VARIABLE;
2632 e->symtree = symtree;
2633 m = gfc_match_varspec (e, 0, false, true);
2635 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2638 /* Variable array references to derived type parameters cause
2639 all sorts of headaches in simplification. Treating such
2640 expressions as variable works just fine for all array
2642 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2644 for (ref = e->ref; ref; ref = ref->next)
2645 if (ref->type == REF_ARRAY)
2648 if (ref == NULL || ref->u.ar.type == AR_FULL)
2654 e = gfc_get_expr ();
2655 e->expr_type = EXPR_VARIABLE;
2656 e->symtree = symtree;
2663 sym = gfc_use_derived (sym);
2667 m = gfc_match_structure_constructor (sym, &e, false);
2670 /* If we're here, then the name is known to be the name of a
2671 procedure, yet it is not sure to be the name of a function. */
2674 /* Procedure Pointer Assignments. */
2676 if (gfc_matching_procptr_assignment)
2678 gfc_gobble_whitespace ();
2679 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2680 /* Parse functions returning a procptr. */
2683 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2684 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2685 sym->attr.intrinsic = 1;
2686 e = gfc_get_expr ();
2687 e->expr_type = EXPR_VARIABLE;
2688 e->symtree = symtree;
2689 m = gfc_match_varspec (e, 0, false, true);
2693 if (sym->attr.subroutine)
2695 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2701 /* At this point, the name has to be a non-statement function.
2702 If the name is the same as the current function being
2703 compiled, then we have a variable reference (to the function
2704 result) if the name is non-recursive. */
2706 st = gfc_enclosing_unit (NULL);
2708 if (st != NULL && st->state == COMP_FUNCTION
2710 && !sym->attr.recursive)
2712 e = gfc_get_expr ();
2713 e->symtree = symtree;
2714 e->expr_type = EXPR_VARIABLE;
2716 m = gfc_match_varspec (e, 0, false, true);
2720 /* Match a function reference. */
2722 m = gfc_match_actual_arglist (0, &actual_arglist);
2725 if (sym->attr.proc == PROC_ST_FUNCTION)
2726 gfc_error ("Statement function '%s' requires argument list at %C",
2729 gfc_error ("Function '%s' requires an argument list at %C",
2742 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2743 sym = symtree->n.sym;
2745 replace_hidden_procptr_result (&sym, &symtree);
2747 e = gfc_get_expr ();
2748 e->symtree = symtree;
2749 e->expr_type = EXPR_FUNCTION;
2750 e->value.function.actual = actual_arglist;
2751 e->where = gfc_current_locus;
2753 if (sym->as != NULL)
2754 e->rank = sym->as->rank;
2756 if (!sym->attr.function
2757 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2763 /* Check here for the existence of at least one argument for the
2764 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2765 argument(s) given will be checked in gfc_iso_c_func_interface,
2766 during resolution of the function call. */
2767 if (sym->attr.is_iso_c == 1
2768 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2769 && (sym->intmod_sym_id == ISOCBINDING_LOC
2770 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2771 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2773 /* make sure we were given a param */
2774 if (actual_arglist == NULL)
2776 gfc_error ("Missing argument to '%s' at %C", sym->name);
2782 if (sym->result == NULL)
2790 /* Special case for derived type variables that get their types
2791 via an IMPLICIT statement. This can't wait for the
2792 resolution phase. */
2794 if (gfc_peek_ascii_char () == '%'
2795 && sym->ts.type == BT_UNKNOWN
2796 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2797 gfc_set_default_type (sym, 0, sym->ns);
2799 /* If the symbol has a dimension attribute, the expression is a
2802 if (sym->attr.dimension)
2804 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2805 sym->name, NULL) == FAILURE)
2811 e = gfc_get_expr ();
2812 e->symtree = symtree;
2813 e->expr_type = EXPR_VARIABLE;
2814 m = gfc_match_varspec (e, 0, false, true);
2818 /* Name is not an array, so we peek to see if a '(' implies a
2819 function call or a substring reference. Otherwise the
2820 variable is just a scalar. */
2822 gfc_gobble_whitespace ();
2823 if (gfc_peek_ascii_char () != '(')
2825 /* Assume a scalar variable */
2826 e = gfc_get_expr ();
2827 e->symtree = symtree;
2828 e->expr_type = EXPR_VARIABLE;
2830 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2831 sym->name, NULL) == FAILURE)
2837 /*FIXME:??? gfc_match_varspec does set this for us: */
2839 m = gfc_match_varspec (e, 0, false, true);
2843 /* See if this is a function reference with a keyword argument
2844 as first argument. We do this because otherwise a spurious
2845 symbol would end up in the symbol table. */
2847 old_loc = gfc_current_locus;
2848 m2 = gfc_match (" ( %n =", argname);
2849 gfc_current_locus = old_loc;
2851 e = gfc_get_expr ();
2852 e->symtree = symtree;
2854 if (m2 != MATCH_YES)
2856 /* Try to figure out whether we're dealing with a character type.
2857 We're peeking ahead here, because we don't want to call
2858 match_substring if we're dealing with an implicitly typed
2859 non-character variable. */
2860 implicit_char = false;
2861 if (sym->ts.type == BT_UNKNOWN)
2863 ts = gfc_get_default_type (sym->name, NULL);
2864 if (ts->type == BT_CHARACTER)
2865 implicit_char = true;
2868 /* See if this could possibly be a substring reference of a name
2869 that we're not sure is a variable yet. */
2871 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2872 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2875 e->expr_type = EXPR_VARIABLE;
2877 if (sym->attr.flavor != FL_VARIABLE
2878 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2879 sym->name, NULL) == FAILURE)
2885 if (sym->ts.type == BT_UNKNOWN
2886 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2900 /* Give up, assume we have a function. */
2902 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2903 sym = symtree->n.sym;
2904 e->expr_type = EXPR_FUNCTION;
2906 if (!sym->attr.function
2907 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2915 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2917 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2925 /* If our new function returns a character, array or structure
2926 type, it might have subsequent references. */
2928 m = gfc_match_varspec (e, 0, false, true);
2935 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2937 e = gfc_get_expr ();
2938 e->symtree = symtree;
2939 e->expr_type = EXPR_FUNCTION;
2941 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2945 gfc_error ("Symbol at %C is not appropriate for an expression");
2961 /* Match a variable, i.e. something that can be assigned to. This
2962 starts as a symbol, can be a structure component or an array
2963 reference. It can be a function if the function doesn't have a
2964 separate RESULT variable. If the symbol has not been previously
2965 seen, we assume it is a variable.
2967 This function is called by two interface functions:
2968 gfc_match_variable, which has host_flag = 1, and
2969 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2970 match of the symbol to the local scope. */
2973 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2981 /* Since nothing has any business being an lvalue in a module
2982 specification block, an interface block or a contains section,
2983 we force the changed_symbols mechanism to work by setting
2984 host_flag to 0. This prevents valid symbols that have the name
2985 of keywords, such as 'end', being turned into variables by
2986 failed matching to assignments for, e.g., END INTERFACE. */
2987 if (gfc_current_state () == COMP_MODULE
2988 || gfc_current_state () == COMP_INTERFACE
2989 || gfc_current_state () == COMP_CONTAINS)
2992 where = gfc_current_locus;
2993 m = gfc_match_sym_tree (&st, host_flag);
2999 /* If this is an implicit do loop index and implicitly typed,
3000 it should not be host associated. */
3001 m = check_for_implicit_index (&st, &sym);
3005 sym->attr.implied_index = 0;
3007 gfc_set_sym_referenced (sym);
3008 switch (sym->attr.flavor)
3011 /* Everything is alright. */
3016 sym_flavor flavor = FL_UNKNOWN;
3018 gfc_gobble_whitespace ();
3020 if (sym->attr.external || sym->attr.procedure
3021 || sym->attr.function || sym->attr.subroutine)
3022 flavor = FL_PROCEDURE;
3024 /* If it is not a procedure, is not typed and is host associated,
3025 we cannot give it a flavor yet. */
3026 else if (sym->ns == gfc_current_ns->parent
3027 && sym->ts.type == BT_UNKNOWN)
3030 /* These are definitive indicators that this is a variable. */
3031 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3032 || sym->attr.pointer || sym->as != NULL)
3033 flavor = FL_VARIABLE;
3035 if (flavor != FL_UNKNOWN
3036 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3044 gfc_error ("Named constant at %C in an EQUIVALENCE");
3047 /* Otherwise this is checked for and an error given in the
3048 variable definition context checks. */
3052 /* Check for a nonrecursive function result variable. */
3053 if (sym->attr.function
3054 && !sym->attr.external
3055 && sym->result == sym
3056 && (gfc_is_function_return_value (sym, gfc_current_ns)
3058 && sym->ns == gfc_current_ns)
3060 && sym->ns == gfc_current_ns->parent)))
3062 /* If a function result is a derived type, then the derived
3063 type may still have to be resolved. */
3065 if (sym->ts.type == BT_DERIVED
3066 && gfc_use_derived (sym->ts.u.derived) == NULL)
3071 if (sym->attr.proc_pointer
3072 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3075 /* Fall through to error */
3078 gfc_error ("'%s' at %C is not a variable", sym->name);
3082 /* Special case for derived type variables that get their types
3083 via an IMPLICIT statement. This can't wait for the
3084 resolution phase. */
3087 gfc_namespace * implicit_ns;
3089 if (gfc_current_ns->proc_name == sym)
3090 implicit_ns = gfc_current_ns;
3092 implicit_ns = sym->ns;
3094 if (gfc_peek_ascii_char () == '%'
3095 && sym->ts.type == BT_UNKNOWN
3096 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3097 gfc_set_default_type (sym, 0, implicit_ns);
3100 expr = gfc_get_expr ();
3102 expr->expr_type = EXPR_VARIABLE;
3105 expr->where = where;
3107 /* Now see if we have to do more. */
3108 m = gfc_match_varspec (expr, equiv_flag, false, false);
3111 gfc_free_expr (expr);
3121 gfc_match_variable (gfc_expr **result, int equiv_flag)
3123 return match_variable (result, equiv_flag, 1);
3128 gfc_match_equiv_variable (gfc_expr **result)
3130 return match_variable (result, 1, 0);