1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 #include "constructor.h"
31 /* Matches a kind-parameter expression, which is either a named
32 symbolic constant or a nonnegative integer constant. If
33 successful, sets the kind value to the correct integer. */
36 match_kind_param (int *kind)
38 char name[GFC_MAX_SYMBOL_LEN + 1];
43 m = gfc_match_small_literal_int (kind, NULL);
47 m = gfc_match_name (name);
51 if (gfc_find_symbol (name, NULL, 1, &sym))
57 if (sym->attr.flavor != FL_PARAMETER)
60 if (sym->value == NULL)
63 p = gfc_extract_int (sym->value, kind);
67 gfc_set_sym_referenced (sym);
76 /* Get a trailing kind-specification for non-character variables.
78 the integer kind value or:
79 -1 if an error was generated
80 -2 if no kind was found */
88 if (gfc_match_char ('_') != MATCH_YES)
91 m = match_kind_param (&kind);
93 gfc_error ("Missing kind-parameter at %C");
95 return (m == MATCH_YES) ? kind : -1;
99 /* Given a character and a radix, see if the character is a valid
100 digit in that radix. */
103 gfc_check_digit (char c, int radix)
110 r = ('0' <= c && c <= '1');
114 r = ('0' <= c && c <= '7');
118 r = ('0' <= c && c <= '9');
126 gfc_internal_error ("gfc_check_digit(): bad radix");
133 /* Match the digit string part of an integer if signflag is not set,
134 the signed digit string part if signflag is set. If the buffer
135 is NULL, we just count characters for the resolution pass. Returns
136 the number of characters matched, -1 for no match. */
139 match_digits (int signflag, int radix, char *buffer)
146 c = gfc_next_ascii_char ();
148 if (signflag && (c == '+' || c == '-'))
152 gfc_gobble_whitespace ();
153 c = gfc_next_ascii_char ();
157 if (!gfc_check_digit (c, radix))
166 old_loc = gfc_current_locus;
167 c = gfc_next_ascii_char ();
169 if (!gfc_check_digit (c, radix))
177 gfc_current_locus = old_loc;
183 /* Match an integer (digit string and optional kind).
184 A sign will be accepted if signflag is set. */
187 match_integer_constant (gfc_expr **result, int signflag)
194 old_loc = gfc_current_locus;
195 gfc_gobble_whitespace ();
197 length = match_digits (signflag, 10, NULL);
198 gfc_current_locus = old_loc;
202 buffer = (char *) alloca (length + 1);
203 memset (buffer, '\0', length + 1);
205 gfc_gobble_whitespace ();
207 match_digits (signflag, 10, buffer);
211 kind = gfc_default_integer_kind;
215 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
217 gfc_error ("Integer kind %d at %C not available", kind);
221 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
223 if (gfc_range_check (e) != ARITH_OK)
225 gfc_error ("Integer too big for its kind at %C. This check can be "
226 "disabled with the option -fno-range-check");
237 /* Match a Hollerith constant. */
240 match_hollerith_constant (gfc_expr **result)
248 old_loc = gfc_current_locus;
249 gfc_gobble_whitespace ();
251 if (match_integer_constant (&e, 0) == MATCH_YES
252 && gfc_match_char ('h') == MATCH_YES)
254 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
258 msg = gfc_extract_int (e, &num);
266 gfc_error ("Invalid Hollerith constant: %L must contain at least "
267 "one character", &old_loc);
270 if (e->ts.kind != gfc_default_integer_kind)
272 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
273 "should be default", &old_loc);
279 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
282 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_get_int_expr (gfc_default_integer_kind, NULL, 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 c = gfc_next_char ();
871 if (c == '\'' || c == '"')
873 kind = gfc_default_character_kind;
874 start_locus = gfc_current_locus;
878 if (gfc_wide_is_digit (c))
882 while (gfc_wide_is_digit (c))
884 kind = kind * 10 + c - '0';
887 c = gfc_next_char ();
893 gfc_current_locus = old_locus;
895 m = match_charkind_name (name);
899 if (gfc_find_symbol (name, NULL, 1, &sym)
901 || sym->attr.flavor != FL_PARAMETER)
905 c = gfc_next_char ();
910 gfc_gobble_whitespace ();
911 c = gfc_next_char ();
917 gfc_gobble_whitespace ();
919 c = gfc_next_char ();
920 if (c != '\'' && c != '"')
923 start_locus = gfc_current_locus;
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')
972 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
974 e->ts.is_c_interop = 0;
977 gfc_current_locus = start_locus;
979 /* We disable the warning for the following loop as the warning has already
980 been printed in the loop above. */
981 warn_ampersand = gfc_option.warn_ampersand;
982 gfc_option.warn_ampersand = 0;
984 p = e->value.character.string;
985 for (i = 0; i < length; i++)
987 c = next_string_char (delimiter, &ret);
989 if (!gfc_check_character_range (c, kind))
991 gfc_error ("Character '%s' in string at %C is not representable "
992 "in character kind %d", gfc_print_wide_char (c), kind);
999 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1000 gfc_option.warn_ampersand = warn_ampersand;
1002 next_string_char (delimiter, &ret);
1004 gfc_internal_error ("match_string_constant(): Delimiter not found");
1006 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1007 e->expr_type = EXPR_SUBSTRING;
1014 gfc_current_locus = old_locus;
1019 /* Match a .true. or .false. Returns 1 if a .true. was found,
1020 0 if a .false. was found, and -1 otherwise. */
1022 match_logical_constant_string (void)
1024 locus orig_loc = gfc_current_locus;
1026 gfc_gobble_whitespace ();
1027 if (gfc_next_ascii_char () == '.')
1029 char ch = gfc_next_ascii_char ();
1032 if (gfc_next_ascii_char () == 'a'
1033 && gfc_next_ascii_char () == 'l'
1034 && gfc_next_ascii_char () == 's'
1035 && gfc_next_ascii_char () == 'e'
1036 && gfc_next_ascii_char () == '.')
1037 /* Matched ".false.". */
1042 if (gfc_next_ascii_char () == 'r'
1043 && gfc_next_ascii_char () == 'u'
1044 && gfc_next_ascii_char () == 'e'
1045 && gfc_next_ascii_char () == '.')
1046 /* Matched ".true.". */
1050 gfc_current_locus = orig_loc;
1054 /* Match a .true. or .false. */
1057 match_logical_constant (gfc_expr **result)
1062 i = match_logical_constant_string ();
1070 kind = gfc_default_logical_kind;
1072 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1074 gfc_error ("Bad kind for logical constant at %C");
1078 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1079 e->ts.is_c_interop = 0;
1087 /* Match a real or imaginary part of a complex constant that is a
1088 symbolic constant. */
1091 match_sym_complex_part (gfc_expr **result)
1093 char name[GFC_MAX_SYMBOL_LEN + 1];
1098 m = gfc_match_name (name);
1102 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1105 if (sym->attr.flavor != FL_PARAMETER)
1107 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1111 if (!gfc_numeric_ts (&sym->value->ts))
1113 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1117 if (sym->value->rank != 0)
1119 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1123 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1124 "complex constant at %C") == FAILURE)
1127 switch (sym->value->ts.type)
1130 e = gfc_copy_expr (sym->value);
1134 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1140 e = gfc_int2real (sym->value, gfc_default_real_kind);
1146 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1149 *result = e; /* e is a scalar, real, constant expression. */
1153 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1158 /* Match a real or imaginary part of a complex number. */
1161 match_complex_part (gfc_expr **result)
1165 m = match_sym_complex_part (result);
1169 m = match_real_constant (result, 1);
1173 return match_integer_constant (result, 1);
1177 /* Try to match a complex constant. */
1180 match_complex_constant (gfc_expr **result)
1182 gfc_expr *e, *real, *imag;
1183 gfc_error_buf old_error;
1184 gfc_typespec target;
1189 old_loc = gfc_current_locus;
1190 real = imag = e = NULL;
1192 m = gfc_match_char ('(');
1196 gfc_push_error (&old_error);
1198 m = match_complex_part (&real);
1201 gfc_free_error (&old_error);
1205 if (gfc_match_char (',') == MATCH_NO)
1207 gfc_pop_error (&old_error);
1212 /* If m is error, then something was wrong with the real part and we
1213 assume we have a complex constant because we've seen the ','. An
1214 ambiguous case here is the start of an iterator list of some
1215 sort. These sort of lists are matched prior to coming here. */
1217 if (m == MATCH_ERROR)
1219 gfc_free_error (&old_error);
1222 gfc_pop_error (&old_error);
1224 m = match_complex_part (&imag);
1227 if (m == MATCH_ERROR)
1230 m = gfc_match_char (')');
1233 /* Give the matcher for implied do-loops a chance to run. This
1234 yields a much saner error message for (/ (i, 4=i, 6) /). */
1235 if (gfc_peek_ascii_char () == '=')
1244 if (m == MATCH_ERROR)
1247 /* Decide on the kind of this complex number. */
1248 if (real->ts.type == BT_REAL)
1250 if (imag->ts.type == BT_REAL)
1251 kind = gfc_kind_max (real, imag);
1253 kind = real->ts.kind;
1257 if (imag->ts.type == BT_REAL)
1258 kind = imag->ts.kind;
1260 kind = gfc_default_real_kind;
1262 target.type = BT_REAL;
1264 target.is_c_interop = 0;
1265 target.is_iso_c = 0;
1267 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1268 gfc_convert_type (real, &target, 2);
1269 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1270 gfc_convert_type (imag, &target, 2);
1272 e = gfc_convert_complex (real, imag, kind);
1273 e->where = gfc_current_locus;
1275 gfc_free_expr (real);
1276 gfc_free_expr (imag);
1282 gfc_error ("Syntax error in COMPLEX constant at %C");
1287 gfc_free_expr (real);
1288 gfc_free_expr (imag);
1289 gfc_current_locus = old_loc;
1295 /* Match constants in any of several forms. Returns nonzero for a
1296 match, zero for no match. */
1299 gfc_match_literal_constant (gfc_expr **result, int signflag)
1303 m = match_complex_constant (result);
1307 m = match_string_constant (result);
1311 m = match_boz_constant (result);
1315 m = match_real_constant (result, signflag);
1319 m = match_hollerith_constant (result);
1323 m = match_integer_constant (result, signflag);
1327 m = match_logical_constant (result);
1335 /* This checks if a symbol is the return value of an encompassing function.
1336 Function nesting can be maximally two levels deep, but we may have
1337 additional local namespaces like BLOCK etc. */
1340 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1342 if (!sym->attr.function || (sym->result != sym))
1346 if (ns->proc_name == sym)
1354 /* Match a single actual argument value. An actual argument is
1355 usually an expression, but can also be a procedure name. If the
1356 argument is a single name, it is not always possible to tell
1357 whether the name is a dummy procedure or not. We treat these cases
1358 by creating an argument that looks like a dummy procedure and
1359 fixing things later during resolution. */
1362 match_actual_arg (gfc_expr **result)
1364 char name[GFC_MAX_SYMBOL_LEN + 1];
1365 gfc_symtree *symtree;
1370 gfc_gobble_whitespace ();
1371 where = gfc_current_locus;
1373 switch (gfc_match_name (name))
1382 w = gfc_current_locus;
1383 gfc_gobble_whitespace ();
1384 c = gfc_next_ascii_char ();
1385 gfc_current_locus = w;
1387 if (c != ',' && c != ')')
1390 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1392 /* Handle error elsewhere. */
1394 /* Eliminate a couple of common cases where we know we don't
1395 have a function argument. */
1396 if (symtree == NULL)
1398 gfc_get_sym_tree (name, NULL, &symtree, false);
1399 gfc_set_sym_referenced (symtree->n.sym);
1405 sym = symtree->n.sym;
1406 gfc_set_sym_referenced (sym);
1407 if (sym->attr.flavor != FL_PROCEDURE
1408 && sym->attr.flavor != FL_UNKNOWN)
1411 if (sym->attr.in_common && !sym->attr.proc_pointer)
1413 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1418 /* If the symbol is a function with itself as the result and
1419 is being defined, then we have a variable. */
1420 if (sym->attr.function && sym->result == sym)
1422 if (gfc_is_function_return_value (sym, gfc_current_ns))
1426 && (sym->ns == gfc_current_ns
1427 || sym->ns == gfc_current_ns->parent))
1429 gfc_entry_list *el = NULL;
1431 for (el = sym->ns->entries; el; el = el->next)
1441 e = gfc_get_expr (); /* Leave it unknown for now */
1442 e->symtree = symtree;
1443 e->expr_type = EXPR_VARIABLE;
1444 e->ts.type = BT_PROCEDURE;
1451 gfc_current_locus = where;
1452 return gfc_match_expr (result);
1456 /* Match a keyword argument. */
1459 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1461 char name[GFC_MAX_SYMBOL_LEN + 1];
1462 gfc_actual_arglist *a;
1466 name_locus = gfc_current_locus;
1467 m = gfc_match_name (name);
1471 if (gfc_match_char ('=') != MATCH_YES)
1477 m = match_actual_arg (&actual->expr);
1481 /* Make sure this name has not appeared yet. */
1483 if (name[0] != '\0')
1485 for (a = base; a; a = a->next)
1486 if (a->name != NULL && strcmp (a->name, name) == 0)
1488 gfc_error ("Keyword '%s' at %C has already appeared in the "
1489 "current argument list", name);
1494 actual->name = gfc_get_string (name);
1498 gfc_current_locus = name_locus;
1503 /* Match an argument list function, such as %VAL. */
1506 match_arg_list_function (gfc_actual_arglist *result)
1508 char name[GFC_MAX_SYMBOL_LEN + 1];
1512 old_locus = gfc_current_locus;
1514 if (gfc_match_char ('%') != MATCH_YES)
1520 m = gfc_match ("%n (", name);
1524 if (name[0] != '\0')
1529 if (strncmp (name, "loc", 3) == 0)
1531 result->name = "%LOC";
1535 if (strncmp (name, "ref", 3) == 0)
1537 result->name = "%REF";
1541 if (strncmp (name, "val", 3) == 0)
1543 result->name = "%VAL";
1552 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1553 "function at %C") == FAILURE)
1559 m = match_actual_arg (&result->expr);
1563 if (gfc_match_char (')') != MATCH_YES)
1572 gfc_current_locus = old_locus;
1577 /* Matches an actual argument list of a function or subroutine, from
1578 the opening parenthesis to the closing parenthesis. The argument
1579 list is assumed to allow keyword arguments because we don't know if
1580 the symbol associated with the procedure has an implicit interface
1581 or not. We make sure keywords are unique. If sub_flag is set,
1582 we're matching the argument list of a subroutine. */
1585 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1587 gfc_actual_arglist *head, *tail;
1589 gfc_st_label *label;
1593 *argp = tail = NULL;
1594 old_loc = gfc_current_locus;
1598 if (gfc_match_char ('(') == MATCH_NO)
1599 return (sub_flag) ? MATCH_YES : MATCH_NO;
1601 if (gfc_match_char (')') == MATCH_YES)
1608 head = tail = gfc_get_actual_arglist ();
1611 tail->next = gfc_get_actual_arglist ();
1615 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1617 m = gfc_match_st_label (&label);
1619 gfc_error ("Expected alternate return label at %C");
1623 tail->label = label;
1627 /* After the first keyword argument is seen, the following
1628 arguments must also have keywords. */
1631 m = match_keyword_arg (tail, head);
1633 if (m == MATCH_ERROR)
1637 gfc_error ("Missing keyword name in actual argument list at %C");
1644 /* Try an argument list function, like %VAL. */
1645 m = match_arg_list_function (tail);
1646 if (m == MATCH_ERROR)
1649 /* See if we have the first keyword argument. */
1652 m = match_keyword_arg (tail, head);
1655 if (m == MATCH_ERROR)
1661 /* Try for a non-keyword argument. */
1662 m = match_actual_arg (&tail->expr);
1663 if (m == MATCH_ERROR)
1672 if (gfc_match_char (')') == MATCH_YES)
1674 if (gfc_match_char (',') != MATCH_YES)
1682 gfc_error ("Syntax error in argument list at %C");
1685 gfc_free_actual_arglist (head);
1686 gfc_current_locus = old_loc;
1692 /* Used by gfc_match_varspec() to extend the reference list by one
1696 extend_ref (gfc_expr *primary, gfc_ref *tail)
1698 if (primary->ref == NULL)
1699 primary->ref = tail = gfc_get_ref ();
1703 gfc_internal_error ("extend_ref(): Bad tail");
1704 tail->next = gfc_get_ref ();
1712 /* Match any additional specifications associated with the current
1713 variable like member references or substrings. If equiv_flag is
1714 set we only match stuff that is allowed inside an EQUIVALENCE
1715 statement. sub_flag tells whether we expect a type-bound procedure found
1716 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1717 components, 'ppc_arg' determines whether the PPC may be called (with an
1718 argument list), or whether it may just be referred to as a pointer. */
1721 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1724 char name[GFC_MAX_SYMBOL_LEN + 1];
1725 gfc_ref *substring, *tail;
1726 gfc_component *component;
1727 gfc_symbol *sym = primary->symtree->n.sym;
1733 gfc_gobble_whitespace ();
1735 if (gfc_peek_ascii_char () == '[')
1737 if (sym->attr.dimension)
1739 gfc_error ("Array section designator, e.g. '(:)', is required "
1740 "besides the coarray designator '[...]' at %C");
1743 if (!sym->attr.codimension)
1745 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1751 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1752 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1753 || (sym->attr.dimension && !sym->attr.proc_pointer
1754 && !gfc_is_proc_ptr_comp (primary, NULL)
1755 && !(gfc_matching_procptr_assignment
1756 && sym->attr.flavor == FL_PROCEDURE))
1757 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension))
1759 /* In EQUIVALENCE, we don't know yet whether we are seeing
1760 an array, character variable or array of character
1761 variables. We'll leave the decision till resolve time. */
1762 tail = extend_ref (primary, tail);
1763 tail->type = REF_ARRAY;
1765 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1766 equiv_flag, sym->as ? sym->as->corank : 0);
1770 gfc_gobble_whitespace ();
1771 if (equiv_flag && gfc_peek_ascii_char () == '(')
1773 tail = extend_ref (primary, tail);
1774 tail->type = REF_ARRAY;
1776 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1782 primary->ts = sym->ts;
1787 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1788 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1789 gfc_set_default_type (sym, 0, sym->ns);
1791 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1792 || gfc_match_char ('%') != MATCH_YES)
1793 goto check_substring;
1795 sym = sym->ts.u.derived;
1802 m = gfc_match_name (name);
1804 gfc_error ("Expected structure component name at %C");
1808 if (sym->f2k_derived)
1809 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1815 gfc_symbol* tbp_sym;
1820 gcc_assert (!tail || !tail->next);
1821 gcc_assert (primary->expr_type == EXPR_VARIABLE);
1823 if (tbp->n.tb->is_generic)
1826 tbp_sym = tbp->n.tb->u.specific->n.sym;
1828 primary->expr_type = EXPR_COMPCALL;
1829 primary->value.compcall.tbp = tbp->n.tb;
1830 primary->value.compcall.name = tbp->name;
1831 primary->value.compcall.ignore_pass = 0;
1832 primary->value.compcall.assign = 0;
1833 primary->value.compcall.base_object = NULL;
1834 gcc_assert (primary->symtree->n.sym->attr.referenced);
1836 primary->ts = tbp_sym->ts;
1838 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1839 &primary->value.compcall.actual);
1840 if (m == MATCH_ERROR)
1845 primary->value.compcall.actual = NULL;
1848 gfc_error ("Expected argument list at %C");
1856 component = gfc_find_component (sym, name, false, false);
1857 if (component == NULL)
1860 tail = extend_ref (primary, tail);
1861 tail->type = REF_COMPONENT;
1863 tail->u.c.component = component;
1864 tail->u.c.sym = sym;
1866 primary->ts = component->ts;
1868 if (component->attr.proc_pointer && ppc_arg
1869 && !gfc_matching_procptr_assignment)
1871 m = gfc_match_actual_arglist (sub_flag,
1872 &primary->value.compcall.actual);
1873 if (m == MATCH_ERROR)
1876 primary->expr_type = EXPR_PPC;
1881 if (component->as != NULL && !component->attr.proc_pointer)
1883 tail = extend_ref (primary, tail);
1884 tail->type = REF_ARRAY;
1886 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
1887 component->as->corank);
1891 else if (component->ts.type == BT_CLASS
1892 && CLASS_DATA (component)->as != NULL
1893 && !component->attr.proc_pointer)
1895 tail = extend_ref (primary, tail);
1896 tail->type = REF_ARRAY;
1898 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
1900 CLASS_DATA (component)->as->corank);
1905 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1906 || gfc_match_char ('%') != MATCH_YES)
1909 sym = component->ts.u.derived;
1914 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1916 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1918 gfc_set_default_type (sym, 0, sym->ns);
1919 primary->ts = sym->ts;
1924 if (primary->ts.type == BT_CHARACTER)
1926 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1930 primary->ref = substring;
1932 tail->next = substring;
1934 if (primary->expr_type == EXPR_CONSTANT)
1935 primary->expr_type = EXPR_SUBSTRING;
1938 primary->ts.u.cl = NULL;
1945 gfc_clear_ts (&primary->ts);
1946 gfc_clear_ts (&sym->ts);
1956 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
1958 gfc_error ("Coindexed procedure-pointer component at %C");
1966 /* Given an expression that is a variable, figure out what the
1967 ultimate variable's type and attribute is, traversing the reference
1968 structures if necessary.
1970 This subroutine is trickier than it looks. We start at the base
1971 symbol and store the attribute. Component references load a
1972 completely new attribute.
1974 A couple of rules come into play. Subobjects of targets are always
1975 targets themselves. If we see a component that goes through a
1976 pointer, then the expression must also be a target, since the
1977 pointer is associated with something (if it isn't core will soon be
1978 dumped). If we see a full part or section of an array, the
1979 expression is also an array.
1981 We can have at most one full array reference. */
1984 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1986 int dimension, pointer, allocatable, target;
1987 symbol_attribute attr;
1990 gfc_component *comp;
1992 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
1993 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1996 sym = expr->symtree->n.sym;
1999 if (sym->ts.type == BT_CLASS)
2001 dimension = CLASS_DATA (sym)->attr.dimension;
2002 pointer = CLASS_DATA (sym)->attr.pointer;
2003 allocatable = CLASS_DATA (sym)->attr.allocatable;
2007 dimension = attr.dimension;
2008 pointer = attr.pointer;
2009 allocatable = attr.allocatable;
2012 target = attr.target;
2013 if (pointer || attr.proc_pointer)
2016 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2019 for (; ref; ref = ref->next)
2024 switch (ref->u.ar.type)
2031 allocatable = pointer = 0;
2036 /* Handle coarrays. */
2037 if (ref->u.ar.dimen > 0)
2038 allocatable = pointer = 0;
2042 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2048 comp = ref->u.c.component;
2053 /* Don't set the string length if a substring reference
2055 if (ts->type == BT_CHARACTER
2056 && ref->next && ref->next->type == REF_SUBSTRING)
2060 if (comp->ts.type == BT_CLASS)
2062 pointer = CLASS_DATA (comp)->attr.pointer;
2063 allocatable = CLASS_DATA (comp)->attr.allocatable;
2067 pointer = comp->attr.pointer;
2068 allocatable = comp->attr.allocatable;
2070 if (pointer || attr.proc_pointer)
2076 allocatable = pointer = 0;
2080 attr.dimension = dimension;
2081 attr.pointer = pointer;
2082 attr.allocatable = allocatable;
2083 attr.target = target;
2089 /* Return the attribute from a general expression. */
2092 gfc_expr_attr (gfc_expr *e)
2094 symbol_attribute attr;
2096 switch (e->expr_type)
2099 attr = gfc_variable_attr (e, NULL);
2103 gfc_clear_attr (&attr);
2105 if (e->value.function.esym != NULL)
2107 gfc_symbol *sym = e->value.function.esym->result;
2109 if (sym->ts.type == BT_CLASS)
2111 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2112 attr.pointer = CLASS_DATA (sym)->attr.pointer;
2113 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2117 attr = gfc_variable_attr (e, NULL);
2119 /* TODO: NULL() returns pointers. May have to take care of this
2125 gfc_clear_attr (&attr);
2133 /* Match a structure constructor. The initial symbol has already been
2136 typedef struct gfc_structure_ctor_component
2141 struct gfc_structure_ctor_component* next;
2143 gfc_structure_ctor_component;
2145 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2148 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2150 gfc_free (comp->name);
2151 gfc_free_expr (comp->val);
2155 /* Translate the component list into the actual constructor by sorting it in
2156 the order required; this also checks along the way that each and every
2157 component actually has an initializer and handles default initializers
2158 for components without explicit value given. */
2160 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2161 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2163 gfc_structure_ctor_component *comp_iter;
2164 gfc_component *comp;
2166 for (comp = sym->components; comp; comp = comp->next)
2168 gfc_structure_ctor_component **next_ptr;
2169 gfc_expr *value = NULL;
2171 /* Try to find the initializer for the current component by name. */
2172 next_ptr = comp_head;
2173 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2175 if (!strcmp (comp_iter->name, comp->name))
2177 next_ptr = &comp_iter->next;
2180 /* If an extension, try building the parent derived type by building
2181 a value expression for the parent derived type and calling self. */
2182 if (!comp_iter && comp == sym->components && sym->attr.extension)
2184 value = gfc_get_structure_constructor_expr (comp->ts.type,
2186 &gfc_current_locus);
2187 value->ts = comp->ts;
2189 if (build_actual_constructor (comp_head, &value->value.constructor,
2190 comp->ts.u.derived) == FAILURE)
2192 gfc_free_expr (value);
2196 gfc_constructor_append_expr (ctor_head, value, NULL);
2200 /* If it was not found, try the default initializer if there's any;
2201 otherwise, it's an error. */
2204 if (comp->initializer)
2206 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2207 " constructor with missing optional arguments"
2208 " at %C") == FAILURE)
2210 value = gfc_copy_expr (comp->initializer);
2214 gfc_error ("No initializer for component '%s' given in the"
2215 " structure constructor at %C!", comp->name);
2220 value = comp_iter->val;
2222 /* Add the value to the constructor chain built. */
2223 gfc_constructor_append_expr (ctor_head, value, NULL);
2225 /* Remove the entry from the component list. We don't want the expression
2226 value to be free'd, so set it to NULL. */
2229 *next_ptr = comp_iter->next;
2230 comp_iter->val = NULL;
2231 gfc_free_structure_ctor_component (comp_iter);
2238 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2241 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2242 gfc_constructor_base ctor_head = NULL;
2243 gfc_component *comp; /* Is set NULL when named component is first seen */
2247 const char* last_name = NULL;
2249 comp_tail = comp_head = NULL;
2251 if (!parent && gfc_match_char ('(') != MATCH_YES)
2254 where = gfc_current_locus;
2256 gfc_find_component (sym, NULL, false, true);
2258 /* Check that we're not about to construct an ABSTRACT type. */
2259 if (!parent && sym->attr.abstract)
2261 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2265 /* Match the component list and store it in a list together with the
2266 corresponding component names. Check for empty argument list first. */
2267 if (gfc_match_char (')') != MATCH_YES)
2269 comp = sym->components;
2272 gfc_component *this_comp = NULL;
2275 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2278 comp_tail->next = gfc_get_structure_ctor_component ();
2279 comp_tail = comp_tail->next;
2281 comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2282 comp_tail->val = NULL;
2283 comp_tail->where = gfc_current_locus;
2285 /* Try matching a component name. */
2286 if (gfc_match_name (comp_tail->name) == MATCH_YES
2287 && gfc_match_char ('=') == MATCH_YES)
2289 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2290 " constructor with named arguments at %C")
2294 last_name = comp_tail->name;
2299 /* Components without name are not allowed after the first named
2300 component initializer! */
2304 gfc_error ("Component initializer without name after"
2305 " component named %s at %C!", last_name);
2307 gfc_error ("Too many components in structure constructor at"
2312 gfc_current_locus = comp_tail->where;
2313 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2316 /* Find the current component in the structure definition and check
2317 its access is not private. */
2319 this_comp = gfc_find_component (sym, comp->name, false, false);
2322 this_comp = gfc_find_component (sym,
2323 (const char *)comp_tail->name,
2325 comp = NULL; /* Reset needed! */
2328 /* Here we can check if a component name is given which does not
2329 correspond to any component of the defined structure. */
2333 /* Check if this component is already given a value. */
2334 for (comp_iter = comp_head; comp_iter != comp_tail;
2335 comp_iter = comp_iter->next)
2337 gcc_assert (comp_iter);
2338 if (!strcmp (comp_iter->name, comp_tail->name))
2340 gfc_error ("Component '%s' is initialized twice in the"
2341 " structure constructor at %C!", comp_tail->name);
2346 /* Match the current initializer expression. */
2347 m = gfc_match_expr (&comp_tail->val);
2350 if (m == MATCH_ERROR)
2353 /* F2008, R457/C725, for PURE C1283. */
2354 if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
2356 gfc_error ("Coindexed expression to pointer component '%s' in "
2357 "structure constructor at %C!", comp_tail->name);
2362 /* If not explicitly a parent constructor, gather up the components
2364 if (comp && comp == sym->components
2365 && sym->attr.extension
2366 && (comp_tail->val->ts.type != BT_DERIVED
2368 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2370 gfc_current_locus = where;
2371 gfc_free_expr (comp_tail->val);
2372 comp_tail->val = NULL;
2374 m = gfc_match_structure_constructor (comp->ts.u.derived,
2375 &comp_tail->val, true);
2378 if (m == MATCH_ERROR)
2385 if (parent && !comp)
2389 while (gfc_match_char (',') == MATCH_YES);
2391 if (!parent && gfc_match_char (')') != MATCH_YES)
2395 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2398 /* No component should be left, as this should have caused an error in the
2399 loop constructing the component-list (name that does not correspond to any
2400 component in the structure definition). */
2401 if (comp_head && sym->attr.extension)
2403 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2405 gfc_error ("component '%s' at %L has already been set by a "
2406 "parent derived type constructor", comp_iter->name,
2412 gcc_assert (!comp_head);
2414 e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
2415 e->ts.u.derived = sym;
2416 e->value.constructor = ctor_head;
2422 gfc_error ("Syntax error in structure constructor at %C");
2425 for (comp_iter = comp_head; comp_iter; )
2427 gfc_structure_ctor_component *next = comp_iter->next;
2428 gfc_free_structure_ctor_component (comp_iter);
2431 gfc_constructor_free (ctor_head);
2436 /* If the symbol is an implicit do loop index and implicitly typed,
2437 it should not be host associated. Provide a symtree from the
2438 current namespace. */
2440 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2442 if ((*sym)->attr.flavor == FL_VARIABLE
2443 && (*sym)->ns != gfc_current_ns
2444 && (*sym)->attr.implied_index
2445 && (*sym)->attr.implicit_type
2446 && !(*sym)->attr.use_assoc)
2449 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2452 *sym = (*st)->n.sym;
2458 /* Procedure pointer as function result: Replace the function symbol by the
2459 auto-generated hidden result variable named "ppr@". */
2462 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2464 /* Check for procedure pointer result variable. */
2465 if ((*sym)->attr.function && !(*sym)->attr.external
2466 && (*sym)->result && (*sym)->result != *sym
2467 && (*sym)->result->attr.proc_pointer
2468 && (*sym) == gfc_current_ns->proc_name
2469 && (*sym) == (*sym)->result->ns->proc_name
2470 && strcmp ("ppr@", (*sym)->result->name) == 0)
2472 /* Automatic replacement with "hidden" result variable. */
2473 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2474 *sym = (*sym)->result;
2475 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2482 /* Matches a variable name followed by anything that might follow it--
2483 array reference, argument list of a function, etc. */
2486 gfc_match_rvalue (gfc_expr **result)
2488 gfc_actual_arglist *actual_arglist;
2489 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2492 gfc_symtree *symtree;
2493 locus where, old_loc;
2501 m = gfc_match_name (name);
2505 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2506 && !gfc_current_ns->has_import_set)
2507 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2509 i = gfc_get_ha_sym_tree (name, &symtree);
2514 sym = symtree->n.sym;
2516 where = gfc_current_locus;
2518 replace_hidden_procptr_result (&sym, &symtree);
2520 /* If this is an implicit do loop index and implicitly typed,
2521 it should not be host associated. */
2522 m = check_for_implicit_index (&symtree, &sym);
2526 gfc_set_sym_referenced (sym);
2527 sym->attr.implied_index = 0;
2529 if (sym->attr.function && sym->result == sym)
2531 /* See if this is a directly recursive function call. */
2532 gfc_gobble_whitespace ();
2533 if (sym->attr.recursive
2534 && gfc_peek_ascii_char () == '('
2535 && gfc_current_ns->proc_name == sym
2536 && !sym->attr.dimension)
2538 gfc_error ("'%s' at %C is the name of a recursive function "
2539 "and so refers to the result variable. Use an "
2540 "explicit RESULT variable for direct recursion "
2541 "(12.5.2.1)", sym->name);
2545 if (gfc_is_function_return_value (sym, gfc_current_ns))
2549 && (sym->ns == gfc_current_ns
2550 || sym->ns == gfc_current_ns->parent))
2552 gfc_entry_list *el = NULL;
2554 for (el = sym->ns->entries; el; el = el->next)
2560 if (gfc_matching_procptr_assignment)
2563 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2566 if (sym->attr.generic)
2567 goto generic_function;
2569 switch (sym->attr.flavor)
2573 e = gfc_get_expr ();
2575 e->expr_type = EXPR_VARIABLE;
2576 e->symtree = symtree;
2578 m = gfc_match_varspec (e, 0, false, true);
2582 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2583 end up here. Unfortunately, sym->value->expr_type is set to
2584 EXPR_CONSTANT, and so the if () branch would be followed without
2585 the !sym->as check. */
2586 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2587 e = gfc_copy_expr (sym->value);
2590 e = gfc_get_expr ();
2591 e->expr_type = EXPR_VARIABLE;
2594 e->symtree = symtree;
2595 m = gfc_match_varspec (e, 0, false, true);
2597 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2600 /* Variable array references to derived type parameters cause
2601 all sorts of headaches in simplification. Treating such
2602 expressions as variable works just fine for all array
2604 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2606 for (ref = e->ref; ref; ref = ref->next)
2607 if (ref->type == REF_ARRAY)
2610 if (ref == NULL || ref->u.ar.type == AR_FULL)
2616 e = gfc_get_expr ();
2617 e->expr_type = EXPR_VARIABLE;
2618 e->symtree = symtree;
2625 sym = gfc_use_derived (sym);
2629 m = gfc_match_structure_constructor (sym, &e, false);
2632 /* If we're here, then the name is known to be the name of a
2633 procedure, yet it is not sure to be the name of a function. */
2636 /* Procedure Pointer Assignments. */
2638 if (gfc_matching_procptr_assignment)
2640 gfc_gobble_whitespace ();
2641 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2642 /* Parse functions returning a procptr. */
2645 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2646 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2647 sym->attr.intrinsic = 1;
2648 e = gfc_get_expr ();
2649 e->expr_type = EXPR_VARIABLE;
2650 e->symtree = symtree;
2651 m = gfc_match_varspec (e, 0, false, true);
2655 if (sym->attr.subroutine)
2657 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2663 /* At this point, the name has to be a non-statement function.
2664 If the name is the same as the current function being
2665 compiled, then we have a variable reference (to the function
2666 result) if the name is non-recursive. */
2668 st = gfc_enclosing_unit (NULL);
2670 if (st != NULL && st->state == COMP_FUNCTION
2672 && !sym->attr.recursive)
2674 e = gfc_get_expr ();
2675 e->symtree = symtree;
2676 e->expr_type = EXPR_VARIABLE;
2678 m = gfc_match_varspec (e, 0, false, true);
2682 /* Match a function reference. */
2684 m = gfc_match_actual_arglist (0, &actual_arglist);
2687 if (sym->attr.proc == PROC_ST_FUNCTION)
2688 gfc_error ("Statement function '%s' requires argument list at %C",
2691 gfc_error ("Function '%s' requires an argument list at %C",
2704 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2705 sym = symtree->n.sym;
2707 replace_hidden_procptr_result (&sym, &symtree);
2709 e = gfc_get_expr ();
2710 e->symtree = symtree;
2711 e->expr_type = EXPR_FUNCTION;
2712 e->value.function.actual = actual_arglist;
2713 e->where = gfc_current_locus;
2715 if (sym->as != NULL)
2716 e->rank = sym->as->rank;
2718 if (!sym->attr.function
2719 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2725 /* Check here for the existence of at least one argument for the
2726 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2727 argument(s) given will be checked in gfc_iso_c_func_interface,
2728 during resolution of the function call. */
2729 if (sym->attr.is_iso_c == 1
2730 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2731 && (sym->intmod_sym_id == ISOCBINDING_LOC
2732 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2733 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2735 /* make sure we were given a param */
2736 if (actual_arglist == NULL)
2738 gfc_error ("Missing argument to '%s' at %C", sym->name);
2744 if (sym->result == NULL)
2752 /* Special case for derived type variables that get their types
2753 via an IMPLICIT statement. This can't wait for the
2754 resolution phase. */
2756 if (gfc_peek_ascii_char () == '%'
2757 && sym->ts.type == BT_UNKNOWN
2758 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2759 gfc_set_default_type (sym, 0, sym->ns);
2761 /* If the symbol has a dimension attribute, the expression is a
2764 if (sym->attr.dimension)
2766 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2767 sym->name, NULL) == FAILURE)
2773 e = gfc_get_expr ();
2774 e->symtree = symtree;
2775 e->expr_type = EXPR_VARIABLE;
2776 m = gfc_match_varspec (e, 0, false, true);
2780 /* Name is not an array, so we peek to see if a '(' implies a
2781 function call or a substring reference. Otherwise the
2782 variable is just a scalar. */
2784 gfc_gobble_whitespace ();
2785 if (gfc_peek_ascii_char () != '(')
2787 /* Assume a scalar variable */
2788 e = gfc_get_expr ();
2789 e->symtree = symtree;
2790 e->expr_type = EXPR_VARIABLE;
2792 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2793 sym->name, NULL) == FAILURE)
2799 /*FIXME:??? gfc_match_varspec does set this for us: */
2801 m = gfc_match_varspec (e, 0, false, true);
2805 /* See if this is a function reference with a keyword argument
2806 as first argument. We do this because otherwise a spurious
2807 symbol would end up in the symbol table. */
2809 old_loc = gfc_current_locus;
2810 m2 = gfc_match (" ( %n =", argname);
2811 gfc_current_locus = old_loc;
2813 e = gfc_get_expr ();
2814 e->symtree = symtree;
2816 if (m2 != MATCH_YES)
2818 /* Try to figure out whether we're dealing with a character type.
2819 We're peeking ahead here, because we don't want to call
2820 match_substring if we're dealing with an implicitly typed
2821 non-character variable. */
2822 implicit_char = false;
2823 if (sym->ts.type == BT_UNKNOWN)
2825 ts = gfc_get_default_type (sym->name, NULL);
2826 if (ts->type == BT_CHARACTER)
2827 implicit_char = true;
2830 /* See if this could possibly be a substring reference of a name
2831 that we're not sure is a variable yet. */
2833 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2834 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2837 e->expr_type = EXPR_VARIABLE;
2839 if (sym->attr.flavor != FL_VARIABLE
2840 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2841 sym->name, NULL) == FAILURE)
2847 if (sym->ts.type == BT_UNKNOWN
2848 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2862 /* Give up, assume we have a function. */
2864 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2865 sym = symtree->n.sym;
2866 e->expr_type = EXPR_FUNCTION;
2868 if (!sym->attr.function
2869 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2877 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2879 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2887 /* If our new function returns a character, array or structure
2888 type, it might have subsequent references. */
2890 m = gfc_match_varspec (e, 0, false, true);
2897 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2899 e = gfc_get_expr ();
2900 e->symtree = symtree;
2901 e->expr_type = EXPR_FUNCTION;
2903 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2907 gfc_error ("Symbol at %C is not appropriate for an expression");
2923 /* Match a variable, i.e. something that can be assigned to. This
2924 starts as a symbol, can be a structure component or an array
2925 reference. It can be a function if the function doesn't have a
2926 separate RESULT variable. If the symbol has not been previously
2927 seen, we assume it is a variable.
2929 This function is called by two interface functions:
2930 gfc_match_variable, which has host_flag = 1, and
2931 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2932 match of the symbol to the local scope. */
2935 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2943 /* Since nothing has any business being an lvalue in a module
2944 specification block, an interface block or a contains section,
2945 we force the changed_symbols mechanism to work by setting
2946 host_flag to 0. This prevents valid symbols that have the name
2947 of keywords, such as 'end', being turned into variables by
2948 failed matching to assignments for, e.g., END INTERFACE. */
2949 if (gfc_current_state () == COMP_MODULE
2950 || gfc_current_state () == COMP_INTERFACE
2951 || gfc_current_state () == COMP_CONTAINS)
2954 where = gfc_current_locus;
2955 m = gfc_match_sym_tree (&st, host_flag);
2961 /* If this is an implicit do loop index and implicitly typed,
2962 it should not be host associated. */
2963 m = check_for_implicit_index (&st, &sym);
2967 sym->attr.implied_index = 0;
2969 gfc_set_sym_referenced (sym);
2970 switch (sym->attr.flavor)
2973 if (sym->attr.is_protected && sym->attr.use_assoc)
2975 gfc_error ("Assigning to PROTECTED variable at %C");
2982 sym_flavor flavor = FL_UNKNOWN;
2984 gfc_gobble_whitespace ();
2986 if (sym->attr.external || sym->attr.procedure
2987 || sym->attr.function || sym->attr.subroutine)
2988 flavor = FL_PROCEDURE;
2990 /* If it is not a procedure, is not typed and is host associated,
2991 we cannot give it a flavor yet. */
2992 else if (sym->ns == gfc_current_ns->parent
2993 && sym->ts.type == BT_UNKNOWN)
2996 /* These are definitive indicators that this is a variable. */
2997 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
2998 || sym->attr.pointer || sym->as != NULL)
2999 flavor = FL_VARIABLE;
3001 if (flavor != FL_UNKNOWN
3002 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3009 gfc_error ("Named constant at %C in an EQUIVALENCE");
3011 gfc_error ("Cannot assign to a named constant at %C");
3016 /* Check for a nonrecursive function result variable. */
3017 if (sym->attr.function
3018 && !sym->attr.external
3019 && sym->result == sym
3020 && (gfc_is_function_return_value (sym, gfc_current_ns)
3022 && sym->ns == gfc_current_ns)
3024 && sym->ns == gfc_current_ns->parent)))
3026 /* If a function result is a derived type, then the derived
3027 type may still have to be resolved. */
3029 if (sym->ts.type == BT_DERIVED
3030 && gfc_use_derived (sym->ts.u.derived) == NULL)
3035 if (sym->attr.proc_pointer
3036 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3039 /* Fall through to error */
3042 gfc_error ("'%s' at %C is not a variable", sym->name);
3046 /* Special case for derived type variables that get their types
3047 via an IMPLICIT statement. This can't wait for the
3048 resolution phase. */
3051 gfc_namespace * implicit_ns;
3053 if (gfc_current_ns->proc_name == sym)
3054 implicit_ns = gfc_current_ns;
3056 implicit_ns = sym->ns;
3058 if (gfc_peek_ascii_char () == '%'
3059 && sym->ts.type == BT_UNKNOWN
3060 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3061 gfc_set_default_type (sym, 0, implicit_ns);
3064 expr = gfc_get_expr ();
3066 expr->expr_type = EXPR_VARIABLE;
3069 expr->where = where;
3071 /* Now see if we have to do more. */
3072 m = gfc_match_varspec (expr, equiv_flag, false, false);
3075 gfc_free_expr (expr);
3085 gfc_match_variable (gfc_expr **result, int equiv_flag)
3087 return match_variable (result, equiv_flag, 1);
3092 gfc_match_equiv_variable (gfc_expr **result)
3094 return match_variable (result, 1, 0);