1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
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/>. */
31 /* Matches a kind-parameter expression, which is either a named
32 symbolic constant or a nonnegative integer constant. If
33 successful, sets the kind value to the correct integer. */
36 match_kind_param (int *kind)
38 char name[GFC_MAX_SYMBOL_LEN + 1];
43 m = gfc_match_small_literal_int (kind, NULL);
47 m = gfc_match_name (name);
51 if (gfc_find_symbol (name, NULL, 1, &sym))
57 if (sym->attr.flavor != FL_PARAMETER)
60 if (sym->value == NULL)
63 p = gfc_extract_int (sym->value, kind);
67 gfc_set_sym_referenced (sym);
76 /* Get a trailing kind-specification for non-character variables.
78 the integer kind value or:
79 -1 if an error was generated
80 -2 if no kind was found */
88 if (gfc_match_char ('_') != MATCH_YES)
91 m = match_kind_param (&kind);
93 gfc_error ("Missing kind-parameter at %C");
95 return (m == MATCH_YES) ? kind : -1;
99 /* Given a character and a radix, see if the character is a valid
100 digit in that radix. */
103 gfc_check_digit (char c, int radix)
110 r = ('0' <= c && c <= '1');
114 r = ('0' <= c && c <= '7');
118 r = ('0' <= c && c <= '9');
126 gfc_internal_error ("gfc_check_digit(): bad radix");
133 /* Match the digit string part of an integer if signflag is not set,
134 the signed digit string part if signflag is set. If the buffer
135 is NULL, we just count characters for the resolution pass. Returns
136 the number of characters matched, -1 for no match. */
139 match_digits (int signflag, int radix, char *buffer)
146 c = gfc_next_ascii_char ();
148 if (signflag && (c == '+' || c == '-'))
152 gfc_gobble_whitespace ();
153 c = gfc_next_ascii_char ();
157 if (!gfc_check_digit (c, radix))
166 old_loc = gfc_current_locus;
167 c = gfc_next_ascii_char ();
169 if (!gfc_check_digit (c, radix))
177 gfc_current_locus = old_loc;
183 /* Match an integer (digit string and optional kind).
184 A sign will be accepted if signflag is set. */
187 match_integer_constant (gfc_expr **result, int signflag)
194 old_loc = gfc_current_locus;
195 gfc_gobble_whitespace ();
197 length = match_digits (signflag, 10, NULL);
198 gfc_current_locus = old_loc;
202 buffer = (char *) alloca (length + 1);
203 memset (buffer, '\0', length + 1);
205 gfc_gobble_whitespace ();
207 match_digits (signflag, 10, buffer);
211 kind = gfc_default_integer_kind;
215 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
217 gfc_error ("Integer kind %d at %C not available", kind);
221 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
223 if (gfc_range_check (e) != ARITH_OK)
225 gfc_error ("Integer too big for its kind at %C. This check can be "
226 "disabled with the option -fno-range-check");
237 /* Match a Hollerith constant. */
240 match_hollerith_constant (gfc_expr **result)
248 old_loc = gfc_current_locus;
249 gfc_gobble_whitespace ();
251 if (match_integer_constant (&e, 0) == MATCH_YES
252 && gfc_match_char ('h') == MATCH_YES)
254 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
258 msg = gfc_extract_int (e, &num);
266 gfc_error ("Invalid Hollerith constant: %L must contain at least "
267 "one character", &old_loc);
270 if (e->ts.kind != gfc_default_integer_kind)
272 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
273 "should be default", &old_loc);
279 e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
282 e->representation.string = XCNEWVEC (char, num + 1);
284 for (i = 0; i < num; i++)
286 gfc_char_t c = gfc_next_char_literal (1);
287 if (! gfc_wide_fits_in_byte (c))
289 gfc_error ("Invalid Hollerith constant at %L contains a "
290 "wide character", &old_loc);
294 e->representation.string[i] = (unsigned char) c;
297 e->representation.string[num] = '\0';
298 e->representation.length = num;
306 gfc_current_locus = old_loc;
315 /* Match a binary, octal or hexadecimal constant that can be found in
316 a DATA statement. The standard permits b'010...', o'73...', and
317 z'a1...' where b, o, and z can be capital letters. This function
318 also accepts postfixed forms of the constants: '01...'b, '73...'o,
319 and 'a1...'z. An additional extension is the use of x for z. */
322 match_boz_constant (gfc_expr **result)
324 int radix, length, x_hex, kind;
325 locus old_loc, start_loc;
326 char *buffer, post, delim;
329 start_loc = old_loc = gfc_current_locus;
330 gfc_gobble_whitespace ();
333 switch (post = gfc_next_ascii_char ())
355 radix = 16; /* Set to accept any valid digit string. */
361 /* No whitespace allowed here. */
364 delim = gfc_next_ascii_char ();
366 if (delim != '\'' && delim != '\"')
370 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
371 "constant at %C uses non-standard syntax")
375 old_loc = gfc_current_locus;
377 length = match_digits (0, radix, NULL);
380 gfc_error ("Empty set of digits in BOZ constant at %C");
384 if (gfc_next_ascii_char () != delim)
386 gfc_error ("Illegal character in BOZ constant at %C");
392 switch (gfc_next_ascii_char ())
409 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
410 "at %C uses non-standard postfix syntax")
415 gfc_current_locus = old_loc;
417 buffer = (char *) alloca (length + 1);
418 memset (buffer, '\0', length + 1);
420 match_digits (0, radix, buffer);
421 gfc_next_ascii_char (); /* Eat delimiter. */
423 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
425 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
426 "If a data-stmt-constant is a boz-literal-constant, the corresponding
427 variable shall be of type integer. The boz-literal-constant is treated
428 as if it were an int-literal-constant with a kind-param that specifies
429 the representation method with the largest decimal exponent range
430 supported by the processor." */
432 kind = gfc_max_integer_kind;
433 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
435 /* Mark as boz variable. */
438 if (gfc_range_check (e) != ARITH_OK)
440 gfc_error ("Integer too big for integer kind %i at %C", kind);
445 if (!gfc_in_match_data ()
446 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
455 gfc_current_locus = start_loc;
460 /* Match a real constant of some sort. Allow a signed constant if signflag
464 match_real_constant (gfc_expr **result, int signflag)
466 int kind, count, seen_dp, seen_digits;
467 locus old_loc, temp_loc;
468 char *p, *buffer, c, exp_char;
472 old_loc = gfc_current_locus;
473 gfc_gobble_whitespace ();
483 c = gfc_next_ascii_char ();
484 if (signflag && (c == '+' || c == '-'))
489 gfc_gobble_whitespace ();
490 c = gfc_next_ascii_char ();
493 /* Scan significand. */
494 for (;; c = gfc_next_ascii_char (), count++)
501 /* Check to see if "." goes with a following operator like
503 temp_loc = gfc_current_locus;
504 c = gfc_next_ascii_char ();
506 if (c == 'e' || c == 'd' || c == 'q')
508 c = gfc_next_ascii_char ();
510 goto done; /* Operator named .e. or .d. */
514 goto done; /* Distinguish 1.e9 from 1.eq.2 */
516 gfc_current_locus = temp_loc;
530 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
535 c = gfc_next_ascii_char ();
538 if (c == '+' || c == '-')
539 { /* optional sign */
540 c = gfc_next_ascii_char ();
546 gfc_error ("Missing exponent in real number at %C");
552 c = gfc_next_ascii_char ();
557 /* Check that we have a numeric constant. */
558 if (!seen_digits || (!seen_dp && exp_char == ' '))
560 gfc_current_locus = old_loc;
564 /* Convert the number. */
565 gfc_current_locus = old_loc;
566 gfc_gobble_whitespace ();
568 buffer = (char *) alloca (count + 1);
569 memset (buffer, '\0', count + 1);
572 c = gfc_next_ascii_char ();
573 if (c == '+' || c == '-')
575 gfc_gobble_whitespace ();
576 c = gfc_next_ascii_char ();
579 /* Hack for mpfr_set_str(). */
582 if (c == 'd' || c == 'q')
590 c = gfc_next_ascii_char ();
602 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
606 kind = gfc_default_double_kind;
611 kind = gfc_default_real_kind;
613 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
615 gfc_error ("Invalid real kind %d at %C", kind);
620 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
622 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
624 switch (gfc_range_check (e))
629 gfc_error ("Real constant overflows its kind at %C");
632 case ARITH_UNDERFLOW:
633 if (gfc_option.warn_underflow)
634 gfc_warning ("Real constant underflows its kind at %C");
635 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
639 gfc_internal_error ("gfc_range_check() returned bad value");
651 /* Match a substring reference. */
654 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
656 gfc_expr *start, *end;
664 old_loc = gfc_current_locus;
666 m = gfc_match_char ('(');
670 if (gfc_match_char (':') != MATCH_YES)
673 m = gfc_match_init_expr (&start);
675 m = gfc_match_expr (&start);
683 m = gfc_match_char (':');
688 if (gfc_match_char (')') != MATCH_YES)
691 m = gfc_match_init_expr (&end);
693 m = gfc_match_expr (&end);
697 if (m == MATCH_ERROR)
700 m = gfc_match_char (')');
705 /* Optimize away the (:) reference. */
706 if (start == NULL && end == NULL)
710 ref = gfc_get_ref ();
712 ref->type = REF_SUBSTRING;
714 start = gfc_int_expr (1);
715 ref->u.ss.start = start;
716 if (end == NULL && cl)
717 end = gfc_copy_expr (cl->length);
719 ref->u.ss.length = cl;
726 gfc_error ("Syntax error in SUBSTRING specification at %C");
730 gfc_free_expr (start);
733 gfc_current_locus = old_loc;
738 /* Reads the next character of a string constant, taking care to
739 return doubled delimiters on the input as a single instance of
742 Special return values for "ret" argument are:
743 -1 End of the string, as determined by the delimiter
744 -2 Unterminated string detected
746 Backslash codes are also expanded at this time. */
749 next_string_char (gfc_char_t delimiter, int *ret)
754 c = gfc_next_char_literal (1);
763 if (gfc_option.flag_backslash && c == '\\')
765 old_locus = gfc_current_locus;
767 if (gfc_match_special_char (&c) == MATCH_NO)
768 gfc_current_locus = old_locus;
770 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
771 gfc_warning ("Extension: backslash character at %C");
777 old_locus = gfc_current_locus;
778 c = gfc_next_char_literal (0);
782 gfc_current_locus = old_locus;
789 /* Special case of gfc_match_name() that matches a parameter kind name
790 before a string constant. This takes case of the weird but legal
795 where kind____ is a parameter. gfc_match_name() will happily slurp
796 up all the underscores, which leads to problems. If we return
797 MATCH_YES, the parse pointer points to the final underscore, which
798 is not part of the name. We never return MATCH_ERROR-- errors in
799 the name will be detected later. */
802 match_charkind_name (char *name)
808 gfc_gobble_whitespace ();
809 c = gfc_next_ascii_char ();
818 old_loc = gfc_current_locus;
819 c = gfc_next_ascii_char ();
823 peek = gfc_peek_ascii_char ();
825 if (peek == '\'' || peek == '\"')
827 gfc_current_locus = old_loc;
835 && (c != '$' || !gfc_option.flag_dollar_ok))
839 if (++len > GFC_MAX_SYMBOL_LEN)
847 /* See if the current input matches a character constant. Lots of
848 contortions have to be done to match the kind parameter which comes
849 before the actual string. The main consideration is that we don't
850 want to error out too quickly. For example, we don't actually do
851 any validation of the kinds until we have actually seen a legal
852 delimiter. Using match_kind_param() generates errors too quickly. */
855 match_string_constant (gfc_expr **result)
857 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
858 int i, kind, length, warn_ampersand, ret;
859 locus old_locus, start_locus;
864 gfc_char_t c, delimiter, *p;
866 old_locus = gfc_current_locus;
868 gfc_gobble_whitespace ();
870 start_locus = gfc_current_locus;
872 c = gfc_next_char ();
873 if (c == '\'' || c == '"')
875 kind = gfc_default_character_kind;
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 ();
919 start_locus = gfc_current_locus;
921 c = gfc_next_char ();
922 if (c != '\'' && c != '"')
927 q = gfc_extract_int (sym->value, &kind);
933 gfc_set_sym_referenced (sym);
936 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
938 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
943 /* Scan the string into a block of memory by first figuring out how
944 long it is, allocating the structure, then re-reading it. This
945 isn't particularly efficient, but string constants aren't that
946 common in most code. TODO: Use obstacks? */
953 c = next_string_char (delimiter, &ret);
958 gfc_current_locus = start_locus;
959 gfc_error ("Unterminated character constant beginning at %C");
966 /* Peek at the next character to see if it is a b, o, z, or x for the
967 postfixed BOZ literal constants. */
968 peek = gfc_peek_ascii_char ();
969 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
975 e->expr_type = EXPR_CONSTANT;
977 e->ts.type = BT_CHARACTER;
979 e->ts.is_c_interop = 0;
981 e->where = start_locus;
983 e->value.character.string = p = gfc_get_wide_string (length + 1);
984 e->value.character.length = length;
986 gfc_current_locus = start_locus;
987 gfc_next_char (); /* Skip delimiter */
989 /* We disable the warning for the following loop as the warning has already
990 been printed in the loop above. */
991 warn_ampersand = gfc_option.warn_ampersand;
992 gfc_option.warn_ampersand = 0;
994 for (i = 0; i < length; i++)
996 c = next_string_char (delimiter, &ret);
998 if (!gfc_check_character_range (c, kind))
1000 gfc_error ("Character '%s' in string at %C is not representable "
1001 "in character kind %d", gfc_print_wide_char (c), kind);
1008 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1009 gfc_option.warn_ampersand = warn_ampersand;
1011 next_string_char (delimiter, &ret);
1013 gfc_internal_error ("match_string_constant(): Delimiter not found");
1015 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1016 e->expr_type = EXPR_SUBSTRING;
1023 gfc_current_locus = old_locus;
1028 /* Match a .true. or .false. Returns 1 if a .true. was found,
1029 0 if a .false. was found, and -1 otherwise. */
1031 match_logical_constant_string (void)
1033 locus orig_loc = gfc_current_locus;
1035 gfc_gobble_whitespace ();
1036 if (gfc_next_ascii_char () == '.')
1038 char ch = gfc_next_ascii_char ();
1041 if (gfc_next_ascii_char () == 'a'
1042 && gfc_next_ascii_char () == 'l'
1043 && gfc_next_ascii_char () == 's'
1044 && gfc_next_ascii_char () == 'e'
1045 && gfc_next_ascii_char () == '.')
1046 /* Matched ".false.". */
1051 if (gfc_next_ascii_char () == 'r'
1052 && gfc_next_ascii_char () == 'u'
1053 && gfc_next_ascii_char () == 'e'
1054 && gfc_next_ascii_char () == '.')
1055 /* Matched ".true.". */
1059 gfc_current_locus = orig_loc;
1063 /* Match a .true. or .false. */
1066 match_logical_constant (gfc_expr **result)
1071 i = match_logical_constant_string ();
1079 kind = gfc_default_logical_kind;
1081 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1083 gfc_error ("Bad kind for logical constant at %C");
1087 e = gfc_get_expr ();
1089 e->expr_type = EXPR_CONSTANT;
1090 e->value.logical = i;
1091 e->ts.type = BT_LOGICAL;
1093 e->ts.is_c_interop = 0;
1095 e->where = gfc_current_locus;
1102 /* Match a real or imaginary part of a complex constant that is a
1103 symbolic constant. */
1106 match_sym_complex_part (gfc_expr **result)
1108 char name[GFC_MAX_SYMBOL_LEN + 1];
1113 m = gfc_match_name (name);
1117 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1120 if (sym->attr.flavor != FL_PARAMETER)
1122 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1126 if (!gfc_numeric_ts (&sym->value->ts))
1128 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1132 if (sym->value->rank != 0)
1134 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1138 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1139 "complex constant at %C") == FAILURE)
1142 switch (sym->value->ts.type)
1145 e = gfc_copy_expr (sym->value);
1149 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1155 e = gfc_int2real (sym->value, gfc_default_real_kind);
1161 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1164 *result = e; /* e is a scalar, real, constant expression. */
1168 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1173 /* Match a real or imaginary part of a complex number. */
1176 match_complex_part (gfc_expr **result)
1180 m = match_sym_complex_part (result);
1184 m = match_real_constant (result, 1);
1188 return match_integer_constant (result, 1);
1192 /* Try to match a complex constant. */
1195 match_complex_constant (gfc_expr **result)
1197 gfc_expr *e, *real, *imag;
1198 gfc_error_buf old_error;
1199 gfc_typespec target;
1204 old_loc = gfc_current_locus;
1205 real = imag = e = NULL;
1207 m = gfc_match_char ('(');
1211 gfc_push_error (&old_error);
1213 m = match_complex_part (&real);
1216 gfc_free_error (&old_error);
1220 if (gfc_match_char (',') == MATCH_NO)
1222 gfc_pop_error (&old_error);
1227 /* If m is error, then something was wrong with the real part and we
1228 assume we have a complex constant because we've seen the ','. An
1229 ambiguous case here is the start of an iterator list of some
1230 sort. These sort of lists are matched prior to coming here. */
1232 if (m == MATCH_ERROR)
1234 gfc_free_error (&old_error);
1237 gfc_pop_error (&old_error);
1239 m = match_complex_part (&imag);
1242 if (m == MATCH_ERROR)
1245 m = gfc_match_char (')');
1248 /* Give the matcher for implied do-loops a chance to run. This
1249 yields a much saner error message for (/ (i, 4=i, 6) /). */
1250 if (gfc_peek_ascii_char () == '=')
1259 if (m == MATCH_ERROR)
1262 /* Decide on the kind of this complex number. */
1263 if (real->ts.type == BT_REAL)
1265 if (imag->ts.type == BT_REAL)
1266 kind = gfc_kind_max (real, imag);
1268 kind = real->ts.kind;
1272 if (imag->ts.type == BT_REAL)
1273 kind = imag->ts.kind;
1275 kind = gfc_default_real_kind;
1277 target.type = BT_REAL;
1279 target.is_c_interop = 0;
1280 target.is_iso_c = 0;
1282 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1283 gfc_convert_type (real, &target, 2);
1284 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1285 gfc_convert_type (imag, &target, 2);
1287 e = gfc_convert_complex (real, imag, kind);
1288 e->where = gfc_current_locus;
1290 gfc_free_expr (real);
1291 gfc_free_expr (imag);
1297 gfc_error ("Syntax error in COMPLEX constant at %C");
1302 gfc_free_expr (real);
1303 gfc_free_expr (imag);
1304 gfc_current_locus = old_loc;
1310 /* Match constants in any of several forms. Returns nonzero for a
1311 match, zero for no match. */
1314 gfc_match_literal_constant (gfc_expr **result, int signflag)
1318 m = match_complex_constant (result);
1322 m = match_string_constant (result);
1326 m = match_boz_constant (result);
1330 m = match_real_constant (result, signflag);
1334 m = match_hollerith_constant (result);
1338 m = match_integer_constant (result, signflag);
1342 m = match_logical_constant (result);
1350 /* This checks if a symbol is the return value of an encompassing function.
1351 Function nesting can be maximally two levels deep, but we may have
1352 additional local namespaces like BLOCK etc. */
1355 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1357 if (!sym->attr.function || (sym->result != sym))
1361 if (ns->proc_name == sym)
1369 /* Match a single actual argument value. An actual argument is
1370 usually an expression, but can also be a procedure name. If the
1371 argument is a single name, it is not always possible to tell
1372 whether the name is a dummy procedure or not. We treat these cases
1373 by creating an argument that looks like a dummy procedure and
1374 fixing things later during resolution. */
1377 match_actual_arg (gfc_expr **result)
1379 char name[GFC_MAX_SYMBOL_LEN + 1];
1380 gfc_symtree *symtree;
1385 gfc_gobble_whitespace ();
1386 where = gfc_current_locus;
1388 switch (gfc_match_name (name))
1397 w = gfc_current_locus;
1398 gfc_gobble_whitespace ();
1399 c = gfc_next_ascii_char ();
1400 gfc_current_locus = w;
1402 if (c != ',' && c != ')')
1405 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1407 /* Handle error elsewhere. */
1409 /* Eliminate a couple of common cases where we know we don't
1410 have a function argument. */
1411 if (symtree == NULL)
1413 gfc_get_sym_tree (name, NULL, &symtree, false);
1414 gfc_set_sym_referenced (symtree->n.sym);
1420 sym = symtree->n.sym;
1421 gfc_set_sym_referenced (sym);
1422 if (sym->attr.flavor != FL_PROCEDURE
1423 && sym->attr.flavor != FL_UNKNOWN)
1426 if (sym->attr.in_common && !sym->attr.proc_pointer)
1428 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1433 /* If the symbol is a function with itself as the result and
1434 is being defined, then we have a variable. */
1435 if (sym->attr.function && sym->result == sym)
1437 if (gfc_is_function_return_value (sym, gfc_current_ns))
1441 && (sym->ns == gfc_current_ns
1442 || sym->ns == gfc_current_ns->parent))
1444 gfc_entry_list *el = NULL;
1446 for (el = sym->ns->entries; el; el = el->next)
1456 e = gfc_get_expr (); /* Leave it unknown for now */
1457 e->symtree = symtree;
1458 e->expr_type = EXPR_VARIABLE;
1459 e->ts.type = BT_PROCEDURE;
1466 gfc_current_locus = where;
1467 return gfc_match_expr (result);
1471 /* Match a keyword argument. */
1474 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1476 char name[GFC_MAX_SYMBOL_LEN + 1];
1477 gfc_actual_arglist *a;
1481 name_locus = gfc_current_locus;
1482 m = gfc_match_name (name);
1486 if (gfc_match_char ('=') != MATCH_YES)
1492 m = match_actual_arg (&actual->expr);
1496 /* Make sure this name has not appeared yet. */
1498 if (name[0] != '\0')
1500 for (a = base; a; a = a->next)
1501 if (a->name != NULL && strcmp (a->name, name) == 0)
1503 gfc_error ("Keyword '%s' at %C has already appeared in the "
1504 "current argument list", name);
1509 actual->name = gfc_get_string (name);
1513 gfc_current_locus = name_locus;
1518 /* Match an argument list function, such as %VAL. */
1521 match_arg_list_function (gfc_actual_arglist *result)
1523 char name[GFC_MAX_SYMBOL_LEN + 1];
1527 old_locus = gfc_current_locus;
1529 if (gfc_match_char ('%') != MATCH_YES)
1535 m = gfc_match ("%n (", name);
1539 if (name[0] != '\0')
1544 if (strncmp (name, "loc", 3) == 0)
1546 result->name = "%LOC";
1550 if (strncmp (name, "ref", 3) == 0)
1552 result->name = "%REF";
1556 if (strncmp (name, "val", 3) == 0)
1558 result->name = "%VAL";
1567 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1568 "function at %C") == FAILURE)
1574 m = match_actual_arg (&result->expr);
1578 if (gfc_match_char (')') != MATCH_YES)
1587 gfc_current_locus = old_locus;
1592 /* Matches an actual argument list of a function or subroutine, from
1593 the opening parenthesis to the closing parenthesis. The argument
1594 list is assumed to allow keyword arguments because we don't know if
1595 the symbol associated with the procedure has an implicit interface
1596 or not. We make sure keywords are unique. If sub_flag is set,
1597 we're matching the argument list of a subroutine. */
1600 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1602 gfc_actual_arglist *head, *tail;
1604 gfc_st_label *label;
1608 *argp = tail = NULL;
1609 old_loc = gfc_current_locus;
1613 if (gfc_match_char ('(') == MATCH_NO)
1614 return (sub_flag) ? MATCH_YES : MATCH_NO;
1616 if (gfc_match_char (')') == MATCH_YES)
1623 head = tail = gfc_get_actual_arglist ();
1626 tail->next = gfc_get_actual_arglist ();
1630 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1632 m = gfc_match_st_label (&label);
1634 gfc_error ("Expected alternate return label at %C");
1638 tail->label = label;
1642 /* After the first keyword argument is seen, the following
1643 arguments must also have keywords. */
1646 m = match_keyword_arg (tail, head);
1648 if (m == MATCH_ERROR)
1652 gfc_error ("Missing keyword name in actual argument list at %C");
1659 /* Try an argument list function, like %VAL. */
1660 m = match_arg_list_function (tail);
1661 if (m == MATCH_ERROR)
1664 /* See if we have the first keyword argument. */
1667 m = match_keyword_arg (tail, head);
1670 if (m == MATCH_ERROR)
1676 /* Try for a non-keyword argument. */
1677 m = match_actual_arg (&tail->expr);
1678 if (m == MATCH_ERROR)
1687 if (gfc_match_char (')') == MATCH_YES)
1689 if (gfc_match_char (',') != MATCH_YES)
1697 gfc_error ("Syntax error in argument list at %C");
1700 gfc_free_actual_arglist (head);
1701 gfc_current_locus = old_loc;
1707 /* Used by gfc_match_varspec() to extend the reference list by one
1711 extend_ref (gfc_expr *primary, gfc_ref *tail)
1713 if (primary->ref == NULL)
1714 primary->ref = tail = gfc_get_ref ();
1718 gfc_internal_error ("extend_ref(): Bad tail");
1719 tail->next = gfc_get_ref ();
1727 /* Match any additional specifications associated with the current
1728 variable like member references or substrings. If equiv_flag is
1729 set we only match stuff that is allowed inside an EQUIVALENCE
1730 statement. sub_flag tells whether we expect a type-bound procedure found
1731 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1732 components, 'ppc_arg' determines whether the PPC may be called (with an
1733 argument list), or whether it may just be referred to as a pointer. */
1736 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1739 char name[GFC_MAX_SYMBOL_LEN + 1];
1740 gfc_ref *substring, *tail;
1741 gfc_component *component;
1742 gfc_symbol *sym = primary->symtree->n.sym;
1748 gfc_gobble_whitespace ();
1749 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1750 || (sym->attr.dimension && !sym->attr.proc_pointer
1751 && !gfc_is_proc_ptr_comp (primary, NULL)
1752 && !(gfc_matching_procptr_assignment
1753 && sym->attr.flavor == FL_PROCEDURE))
1754 || (sym->ts.type == BT_CLASS
1755 && sym->ts.u.derived->components->attr.dimension))
1757 /* In EQUIVALENCE, we don't know yet whether we are seeing
1758 an array, character variable or array of character
1759 variables. We'll leave the decision till resolve time. */
1760 tail = extend_ref (primary, tail);
1761 tail->type = REF_ARRAY;
1763 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1768 gfc_gobble_whitespace ();
1769 if (equiv_flag && gfc_peek_ascii_char () == '(')
1771 tail = extend_ref (primary, tail);
1772 tail->type = REF_ARRAY;
1774 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1780 primary->ts = sym->ts;
1785 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1786 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1787 gfc_set_default_type (sym, 0, sym->ns);
1789 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1790 || gfc_match_char ('%') != MATCH_YES)
1791 goto check_substring;
1793 sym = sym->ts.u.derived;
1800 m = gfc_match_name (name);
1802 gfc_error ("Expected structure component name at %C");
1806 if (sym->f2k_derived)
1807 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1813 gfc_symbol* tbp_sym;
1818 gcc_assert (!tail || !tail->next);
1819 gcc_assert (primary->expr_type == EXPR_VARIABLE);
1821 if (tbp->n.tb->is_generic)
1824 tbp_sym = tbp->n.tb->u.specific->n.sym;
1826 primary->expr_type = EXPR_COMPCALL;
1827 primary->value.compcall.tbp = tbp->n.tb;
1828 primary->value.compcall.name = tbp->name;
1829 primary->value.compcall.ignore_pass = 0;
1830 primary->value.compcall.assign = 0;
1831 primary->value.compcall.base_object = NULL;
1832 gcc_assert (primary->symtree->n.sym->attr.referenced);
1834 primary->ts = tbp_sym->ts;
1836 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1837 &primary->value.compcall.actual);
1838 if (m == MATCH_ERROR)
1843 primary->value.compcall.actual = NULL;
1846 gfc_error ("Expected argument list at %C");
1854 component = gfc_find_component (sym, name, false, false);
1855 if (component == NULL)
1858 tail = extend_ref (primary, tail);
1859 tail->type = REF_COMPONENT;
1861 tail->u.c.component = component;
1862 tail->u.c.sym = sym;
1864 primary->ts = component->ts;
1866 if (component->attr.proc_pointer && ppc_arg
1867 && !gfc_matching_procptr_assignment)
1869 m = gfc_match_actual_arglist (sub_flag,
1870 &primary->value.compcall.actual);
1871 if (m == MATCH_ERROR)
1874 primary->expr_type = EXPR_PPC;
1879 if (component->as != NULL && !component->attr.proc_pointer)
1881 tail = extend_ref (primary, tail);
1882 tail->type = REF_ARRAY;
1884 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1888 else if (component->ts.type == BT_CLASS
1889 && component->ts.u.derived->components->as != NULL
1890 && !component->attr.proc_pointer)
1892 tail = extend_ref (primary, tail);
1893 tail->type = REF_ARRAY;
1895 m = gfc_match_array_ref (&tail->u.ar,
1896 component->ts.u.derived->components->as,
1902 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1903 || gfc_match_char ('%') != MATCH_YES)
1906 sym = component->ts.u.derived;
1911 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1913 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1915 gfc_set_default_type (sym, 0, sym->ns);
1916 primary->ts = sym->ts;
1921 if (primary->ts.type == BT_CHARACTER)
1923 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1927 primary->ref = substring;
1929 tail->next = substring;
1931 if (primary->expr_type == EXPR_CONSTANT)
1932 primary->expr_type = EXPR_SUBSTRING;
1935 primary->ts.u.cl = NULL;
1942 gfc_clear_ts (&primary->ts);
1943 gfc_clear_ts (&sym->ts);
1956 /* Given an expression that is a variable, figure out what the
1957 ultimate variable's type and attribute is, traversing the reference
1958 structures if necessary.
1960 This subroutine is trickier than it looks. We start at the base
1961 symbol and store the attribute. Component references load a
1962 completely new attribute.
1964 A couple of rules come into play. Subobjects of targets are always
1965 targets themselves. If we see a component that goes through a
1966 pointer, then the expression must also be a target, since the
1967 pointer is associated with something (if it isn't core will soon be
1968 dumped). If we see a full part or section of an array, the
1969 expression is also an array.
1971 We can have at most one full array reference. */
1974 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1976 int dimension, pointer, allocatable, target;
1977 symbol_attribute attr;
1980 gfc_component *comp;
1982 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
1983 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1986 sym = expr->symtree->n.sym;
1989 if (sym->ts.type == BT_CLASS)
1991 dimension = sym->ts.u.derived->components->attr.dimension;
1992 pointer = sym->ts.u.derived->components->attr.pointer;
1993 allocatable = sym->ts.u.derived->components->attr.allocatable;
1997 dimension = attr.dimension;
1998 pointer = attr.pointer;
1999 allocatable = attr.allocatable;
2002 target = attr.target;
2003 if (pointer || attr.proc_pointer)
2006 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2009 for (; ref; ref = ref->next)
2014 switch (ref->u.ar.type)
2021 allocatable = pointer = 0;
2026 allocatable = pointer = 0;
2030 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2036 comp = ref->u.c.component;
2041 /* Don't set the string length if a substring reference
2043 if (ts->type == BT_CHARACTER
2044 && ref->next && ref->next->type == REF_SUBSTRING)
2048 if (comp->ts.type == BT_CLASS)
2050 pointer = comp->ts.u.derived->components->attr.pointer;
2051 allocatable = comp->ts.u.derived->components->attr.allocatable;
2055 pointer = comp->attr.pointer;
2056 allocatable = comp->attr.allocatable;
2058 if (pointer || attr.proc_pointer)
2064 allocatable = pointer = 0;
2068 attr.dimension = dimension;
2069 attr.pointer = pointer;
2070 attr.allocatable = allocatable;
2071 attr.target = target;
2077 /* Return the attribute from a general expression. */
2080 gfc_expr_attr (gfc_expr *e)
2082 symbol_attribute attr;
2084 switch (e->expr_type)
2087 attr = gfc_variable_attr (e, NULL);
2091 gfc_clear_attr (&attr);
2093 if (e->value.function.esym != NULL)
2095 gfc_symbol *sym = e->value.function.esym->result;
2097 if (sym->ts.type == BT_CLASS)
2099 attr.dimension = sym->ts.u.derived->components->attr.dimension;
2100 attr.pointer = sym->ts.u.derived->components->attr.pointer;
2101 attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
2105 attr = gfc_variable_attr (e, NULL);
2107 /* TODO: NULL() returns pointers. May have to take care of this
2113 gfc_clear_attr (&attr);
2121 /* Match a structure constructor. The initial symbol has already been
2124 typedef struct gfc_structure_ctor_component
2129 struct gfc_structure_ctor_component* next;
2131 gfc_structure_ctor_component;
2133 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2136 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2138 gfc_free (comp->name);
2139 gfc_free_expr (comp->val);
2143 /* Translate the component list into the actual constructor by sorting it in
2144 the order required; this also checks along the way that each and every
2145 component actually has an initializer and handles default initializers
2146 for components without explicit value given. */
2148 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2149 gfc_constructor **ctor_head, gfc_symbol *sym)
2151 gfc_structure_ctor_component *comp_iter;
2152 gfc_constructor *ctor_tail = NULL;
2153 gfc_component *comp;
2155 for (comp = sym->components; comp; comp = comp->next)
2157 gfc_structure_ctor_component **next_ptr;
2158 gfc_expr *value = NULL;
2160 /* Try to find the initializer for the current component by name. */
2161 next_ptr = comp_head;
2162 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2164 if (!strcmp (comp_iter->name, comp->name))
2166 next_ptr = &comp_iter->next;
2169 /* If an extension, try building the parent derived type by building
2170 a value expression for the parent derived type and calling self. */
2171 if (!comp_iter && comp == sym->components && sym->attr.extension)
2173 value = gfc_get_expr ();
2174 value->expr_type = EXPR_STRUCTURE;
2175 value->value.constructor = NULL;
2176 value->ts = comp->ts;
2177 value->where = gfc_current_locus;
2179 if (build_actual_constructor (comp_head, &value->value.constructor,
2180 comp->ts.u.derived) == FAILURE)
2182 gfc_free_expr (value);
2185 *ctor_head = ctor_tail = gfc_get_constructor ();
2186 ctor_tail->expr = value;
2190 /* If it was not found, try the default initializer if there's any;
2191 otherwise, it's an error. */
2194 if (comp->initializer)
2196 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2197 " constructor with missing optional arguments"
2198 " at %C") == FAILURE)
2200 value = gfc_copy_expr (comp->initializer);
2204 gfc_error ("No initializer for component '%s' given in the"
2205 " structure constructor at %C!", comp->name);
2210 value = comp_iter->val;
2212 /* Add the value to the constructor chain built. */
2215 ctor_tail->next = gfc_get_constructor ();
2216 ctor_tail = ctor_tail->next;
2219 *ctor_head = ctor_tail = gfc_get_constructor ();
2221 ctor_tail->expr = value;
2223 /* Remove the entry from the component list. We don't want the expression
2224 value to be free'd, so set it to NULL. */
2227 *next_ptr = comp_iter->next;
2228 comp_iter->val = NULL;
2229 gfc_free_structure_ctor_component (comp_iter);
2236 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2239 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2240 gfc_constructor *ctor_head, *ctor_tail;
2241 gfc_component *comp; /* Is set NULL when named component is first seen */
2245 const char* last_name = NULL;
2247 comp_tail = comp_head = NULL;
2248 ctor_head = ctor_tail = NULL;
2250 if (!parent && gfc_match_char ('(') != MATCH_YES)
2253 where = gfc_current_locus;
2255 gfc_find_component (sym, NULL, false, true);
2257 /* Check that we're not about to construct an ABSTRACT type. */
2258 if (!parent && sym->attr.abstract)
2260 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2264 /* Match the component list and store it in a list together with the
2265 corresponding component names. Check for empty argument list first. */
2266 if (gfc_match_char (')') != MATCH_YES)
2268 comp = sym->components;
2271 gfc_component *this_comp = NULL;
2274 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2277 comp_tail->next = gfc_get_structure_ctor_component ();
2278 comp_tail = comp_tail->next;
2280 comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2281 comp_tail->val = NULL;
2282 comp_tail->where = gfc_current_locus;
2284 /* Try matching a component name. */
2285 if (gfc_match_name (comp_tail->name) == MATCH_YES
2286 && gfc_match_char ('=') == MATCH_YES)
2288 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2289 " constructor with named arguments at %C")
2293 last_name = comp_tail->name;
2298 /* Components without name are not allowed after the first named
2299 component initializer! */
2303 gfc_error ("Component initializer without name after"
2304 " component named %s at %C!", last_name);
2306 gfc_error ("Too many components in structure constructor at"
2311 gfc_current_locus = comp_tail->where;
2312 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2315 /* Find the current component in the structure definition and check
2316 its access is not private. */
2318 this_comp = gfc_find_component (sym, comp->name, false, false);
2321 this_comp = gfc_find_component (sym,
2322 (const char *)comp_tail->name,
2324 comp = NULL; /* Reset needed! */
2327 /* Here we can check if a component name is given which does not
2328 correspond to any component of the defined structure. */
2332 /* Check if this component is already given a value. */
2333 for (comp_iter = comp_head; comp_iter != comp_tail;
2334 comp_iter = comp_iter->next)
2336 gcc_assert (comp_iter);
2337 if (!strcmp (comp_iter->name, comp_tail->name))
2339 gfc_error ("Component '%s' is initialized twice in the"
2340 " structure constructor at %C!", comp_tail->name);
2345 /* Match the current initializer expression. */
2346 m = gfc_match_expr (&comp_tail->val);
2349 if (m == MATCH_ERROR)
2352 /* If not explicitly a parent constructor, gather up the components
2354 if (comp && comp == sym->components
2355 && sym->attr.extension
2356 && (comp_tail->val->ts.type != BT_DERIVED
2358 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2360 gfc_current_locus = where;
2361 gfc_free_expr (comp_tail->val);
2362 comp_tail->val = NULL;
2364 m = gfc_match_structure_constructor (comp->ts.u.derived,
2365 &comp_tail->val, true);
2368 if (m == MATCH_ERROR)
2375 if (parent && !comp)
2379 while (gfc_match_char (',') == MATCH_YES);
2381 if (!parent && gfc_match_char (')') != MATCH_YES)
2385 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2388 /* No component should be left, as this should have caused an error in the
2389 loop constructing the component-list (name that does not correspond to any
2390 component in the structure definition). */
2391 if (comp_head && sym->attr.extension)
2393 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2395 gfc_error ("component '%s' at %L has already been set by a "
2396 "parent derived type constructor", comp_iter->name,
2402 gcc_assert (!comp_head);
2404 e = gfc_get_expr ();
2406 e->expr_type = EXPR_STRUCTURE;
2408 e->ts.type = BT_DERIVED;
2409 e->ts.u.derived = sym;
2412 e->value.constructor = ctor_head;
2418 gfc_error ("Syntax error in structure constructor at %C");
2421 for (comp_iter = comp_head; comp_iter; )
2423 gfc_structure_ctor_component *next = comp_iter->next;
2424 gfc_free_structure_ctor_component (comp_iter);
2427 gfc_free_constructor (ctor_head);
2432 /* If the symbol is an implicit do loop index and implicitly typed,
2433 it should not be host associated. Provide a symtree from the
2434 current namespace. */
2436 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2438 if ((*sym)->attr.flavor == FL_VARIABLE
2439 && (*sym)->ns != gfc_current_ns
2440 && (*sym)->attr.implied_index
2441 && (*sym)->attr.implicit_type
2442 && !(*sym)->attr.use_assoc)
2445 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2448 *sym = (*st)->n.sym;
2454 /* Procedure pointer as function result: Replace the function symbol by the
2455 auto-generated hidden result variable named "ppr@". */
2458 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2460 /* Check for procedure pointer result variable. */
2461 if ((*sym)->attr.function && !(*sym)->attr.external
2462 && (*sym)->result && (*sym)->result != *sym
2463 && (*sym)->result->attr.proc_pointer
2464 && (*sym) == gfc_current_ns->proc_name
2465 && (*sym) == (*sym)->result->ns->proc_name
2466 && strcmp ("ppr@", (*sym)->result->name) == 0)
2468 /* Automatic replacement with "hidden" result variable. */
2469 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2470 *sym = (*sym)->result;
2471 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2478 /* Matches a variable name followed by anything that might follow it--
2479 array reference, argument list of a function, etc. */
2482 gfc_match_rvalue (gfc_expr **result)
2484 gfc_actual_arglist *actual_arglist;
2485 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2488 gfc_symtree *symtree;
2489 locus where, old_loc;
2497 m = gfc_match_name (name);
2501 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2502 && !gfc_current_ns->has_import_set)
2503 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2505 i = gfc_get_ha_sym_tree (name, &symtree);
2510 sym = symtree->n.sym;
2512 where = gfc_current_locus;
2514 replace_hidden_procptr_result (&sym, &symtree);
2516 /* If this is an implicit do loop index and implicitly typed,
2517 it should not be host associated. */
2518 m = check_for_implicit_index (&symtree, &sym);
2522 gfc_set_sym_referenced (sym);
2523 sym->attr.implied_index = 0;
2525 if (sym->attr.function && sym->result == sym)
2527 /* See if this is a directly recursive function call. */
2528 gfc_gobble_whitespace ();
2529 if (sym->attr.recursive
2530 && gfc_peek_ascii_char () == '('
2531 && gfc_current_ns->proc_name == sym
2532 && !sym->attr.dimension)
2534 gfc_error ("'%s' at %C is the name of a recursive function "
2535 "and so refers to the result variable. Use an "
2536 "explicit RESULT variable for direct recursion "
2537 "(12.5.2.1)", sym->name);
2541 if (gfc_is_function_return_value (sym, gfc_current_ns))
2545 && (sym->ns == gfc_current_ns
2546 || sym->ns == gfc_current_ns->parent))
2548 gfc_entry_list *el = NULL;
2550 for (el = sym->ns->entries; el; el = el->next)
2556 if (gfc_matching_procptr_assignment)
2559 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2562 if (sym->attr.generic)
2563 goto generic_function;
2565 switch (sym->attr.flavor)
2569 e = gfc_get_expr ();
2571 e->expr_type = EXPR_VARIABLE;
2572 e->symtree = symtree;
2574 m = gfc_match_varspec (e, 0, false, true);
2578 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2579 end up here. Unfortunately, sym->value->expr_type is set to
2580 EXPR_CONSTANT, and so the if () branch would be followed without
2581 the !sym->as check. */
2582 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2583 e = gfc_copy_expr (sym->value);
2586 e = gfc_get_expr ();
2587 e->expr_type = EXPR_VARIABLE;
2590 e->symtree = symtree;
2591 m = gfc_match_varspec (e, 0, false, true);
2593 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2596 /* Variable array references to derived type parameters cause
2597 all sorts of headaches in simplification. Treating such
2598 expressions as variable works just fine for all array
2600 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2602 for (ref = e->ref; ref; ref = ref->next)
2603 if (ref->type == REF_ARRAY)
2606 if (ref == NULL || ref->u.ar.type == AR_FULL)
2612 e = gfc_get_expr ();
2613 e->expr_type = EXPR_VARIABLE;
2614 e->symtree = symtree;
2621 sym = gfc_use_derived (sym);
2625 m = gfc_match_structure_constructor (sym, &e, false);
2628 /* If we're here, then the name is known to be the name of a
2629 procedure, yet it is not sure to be the name of a function. */
2632 /* Procedure Pointer Assignments. */
2634 if (gfc_matching_procptr_assignment)
2636 gfc_gobble_whitespace ();
2637 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2638 /* Parse functions returning a procptr. */
2641 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2642 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2643 sym->attr.intrinsic = 1;
2644 e = gfc_get_expr ();
2645 e->expr_type = EXPR_VARIABLE;
2646 e->symtree = symtree;
2647 m = gfc_match_varspec (e, 0, false, true);
2651 if (sym->attr.subroutine)
2653 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2659 /* At this point, the name has to be a non-statement function.
2660 If the name is the same as the current function being
2661 compiled, then we have a variable reference (to the function
2662 result) if the name is non-recursive. */
2664 st = gfc_enclosing_unit (NULL);
2666 if (st != NULL && st->state == COMP_FUNCTION
2668 && !sym->attr.recursive)
2670 e = gfc_get_expr ();
2671 e->symtree = symtree;
2672 e->expr_type = EXPR_VARIABLE;
2674 m = gfc_match_varspec (e, 0, false, true);
2678 /* Match a function reference. */
2680 m = gfc_match_actual_arglist (0, &actual_arglist);
2683 if (sym->attr.proc == PROC_ST_FUNCTION)
2684 gfc_error ("Statement function '%s' requires argument list at %C",
2687 gfc_error ("Function '%s' requires an argument list at %C",
2700 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2701 sym = symtree->n.sym;
2703 replace_hidden_procptr_result (&sym, &symtree);
2705 e = gfc_get_expr ();
2706 e->symtree = symtree;
2707 e->expr_type = EXPR_FUNCTION;
2708 e->value.function.actual = actual_arglist;
2709 e->where = gfc_current_locus;
2711 if (sym->as != NULL)
2712 e->rank = sym->as->rank;
2714 if (!sym->attr.function
2715 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2721 /* Check here for the existence of at least one argument for the
2722 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2723 argument(s) given will be checked in gfc_iso_c_func_interface,
2724 during resolution of the function call. */
2725 if (sym->attr.is_iso_c == 1
2726 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2727 && (sym->intmod_sym_id == ISOCBINDING_LOC
2728 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2729 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2731 /* make sure we were given a param */
2732 if (actual_arglist == NULL)
2734 gfc_error ("Missing argument to '%s' at %C", sym->name);
2740 if (sym->result == NULL)
2748 /* Special case for derived type variables that get their types
2749 via an IMPLICIT statement. This can't wait for the
2750 resolution phase. */
2752 if (gfc_peek_ascii_char () == '%'
2753 && sym->ts.type == BT_UNKNOWN
2754 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2755 gfc_set_default_type (sym, 0, sym->ns);
2757 /* If the symbol has a dimension attribute, the expression is a
2760 if (sym->attr.dimension)
2762 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2763 sym->name, NULL) == FAILURE)
2769 e = gfc_get_expr ();
2770 e->symtree = symtree;
2771 e->expr_type = EXPR_VARIABLE;
2772 m = gfc_match_varspec (e, 0, false, true);
2776 /* Name is not an array, so we peek to see if a '(' implies a
2777 function call or a substring reference. Otherwise the
2778 variable is just a scalar. */
2780 gfc_gobble_whitespace ();
2781 if (gfc_peek_ascii_char () != '(')
2783 /* Assume a scalar variable */
2784 e = gfc_get_expr ();
2785 e->symtree = symtree;
2786 e->expr_type = EXPR_VARIABLE;
2788 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2789 sym->name, NULL) == FAILURE)
2795 /*FIXME:??? gfc_match_varspec does set this for us: */
2797 m = gfc_match_varspec (e, 0, false, true);
2801 /* See if this is a function reference with a keyword argument
2802 as first argument. We do this because otherwise a spurious
2803 symbol would end up in the symbol table. */
2805 old_loc = gfc_current_locus;
2806 m2 = gfc_match (" ( %n =", argname);
2807 gfc_current_locus = old_loc;
2809 e = gfc_get_expr ();
2810 e->symtree = symtree;
2812 if (m2 != MATCH_YES)
2814 /* Try to figure out whether we're dealing with a character type.
2815 We're peeking ahead here, because we don't want to call
2816 match_substring if we're dealing with an implicitly typed
2817 non-character variable. */
2818 implicit_char = false;
2819 if (sym->ts.type == BT_UNKNOWN)
2821 ts = gfc_get_default_type (sym->name, NULL);
2822 if (ts->type == BT_CHARACTER)
2823 implicit_char = true;
2826 /* See if this could possibly be a substring reference of a name
2827 that we're not sure is a variable yet. */
2829 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2830 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2833 e->expr_type = EXPR_VARIABLE;
2835 if (sym->attr.flavor != FL_VARIABLE
2836 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2837 sym->name, NULL) == FAILURE)
2843 if (sym->ts.type == BT_UNKNOWN
2844 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2858 /* Give up, assume we have a function. */
2860 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2861 sym = symtree->n.sym;
2862 e->expr_type = EXPR_FUNCTION;
2864 if (!sym->attr.function
2865 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2873 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2875 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2883 /* If our new function returns a character, array or structure
2884 type, it might have subsequent references. */
2886 m = gfc_match_varspec (e, 0, false, true);
2893 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2895 e = gfc_get_expr ();
2896 e->symtree = symtree;
2897 e->expr_type = EXPR_FUNCTION;
2899 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2903 gfc_error ("Symbol at %C is not appropriate for an expression");
2919 /* Match a variable, i.e. something that can be assigned to. This
2920 starts as a symbol, can be a structure component or an array
2921 reference. It can be a function if the function doesn't have a
2922 separate RESULT variable. If the symbol has not been previously
2923 seen, we assume it is a variable.
2925 This function is called by two interface functions:
2926 gfc_match_variable, which has host_flag = 1, and
2927 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2928 match of the symbol to the local scope. */
2931 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2939 /* Since nothing has any business being an lvalue in a module
2940 specification block, an interface block or a contains section,
2941 we force the changed_symbols mechanism to work by setting
2942 host_flag to 0. This prevents valid symbols that have the name
2943 of keywords, such as 'end', being turned into variables by
2944 failed matching to assignments for, e.g., END INTERFACE. */
2945 if (gfc_current_state () == COMP_MODULE
2946 || gfc_current_state () == COMP_INTERFACE
2947 || gfc_current_state () == COMP_CONTAINS)
2950 where = gfc_current_locus;
2951 m = gfc_match_sym_tree (&st, host_flag);
2957 /* If this is an implicit do loop index and implicitly typed,
2958 it should not be host associated. */
2959 m = check_for_implicit_index (&st, &sym);
2963 sym->attr.implied_index = 0;
2965 gfc_set_sym_referenced (sym);
2966 switch (sym->attr.flavor)
2969 if (sym->attr.is_protected && sym->attr.use_assoc)
2971 gfc_error ("Assigning to PROTECTED variable at %C");
2978 sym_flavor flavor = FL_UNKNOWN;
2980 gfc_gobble_whitespace ();
2982 if (sym->attr.external || sym->attr.procedure
2983 || sym->attr.function || sym->attr.subroutine)
2984 flavor = FL_PROCEDURE;
2986 /* If it is not a procedure, is not typed and is host associated,
2987 we cannot give it a flavor yet. */
2988 else if (sym->ns == gfc_current_ns->parent
2989 && sym->ts.type == BT_UNKNOWN)
2992 /* These are definitive indicators that this is a variable. */
2993 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
2994 || sym->attr.pointer || sym->as != NULL)
2995 flavor = FL_VARIABLE;
2997 if (flavor != FL_UNKNOWN
2998 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3005 gfc_error ("Named constant at %C in an EQUIVALENCE");
3007 gfc_error ("Cannot assign to a named constant at %C");
3012 /* Check for a nonrecursive function result variable. */
3013 if (sym->attr.function
3014 && !sym->attr.external
3015 && sym->result == sym
3016 && (gfc_is_function_return_value (sym, gfc_current_ns)
3018 && sym->ns == gfc_current_ns)
3020 && sym->ns == gfc_current_ns->parent)))
3022 /* If a function result is a derived type, then the derived
3023 type may still have to be resolved. */
3025 if (sym->ts.type == BT_DERIVED
3026 && gfc_use_derived (sym->ts.u.derived) == NULL)
3031 if (sym->attr.proc_pointer
3032 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3035 /* Fall through to error */
3038 gfc_error ("'%s' at %C is not a variable", sym->name);
3042 /* Special case for derived type variables that get their types
3043 via an IMPLICIT statement. This can't wait for the
3044 resolution phase. */
3047 gfc_namespace * implicit_ns;
3049 if (gfc_current_ns->proc_name == sym)
3050 implicit_ns = gfc_current_ns;
3052 implicit_ns = sym->ns;
3054 if (gfc_peek_ascii_char () == '%'
3055 && sym->ts.type == BT_UNKNOWN
3056 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3057 gfc_set_default_type (sym, 0, implicit_ns);
3060 expr = gfc_get_expr ();
3062 expr->expr_type = EXPR_VARIABLE;
3065 expr->where = where;
3067 /* Now see if we have to do more. */
3068 m = gfc_match_varspec (expr, equiv_flag, false, false);
3071 gfc_free_expr (expr);
3081 gfc_match_variable (gfc_expr **result, int equiv_flag)
3083 return match_variable (result, equiv_flag, 1);
3088 gfc_match_equiv_variable (gfc_expr **result)
3090 return match_variable (result, 1, 0);