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 /* Match a single actual argument value. An actual argument is
1351 usually an expression, but can also be a procedure name. If the
1352 argument is a single name, it is not always possible to tell
1353 whether the name is a dummy procedure or not. We treat these cases
1354 by creating an argument that looks like a dummy procedure and
1355 fixing things later during resolution. */
1358 match_actual_arg (gfc_expr **result)
1360 char name[GFC_MAX_SYMBOL_LEN + 1];
1361 gfc_symtree *symtree;
1366 gfc_gobble_whitespace ();
1367 where = gfc_current_locus;
1369 switch (gfc_match_name (name))
1378 w = gfc_current_locus;
1379 gfc_gobble_whitespace ();
1380 c = gfc_next_ascii_char ();
1381 gfc_current_locus = w;
1383 if (c != ',' && c != ')')
1386 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1388 /* Handle error elsewhere. */
1390 /* Eliminate a couple of common cases where we know we don't
1391 have a function argument. */
1392 if (symtree == NULL)
1394 gfc_get_sym_tree (name, NULL, &symtree, false);
1395 gfc_set_sym_referenced (symtree->n.sym);
1401 sym = symtree->n.sym;
1402 gfc_set_sym_referenced (sym);
1403 if (sym->attr.flavor != FL_PROCEDURE
1404 && sym->attr.flavor != FL_UNKNOWN)
1407 if (sym->attr.in_common && !sym->attr.proc_pointer)
1409 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1414 /* If the symbol is a function with itself as the result and
1415 is being defined, then we have a variable. */
1416 if (sym->attr.function && sym->result == sym)
1418 if (gfc_current_ns->proc_name == sym
1419 || (gfc_current_ns->parent != NULL
1420 && gfc_current_ns->parent->proc_name == sym))
1424 && (sym->ns == gfc_current_ns
1425 || sym->ns == gfc_current_ns->parent))
1427 gfc_entry_list *el = NULL;
1429 for (el = sym->ns->entries; el; el = el->next)
1439 e = gfc_get_expr (); /* Leave it unknown for now */
1440 e->symtree = symtree;
1441 e->expr_type = EXPR_VARIABLE;
1442 e->ts.type = BT_PROCEDURE;
1449 gfc_current_locus = where;
1450 return gfc_match_expr (result);
1454 /* Match a keyword argument. */
1457 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1459 char name[GFC_MAX_SYMBOL_LEN + 1];
1460 gfc_actual_arglist *a;
1464 name_locus = gfc_current_locus;
1465 m = gfc_match_name (name);
1469 if (gfc_match_char ('=') != MATCH_YES)
1475 m = match_actual_arg (&actual->expr);
1479 /* Make sure this name has not appeared yet. */
1481 if (name[0] != '\0')
1483 for (a = base; a; a = a->next)
1484 if (a->name != NULL && strcmp (a->name, name) == 0)
1486 gfc_error ("Keyword '%s' at %C has already appeared in the "
1487 "current argument list", name);
1492 actual->name = gfc_get_string (name);
1496 gfc_current_locus = name_locus;
1501 /* Match an argument list function, such as %VAL. */
1504 match_arg_list_function (gfc_actual_arglist *result)
1506 char name[GFC_MAX_SYMBOL_LEN + 1];
1510 old_locus = gfc_current_locus;
1512 if (gfc_match_char ('%') != MATCH_YES)
1518 m = gfc_match ("%n (", name);
1522 if (name[0] != '\0')
1527 if (strncmp (name, "loc", 3) == 0)
1529 result->name = "%LOC";
1533 if (strncmp (name, "ref", 3) == 0)
1535 result->name = "%REF";
1539 if (strncmp (name, "val", 3) == 0)
1541 result->name = "%VAL";
1550 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1551 "function at %C") == FAILURE)
1557 m = match_actual_arg (&result->expr);
1561 if (gfc_match_char (')') != MATCH_YES)
1570 gfc_current_locus = old_locus;
1575 /* Matches an actual argument list of a function or subroutine, from
1576 the opening parenthesis to the closing parenthesis. The argument
1577 list is assumed to allow keyword arguments because we don't know if
1578 the symbol associated with the procedure has an implicit interface
1579 or not. We make sure keywords are unique. If sub_flag is set,
1580 we're matching the argument list of a subroutine. */
1583 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1585 gfc_actual_arglist *head, *tail;
1587 gfc_st_label *label;
1591 *argp = tail = NULL;
1592 old_loc = gfc_current_locus;
1596 if (gfc_match_char ('(') == MATCH_NO)
1597 return (sub_flag) ? MATCH_YES : MATCH_NO;
1599 if (gfc_match_char (')') == MATCH_YES)
1606 head = tail = gfc_get_actual_arglist ();
1609 tail->next = gfc_get_actual_arglist ();
1613 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1615 m = gfc_match_st_label (&label);
1617 gfc_error ("Expected alternate return label at %C");
1621 tail->label = label;
1625 /* After the first keyword argument is seen, the following
1626 arguments must also have keywords. */
1629 m = match_keyword_arg (tail, head);
1631 if (m == MATCH_ERROR)
1635 gfc_error ("Missing keyword name in actual argument list at %C");
1642 /* Try an argument list function, like %VAL. */
1643 m = match_arg_list_function (tail);
1644 if (m == MATCH_ERROR)
1647 /* See if we have the first keyword argument. */
1650 m = match_keyword_arg (tail, head);
1653 if (m == MATCH_ERROR)
1659 /* Try for a non-keyword argument. */
1660 m = match_actual_arg (&tail->expr);
1661 if (m == MATCH_ERROR)
1670 if (gfc_match_char (')') == MATCH_YES)
1672 if (gfc_match_char (',') != MATCH_YES)
1680 gfc_error ("Syntax error in argument list at %C");
1683 gfc_free_actual_arglist (head);
1684 gfc_current_locus = old_loc;
1690 /* Used by gfc_match_varspec() to extend the reference list by one
1694 extend_ref (gfc_expr *primary, gfc_ref *tail)
1696 if (primary->ref == NULL)
1697 primary->ref = tail = gfc_get_ref ();
1701 gfc_internal_error ("extend_ref(): Bad tail");
1702 tail->next = gfc_get_ref ();
1710 /* Match any additional specifications associated with the current
1711 variable like member references or substrings. If equiv_flag is
1712 set we only match stuff that is allowed inside an EQUIVALENCE
1713 statement. sub_flag tells whether we expect a type-bound procedure found
1714 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1715 components, 'ppc_arg' determines whether the PPC may be called (with an
1716 argument list), or whether it may just be referred to as a pointer. */
1719 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1722 char name[GFC_MAX_SYMBOL_LEN + 1];
1723 gfc_ref *substring, *tail;
1724 gfc_component *component;
1725 gfc_symbol *sym = primary->symtree->n.sym;
1731 gfc_gobble_whitespace ();
1732 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1733 || (sym->attr.dimension && !sym->attr.proc_pointer
1734 && !gfc_is_proc_ptr_comp (primary, NULL)
1735 && !(gfc_matching_procptr_assignment
1736 && sym->attr.flavor == FL_PROCEDURE)))
1738 /* In EQUIVALENCE, we don't know yet whether we are seeing
1739 an array, character variable or array of character
1740 variables. We'll leave the decision till resolve time. */
1741 tail = extend_ref (primary, tail);
1742 tail->type = REF_ARRAY;
1744 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1749 gfc_gobble_whitespace ();
1750 if (equiv_flag && gfc_peek_ascii_char () == '(')
1752 tail = extend_ref (primary, tail);
1753 tail->type = REF_ARRAY;
1755 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1761 primary->ts = sym->ts;
1766 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1767 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1768 gfc_set_default_type (sym, 0, sym->ns);
1770 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1771 goto check_substring;
1773 sym = sym->ts.u.derived;
1780 m = gfc_match_name (name);
1782 gfc_error ("Expected structure component name at %C");
1786 if (sym->f2k_derived)
1787 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1793 gfc_symbol* tbp_sym;
1798 gcc_assert (!tail || !tail->next);
1799 gcc_assert (primary->expr_type == EXPR_VARIABLE);
1801 if (tbp->n.tb->is_generic)
1804 tbp_sym = tbp->n.tb->u.specific->n.sym;
1806 primary->expr_type = EXPR_COMPCALL;
1807 primary->value.compcall.tbp = tbp->n.tb;
1808 primary->value.compcall.name = tbp->name;
1809 primary->value.compcall.ignore_pass = 0;
1810 primary->value.compcall.assign = 0;
1811 primary->value.compcall.base_object = NULL;
1812 gcc_assert (primary->symtree->n.sym->attr.referenced);
1814 primary->ts = tbp_sym->ts;
1816 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1817 &primary->value.compcall.actual);
1818 if (m == MATCH_ERROR)
1823 primary->value.compcall.actual = NULL;
1826 gfc_error ("Expected argument list at %C");
1834 component = gfc_find_component (sym, name, false, false);
1835 if (component == NULL)
1838 tail = extend_ref (primary, tail);
1839 tail->type = REF_COMPONENT;
1841 tail->u.c.component = component;
1842 tail->u.c.sym = sym;
1844 primary->ts = component->ts;
1846 if (component->attr.proc_pointer && ppc_arg
1847 && !gfc_matching_procptr_assignment)
1849 m = gfc_match_actual_arglist (sub_flag,
1850 &primary->value.compcall.actual);
1851 if (m == MATCH_ERROR)
1854 primary->expr_type = EXPR_PPC;
1859 if (component->as != NULL && !component->attr.proc_pointer)
1861 tail = extend_ref (primary, tail);
1862 tail->type = REF_ARRAY;
1864 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1869 if (component->ts.type != BT_DERIVED
1870 || gfc_match_char ('%') != MATCH_YES)
1873 sym = component->ts.u.derived;
1878 if (primary->ts.type == BT_UNKNOWN)
1880 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1882 gfc_set_default_type (sym, 0, sym->ns);
1883 primary->ts = sym->ts;
1888 if (primary->ts.type == BT_CHARACTER)
1890 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1894 primary->ref = substring;
1896 tail->next = substring;
1898 if (primary->expr_type == EXPR_CONSTANT)
1899 primary->expr_type = EXPR_SUBSTRING;
1902 primary->ts.u.cl = NULL;
1909 gfc_clear_ts (&primary->ts);
1910 gfc_clear_ts (&sym->ts);
1923 /* Given an expression that is a variable, figure out what the
1924 ultimate variable's type and attribute is, traversing the reference
1925 structures if necessary.
1927 This subroutine is trickier than it looks. We start at the base
1928 symbol and store the attribute. Component references load a
1929 completely new attribute.
1931 A couple of rules come into play. Subobjects of targets are always
1932 targets themselves. If we see a component that goes through a
1933 pointer, then the expression must also be a target, since the
1934 pointer is associated with something (if it isn't core will soon be
1935 dumped). If we see a full part or section of an array, the
1936 expression is also an array.
1938 We can have at most one full array reference. */
1941 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1943 int dimension, pointer, allocatable, target;
1944 symbol_attribute attr;
1947 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
1948 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1951 attr = expr->symtree->n.sym->attr;
1953 dimension = attr.dimension;
1954 pointer = attr.pointer;
1955 allocatable = attr.allocatable;
1957 target = attr.target;
1958 if (pointer || attr.proc_pointer)
1961 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1962 *ts = expr->symtree->n.sym->ts;
1964 for (; ref; ref = ref->next)
1969 switch (ref->u.ar.type)
1976 allocatable = pointer = 0;
1981 allocatable = pointer = 0;
1985 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1991 attr = ref->u.c.component->attr;
1994 *ts = ref->u.c.component->ts;
1995 /* Don't set the string length if a substring reference
1997 if (ts->type == BT_CHARACTER
1998 && ref->next && ref->next->type == REF_SUBSTRING)
2002 pointer = ref->u.c.component->attr.pointer;
2003 allocatable = ref->u.c.component->attr.allocatable;
2004 if (pointer || attr.proc_pointer)
2010 allocatable = pointer = 0;
2014 attr.dimension = dimension;
2015 attr.pointer = pointer;
2016 attr.allocatable = allocatable;
2017 attr.target = target;
2023 /* Return the attribute from a general expression. */
2026 gfc_expr_attr (gfc_expr *e)
2028 symbol_attribute attr;
2030 switch (e->expr_type)
2033 attr = gfc_variable_attr (e, NULL);
2037 gfc_clear_attr (&attr);
2039 if (e->value.function.esym != NULL)
2040 attr = e->value.function.esym->result->attr;
2042 attr = gfc_variable_attr (e, NULL);
2044 /* TODO: NULL() returns pointers. May have to take care of this
2050 gfc_clear_attr (&attr);
2058 /* Match a structure constructor. The initial symbol has already been
2061 typedef struct gfc_structure_ctor_component
2066 struct gfc_structure_ctor_component* next;
2068 gfc_structure_ctor_component;
2070 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2073 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2075 gfc_free (comp->name);
2076 gfc_free_expr (comp->val);
2080 /* Translate the component list into the actual constructor by sorting it in
2081 the order required; this also checks along the way that each and every
2082 component actually has an initializer and handles default initializers
2083 for components without explicit value given. */
2085 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2086 gfc_constructor **ctor_head, gfc_symbol *sym)
2088 gfc_structure_ctor_component *comp_iter;
2089 gfc_constructor *ctor_tail = NULL;
2090 gfc_component *comp;
2092 for (comp = sym->components; comp; comp = comp->next)
2094 gfc_structure_ctor_component **next_ptr;
2095 gfc_expr *value = NULL;
2097 /* Try to find the initializer for the current component by name. */
2098 next_ptr = comp_head;
2099 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2101 if (!strcmp (comp_iter->name, comp->name))
2103 next_ptr = &comp_iter->next;
2106 /* If an extension, try building the parent derived type by building
2107 a value expression for the parent derived type and calling self. */
2108 if (!comp_iter && comp == sym->components && sym->attr.extension)
2110 value = gfc_get_expr ();
2111 value->expr_type = EXPR_STRUCTURE;
2112 value->value.constructor = NULL;
2113 value->ts = comp->ts;
2114 value->where = gfc_current_locus;
2116 if (build_actual_constructor (comp_head, &value->value.constructor,
2117 comp->ts.u.derived) == FAILURE)
2119 gfc_free_expr (value);
2122 *ctor_head = ctor_tail = gfc_get_constructor ();
2123 ctor_tail->expr = value;
2127 /* If it was not found, try the default initializer if there's any;
2128 otherwise, it's an error. */
2131 if (comp->initializer)
2133 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2134 " constructor with missing optional arguments"
2135 " at %C") == FAILURE)
2137 value = gfc_copy_expr (comp->initializer);
2141 gfc_error ("No initializer for component '%s' given in the"
2142 " structure constructor at %C!", comp->name);
2147 value = comp_iter->val;
2149 /* Add the value to the constructor chain built. */
2152 ctor_tail->next = gfc_get_constructor ();
2153 ctor_tail = ctor_tail->next;
2156 *ctor_head = ctor_tail = gfc_get_constructor ();
2158 ctor_tail->expr = value;
2160 /* Remove the entry from the component list. We don't want the expression
2161 value to be free'd, so set it to NULL. */
2164 *next_ptr = comp_iter->next;
2165 comp_iter->val = NULL;
2166 gfc_free_structure_ctor_component (comp_iter);
2173 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2176 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2177 gfc_constructor *ctor_head, *ctor_tail;
2178 gfc_component *comp; /* Is set NULL when named component is first seen */
2182 const char* last_name = NULL;
2184 comp_tail = comp_head = NULL;
2185 ctor_head = ctor_tail = NULL;
2187 if (!parent && gfc_match_char ('(') != MATCH_YES)
2190 where = gfc_current_locus;
2192 gfc_find_component (sym, NULL, false, true);
2194 /* Check that we're not about to construct an ABSTRACT type. */
2195 if (!parent && sym->attr.abstract)
2197 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2201 /* Match the component list and store it in a list together with the
2202 corresponding component names. Check for empty argument list first. */
2203 if (gfc_match_char (')') != MATCH_YES)
2205 comp = sym->components;
2208 gfc_component *this_comp = NULL;
2211 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2214 comp_tail->next = gfc_get_structure_ctor_component ();
2215 comp_tail = comp_tail->next;
2217 comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2218 comp_tail->val = NULL;
2219 comp_tail->where = gfc_current_locus;
2221 /* Try matching a component name. */
2222 if (gfc_match_name (comp_tail->name) == MATCH_YES
2223 && gfc_match_char ('=') == MATCH_YES)
2225 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2226 " constructor with named arguments at %C")
2230 last_name = comp_tail->name;
2235 /* Components without name are not allowed after the first named
2236 component initializer! */
2240 gfc_error ("Component initializer without name after"
2241 " component named %s at %C!", last_name);
2243 gfc_error ("Too many components in structure constructor at"
2248 gfc_current_locus = comp_tail->where;
2249 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2252 /* Find the current component in the structure definition and check
2253 its access is not private. */
2255 this_comp = gfc_find_component (sym, comp->name, false, false);
2258 this_comp = gfc_find_component (sym,
2259 (const char *)comp_tail->name,
2261 comp = NULL; /* Reset needed! */
2264 /* Here we can check if a component name is given which does not
2265 correspond to any component of the defined structure. */
2269 /* Check if this component is already given a value. */
2270 for (comp_iter = comp_head; comp_iter != comp_tail;
2271 comp_iter = comp_iter->next)
2273 gcc_assert (comp_iter);
2274 if (!strcmp (comp_iter->name, comp_tail->name))
2276 gfc_error ("Component '%s' is initialized twice in the"
2277 " structure constructor at %C!", comp_tail->name);
2282 /* Match the current initializer expression. */
2283 m = gfc_match_expr (&comp_tail->val);
2286 if (m == MATCH_ERROR)
2289 /* If not explicitly a parent constructor, gather up the components
2291 if (comp && comp == sym->components
2292 && sym->attr.extension
2293 && (comp_tail->val->ts.type != BT_DERIVED
2295 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2297 gfc_current_locus = where;
2298 gfc_free_expr (comp_tail->val);
2299 comp_tail->val = NULL;
2301 m = gfc_match_structure_constructor (comp->ts.u.derived,
2302 &comp_tail->val, true);
2305 if (m == MATCH_ERROR)
2312 if (parent && !comp)
2316 while (gfc_match_char (',') == MATCH_YES);
2318 if (!parent && gfc_match_char (')') != MATCH_YES)
2322 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2325 /* No component should be left, as this should have caused an error in the
2326 loop constructing the component-list (name that does not correspond to any
2327 component in the structure definition). */
2328 if (comp_head && sym->attr.extension)
2330 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2332 gfc_error ("component '%s' at %L has already been set by a "
2333 "parent derived type constructor", comp_iter->name,
2339 gcc_assert (!comp_head);
2341 e = gfc_get_expr ();
2343 e->expr_type = EXPR_STRUCTURE;
2345 e->ts.type = BT_DERIVED;
2346 e->ts.u.derived = sym;
2349 e->value.constructor = ctor_head;
2355 gfc_error ("Syntax error in structure constructor at %C");
2358 for (comp_iter = comp_head; comp_iter; )
2360 gfc_structure_ctor_component *next = comp_iter->next;
2361 gfc_free_structure_ctor_component (comp_iter);
2364 gfc_free_constructor (ctor_head);
2369 /* If the symbol is an implicit do loop index and implicitly typed,
2370 it should not be host associated. Provide a symtree from the
2371 current namespace. */
2373 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2375 if ((*sym)->attr.flavor == FL_VARIABLE
2376 && (*sym)->ns != gfc_current_ns
2377 && (*sym)->attr.implied_index
2378 && (*sym)->attr.implicit_type
2379 && !(*sym)->attr.use_assoc)
2382 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2385 *sym = (*st)->n.sym;
2391 /* Procedure pointer as function result: Replace the function symbol by the
2392 auto-generated hidden result variable named "ppr@". */
2395 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2397 /* Check for procedure pointer result variable. */
2398 if ((*sym)->attr.function && !(*sym)->attr.external
2399 && (*sym)->result && (*sym)->result != *sym
2400 && (*sym)->result->attr.proc_pointer
2401 && (*sym) == gfc_current_ns->proc_name
2402 && (*sym) == (*sym)->result->ns->proc_name
2403 && strcmp ("ppr@", (*sym)->result->name) == 0)
2405 /* Automatic replacement with "hidden" result variable. */
2406 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2407 *sym = (*sym)->result;
2408 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2415 /* Matches a variable name followed by anything that might follow it--
2416 array reference, argument list of a function, etc. */
2419 gfc_match_rvalue (gfc_expr **result)
2421 gfc_actual_arglist *actual_arglist;
2422 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2425 gfc_symtree *symtree;
2426 locus where, old_loc;
2434 m = gfc_match_name (name);
2438 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2439 && !gfc_current_ns->has_import_set)
2440 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2442 i = gfc_get_ha_sym_tree (name, &symtree);
2447 sym = symtree->n.sym;
2449 where = gfc_current_locus;
2451 replace_hidden_procptr_result (&sym, &symtree);
2453 /* If this is an implicit do loop index and implicitly typed,
2454 it should not be host associated. */
2455 m = check_for_implicit_index (&symtree, &sym);
2459 gfc_set_sym_referenced (sym);
2460 sym->attr.implied_index = 0;
2462 if (sym->attr.function && sym->result == sym)
2464 /* See if this is a directly recursive function call. */
2465 gfc_gobble_whitespace ();
2466 if (sym->attr.recursive
2467 && gfc_peek_ascii_char () == '('
2468 && gfc_current_ns->proc_name == sym
2469 && !sym->attr.dimension)
2471 gfc_error ("'%s' at %C is the name of a recursive function "
2472 "and so refers to the result variable. Use an "
2473 "explicit RESULT variable for direct recursion "
2474 "(12.5.2.1)", sym->name);
2478 if (gfc_current_ns->proc_name == sym
2479 || (gfc_current_ns->parent != NULL
2480 && gfc_current_ns->parent->proc_name == sym))
2484 && (sym->ns == gfc_current_ns
2485 || sym->ns == gfc_current_ns->parent))
2487 gfc_entry_list *el = NULL;
2489 for (el = sym->ns->entries; el; el = el->next)
2495 if (gfc_matching_procptr_assignment)
2498 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2501 if (sym->attr.generic)
2502 goto generic_function;
2504 switch (sym->attr.flavor)
2508 e = gfc_get_expr ();
2510 e->expr_type = EXPR_VARIABLE;
2511 e->symtree = symtree;
2513 m = gfc_match_varspec (e, 0, false, true);
2517 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2518 end up here. Unfortunately, sym->value->expr_type is set to
2519 EXPR_CONSTANT, and so the if () branch would be followed without
2520 the !sym->as check. */
2521 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2522 e = gfc_copy_expr (sym->value);
2525 e = gfc_get_expr ();
2526 e->expr_type = EXPR_VARIABLE;
2529 e->symtree = symtree;
2530 m = gfc_match_varspec (e, 0, false, true);
2532 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2535 /* Variable array references to derived type parameters cause
2536 all sorts of headaches in simplification. Treating such
2537 expressions as variable works just fine for all array
2539 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2541 for (ref = e->ref; ref; ref = ref->next)
2542 if (ref->type == REF_ARRAY)
2545 if (ref == NULL || ref->u.ar.type == AR_FULL)
2551 e = gfc_get_expr ();
2552 e->expr_type = EXPR_VARIABLE;
2553 e->symtree = symtree;
2560 sym = gfc_use_derived (sym);
2564 m = gfc_match_structure_constructor (sym, &e, false);
2567 /* If we're here, then the name is known to be the name of a
2568 procedure, yet it is not sure to be the name of a function. */
2571 /* Procedure Pointer Assignments. */
2573 if (gfc_matching_procptr_assignment)
2575 gfc_gobble_whitespace ();
2576 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2577 /* Parse functions returning a procptr. */
2580 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2581 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2582 sym->attr.intrinsic = 1;
2583 e = gfc_get_expr ();
2584 e->expr_type = EXPR_VARIABLE;
2585 e->symtree = symtree;
2586 m = gfc_match_varspec (e, 0, false, true);
2590 if (sym->attr.subroutine)
2592 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2598 /* At this point, the name has to be a non-statement function.
2599 If the name is the same as the current function being
2600 compiled, then we have a variable reference (to the function
2601 result) if the name is non-recursive. */
2603 st = gfc_enclosing_unit (NULL);
2605 if (st != NULL && st->state == COMP_FUNCTION
2607 && !sym->attr.recursive)
2609 e = gfc_get_expr ();
2610 e->symtree = symtree;
2611 e->expr_type = EXPR_VARIABLE;
2613 m = gfc_match_varspec (e, 0, false, true);
2617 /* Match a function reference. */
2619 m = gfc_match_actual_arglist (0, &actual_arglist);
2622 if (sym->attr.proc == PROC_ST_FUNCTION)
2623 gfc_error ("Statement function '%s' requires argument list at %C",
2626 gfc_error ("Function '%s' requires an argument list at %C",
2639 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2640 sym = symtree->n.sym;
2642 replace_hidden_procptr_result (&sym, &symtree);
2644 e = gfc_get_expr ();
2645 e->symtree = symtree;
2646 e->expr_type = EXPR_FUNCTION;
2647 e->value.function.actual = actual_arglist;
2648 e->where = gfc_current_locus;
2650 if (sym->as != NULL)
2651 e->rank = sym->as->rank;
2653 if (!sym->attr.function
2654 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2660 /* Check here for the existence of at least one argument for the
2661 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2662 argument(s) given will be checked in gfc_iso_c_func_interface,
2663 during resolution of the function call. */
2664 if (sym->attr.is_iso_c == 1
2665 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2666 && (sym->intmod_sym_id == ISOCBINDING_LOC
2667 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2668 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2670 /* make sure we were given a param */
2671 if (actual_arglist == NULL)
2673 gfc_error ("Missing argument to '%s' at %C", sym->name);
2679 if (sym->result == NULL)
2687 /* Special case for derived type variables that get their types
2688 via an IMPLICIT statement. This can't wait for the
2689 resolution phase. */
2691 if (gfc_peek_ascii_char () == '%'
2692 && sym->ts.type == BT_UNKNOWN
2693 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2694 gfc_set_default_type (sym, 0, sym->ns);
2696 /* If the symbol has a dimension attribute, the expression is a
2699 if (sym->attr.dimension)
2701 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2702 sym->name, NULL) == FAILURE)
2708 e = gfc_get_expr ();
2709 e->symtree = symtree;
2710 e->expr_type = EXPR_VARIABLE;
2711 m = gfc_match_varspec (e, 0, false, true);
2715 /* Name is not an array, so we peek to see if a '(' implies a
2716 function call or a substring reference. Otherwise the
2717 variable is just a scalar. */
2719 gfc_gobble_whitespace ();
2720 if (gfc_peek_ascii_char () != '(')
2722 /* Assume a scalar variable */
2723 e = gfc_get_expr ();
2724 e->symtree = symtree;
2725 e->expr_type = EXPR_VARIABLE;
2727 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2728 sym->name, NULL) == FAILURE)
2734 /*FIXME:??? gfc_match_varspec does set this for us: */
2736 m = gfc_match_varspec (e, 0, false, true);
2740 /* See if this is a function reference with a keyword argument
2741 as first argument. We do this because otherwise a spurious
2742 symbol would end up in the symbol table. */
2744 old_loc = gfc_current_locus;
2745 m2 = gfc_match (" ( %n =", argname);
2746 gfc_current_locus = old_loc;
2748 e = gfc_get_expr ();
2749 e->symtree = symtree;
2751 if (m2 != MATCH_YES)
2753 /* Try to figure out whether we're dealing with a character type.
2754 We're peeking ahead here, because we don't want to call
2755 match_substring if we're dealing with an implicitly typed
2756 non-character variable. */
2757 implicit_char = false;
2758 if (sym->ts.type == BT_UNKNOWN)
2760 ts = gfc_get_default_type (sym->name, NULL);
2761 if (ts->type == BT_CHARACTER)
2762 implicit_char = true;
2765 /* See if this could possibly be a substring reference of a name
2766 that we're not sure is a variable yet. */
2768 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2769 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2772 e->expr_type = EXPR_VARIABLE;
2774 if (sym->attr.flavor != FL_VARIABLE
2775 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2776 sym->name, NULL) == FAILURE)
2782 if (sym->ts.type == BT_UNKNOWN
2783 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2797 /* Give up, assume we have a function. */
2799 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2800 sym = symtree->n.sym;
2801 e->expr_type = EXPR_FUNCTION;
2803 if (!sym->attr.function
2804 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2812 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2814 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2822 /* If our new function returns a character, array or structure
2823 type, it might have subsequent references. */
2825 m = gfc_match_varspec (e, 0, false, true);
2832 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2834 e = gfc_get_expr ();
2835 e->symtree = symtree;
2836 e->expr_type = EXPR_FUNCTION;
2838 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2842 gfc_error ("Symbol at %C is not appropriate for an expression");
2858 /* Match a variable, i.e. something that can be assigned to. This
2859 starts as a symbol, can be a structure component or an array
2860 reference. It can be a function if the function doesn't have a
2861 separate RESULT variable. If the symbol has not been previously
2862 seen, we assume it is a variable.
2864 This function is called by two interface functions:
2865 gfc_match_variable, which has host_flag = 1, and
2866 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2867 match of the symbol to the local scope. */
2870 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2878 /* Since nothing has any business being an lvalue in a module
2879 specification block, an interface block or a contains section,
2880 we force the changed_symbols mechanism to work by setting
2881 host_flag to 0. This prevents valid symbols that have the name
2882 of keywords, such as 'end', being turned into variables by
2883 failed matching to assignments for, e.g., END INTERFACE. */
2884 if (gfc_current_state () == COMP_MODULE
2885 || gfc_current_state () == COMP_INTERFACE
2886 || gfc_current_state () == COMP_CONTAINS)
2889 where = gfc_current_locus;
2890 m = gfc_match_sym_tree (&st, host_flag);
2896 /* If this is an implicit do loop index and implicitly typed,
2897 it should not be host associated. */
2898 m = check_for_implicit_index (&st, &sym);
2902 sym->attr.implied_index = 0;
2904 gfc_set_sym_referenced (sym);
2905 switch (sym->attr.flavor)
2908 if (sym->attr.is_protected && sym->attr.use_assoc)
2910 gfc_error ("Assigning to PROTECTED variable at %C");
2917 sym_flavor flavor = FL_UNKNOWN;
2919 gfc_gobble_whitespace ();
2921 if (sym->attr.external || sym->attr.procedure
2922 || sym->attr.function || sym->attr.subroutine)
2923 flavor = FL_PROCEDURE;
2925 /* If it is not a procedure, is not typed and is host associated,
2926 we cannot give it a flavor yet. */
2927 else if (sym->ns == gfc_current_ns->parent
2928 && sym->ts.type == BT_UNKNOWN)
2931 /* These are definitive indicators that this is a variable. */
2932 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
2933 || sym->attr.pointer || sym->as != NULL)
2934 flavor = FL_VARIABLE;
2936 if (flavor != FL_UNKNOWN
2937 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
2944 gfc_error ("Named constant at %C in an EQUIVALENCE");
2946 gfc_error ("Cannot assign to a named constant at %C");
2951 /* Check for a nonrecursive function result variable. */
2952 if (sym->attr.function
2953 && !sym->attr.external
2954 && sym->result == sym
2955 && ((sym == gfc_current_ns->proc_name
2956 && sym == gfc_current_ns->proc_name->result)
2957 || (gfc_current_ns->parent
2958 && sym == gfc_current_ns->parent->proc_name->result)
2960 && sym->ns == gfc_current_ns)
2962 && sym->ns == gfc_current_ns->parent)))
2964 /* If a function result is a derived type, then the derived
2965 type may still have to be resolved. */
2967 if (sym->ts.type == BT_DERIVED
2968 && gfc_use_derived (sym->ts.u.derived) == NULL)
2973 if (sym->attr.proc_pointer
2974 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
2977 /* Fall through to error */
2980 gfc_error ("'%s' at %C is not a variable", sym->name);
2984 /* Special case for derived type variables that get their types
2985 via an IMPLICIT statement. This can't wait for the
2986 resolution phase. */
2989 gfc_namespace * implicit_ns;
2991 if (gfc_current_ns->proc_name == sym)
2992 implicit_ns = gfc_current_ns;
2994 implicit_ns = sym->ns;
2996 if (gfc_peek_ascii_char () == '%'
2997 && sym->ts.type == BT_UNKNOWN
2998 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
2999 gfc_set_default_type (sym, 0, implicit_ns);
3002 expr = gfc_get_expr ();
3004 expr->expr_type = EXPR_VARIABLE;
3007 expr->where = where;
3009 /* Now see if we have to do more. */
3010 m = gfc_match_varspec (expr, equiv_flag, false, false);
3013 gfc_free_expr (expr);
3023 gfc_match_variable (gfc_expr **result, int equiv_flag)
3025 return match_variable (result, equiv_flag, 1);
3030 gfc_match_equiv_variable (gfc_expr **result)
3032 return match_variable (result, 1, 0);