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/>. */
30 /* Matches a kind-parameter expression, which is either a named
31 symbolic constant or a nonnegative integer constant. If
32 successful, sets the kind value to the correct integer. */
35 match_kind_param (int *kind)
37 char name[GFC_MAX_SYMBOL_LEN + 1];
42 m = gfc_match_small_literal_int (kind, NULL);
46 m = gfc_match_name (name);
50 if (gfc_find_symbol (name, NULL, 1, &sym))
56 if (sym->attr.flavor != FL_PARAMETER)
59 p = gfc_extract_int (sym->value, kind);
63 gfc_set_sym_referenced (sym);
72 /* Get a trailing kind-specification for non-character variables.
74 the integer kind value or:
75 -1 if an error was generated
76 -2 if no kind was found */
84 if (gfc_match_char ('_') != MATCH_YES)
87 m = match_kind_param (&kind);
89 gfc_error ("Missing kind-parameter at %C");
91 return (m == MATCH_YES) ? kind : -1;
95 /* Given a character and a radix, see if the character is a valid
96 digit in that radix. */
99 check_digit (int c, int radix)
106 r = ('0' <= c && c <= '1');
110 r = ('0' <= c && c <= '7');
114 r = ('0' <= c && c <= '9');
122 gfc_internal_error ("check_digit(): bad radix");
129 /* Match the digit string part of an integer if signflag is not set,
130 the signed digit string part if signflag is set. If the buffer
131 is NULL, we just count characters for the resolution pass. Returns
132 the number of characters matched, -1 for no match. */
135 match_digits (int signflag, int radix, char *buffer)
141 c = gfc_next_char ();
143 if (signflag && (c == '+' || c == '-'))
147 gfc_gobble_whitespace ();
148 c = gfc_next_char ();
152 if (!check_digit (c, radix))
161 old_loc = gfc_current_locus;
162 c = gfc_next_char ();
164 if (!check_digit (c, radix))
172 gfc_current_locus = old_loc;
178 /* Match an integer (digit string and optional kind).
179 A sign will be accepted if signflag is set. */
182 match_integer_constant (gfc_expr **result, int signflag)
189 old_loc = gfc_current_locus;
190 gfc_gobble_whitespace ();
192 length = match_digits (signflag, 10, NULL);
193 gfc_current_locus = old_loc;
197 buffer = alloca (length + 1);
198 memset (buffer, '\0', length + 1);
200 gfc_gobble_whitespace ();
202 match_digits (signflag, 10, buffer);
206 kind = gfc_default_integer_kind;
210 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
212 gfc_error ("Integer kind %d at %C not available", kind);
216 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
218 if (gfc_range_check (e) != ARITH_OK)
220 gfc_error ("Integer too big for its kind at %C. This check can be "
221 "disabled with the option -fno-range-check");
232 /* Match a Hollerith constant. */
235 match_hollerith_constant (gfc_expr **result)
243 old_loc = gfc_current_locus;
244 gfc_gobble_whitespace ();
246 if (match_integer_constant (&e, 0) == MATCH_YES
247 && gfc_match_char ('h') == MATCH_YES)
249 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
253 msg = gfc_extract_int (e, &num);
261 gfc_error ("Invalid Hollerith constant: %L must contain at least "
262 "one character", &old_loc);
265 if (e->ts.kind != gfc_default_integer_kind)
267 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
268 "should be default", &old_loc);
274 e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
277 e->representation.string = gfc_getmem (num + 1);
278 for (i = 0; i < num; i++)
280 e->representation.string[i] = gfc_next_char_literal (1);
282 e->representation.string[num] = '\0';
283 e->representation.length = num;
291 gfc_current_locus = old_loc;
300 /* Match a binary, octal or hexadecimal constant that can be found in
301 a DATA statement. The standard permits b'010...', o'73...', and
302 z'a1...' where b, o, and z can be capital letters. This function
303 also accepts postfixed forms of the constants: '01...'b, '73...'o,
304 and 'a1...'z. An additional extension is the use of x for z. */
307 match_boz_constant (gfc_expr **result)
309 int post, radix, delim, length, x_hex, kind;
310 locus old_loc, start_loc;
314 start_loc = old_loc = gfc_current_locus;
315 gfc_gobble_whitespace ();
318 switch (post = gfc_next_char ())
340 radix = 16; /* Set to accept any valid digit string. */
346 /* No whitespace allowed here. */
349 delim = gfc_next_char ();
351 if (delim != '\'' && delim != '\"')
355 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
356 "constant at %C uses non-standard syntax")
360 old_loc = gfc_current_locus;
362 length = match_digits (0, radix, NULL);
365 gfc_error ("Empty set of digits in BOZ constant at %C");
369 if (gfc_next_char () != delim)
371 gfc_error ("Illegal character in BOZ constant at %C");
377 switch (gfc_next_char ())
394 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
395 "at %C uses non-standard postfix syntax")
400 gfc_current_locus = old_loc;
402 buffer = alloca (length + 1);
403 memset (buffer, '\0', length + 1);
405 match_digits (0, radix, buffer);
406 gfc_next_char (); /* Eat delimiter. */
408 gfc_next_char (); /* Eat postfixed b, o, z, or x. */
410 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
411 "If a data-stmt-constant is a boz-literal-constant, the corresponding
412 variable shall be of type integer. The boz-literal-constant is treated
413 as if it were an int-literal-constant with a kind-param that specifies
414 the representation method with the largest decimal exponent range
415 supported by the processor." */
417 kind = gfc_max_integer_kind;
418 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
420 /* Mark as boz variable. */
423 if (gfc_range_check (e) != ARITH_OK)
425 gfc_error ("Integer too big for integer kind %i at %C", kind);
430 if (!gfc_in_match_data ()
431 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
440 gfc_current_locus = start_loc;
445 /* Match a real constant of some sort. Allow a signed constant if signflag
449 match_real_constant (gfc_expr **result, int signflag)
451 int kind, c, count, seen_dp, seen_digits, exp_char;
452 locus old_loc, temp_loc;
457 old_loc = gfc_current_locus;
458 gfc_gobble_whitespace ();
468 c = gfc_next_char ();
469 if (signflag && (c == '+' || c == '-'))
474 gfc_gobble_whitespace ();
475 c = gfc_next_char ();
478 /* Scan significand. */
479 for (;; c = gfc_next_char (), count++)
486 /* Check to see if "." goes with a following operator like
488 temp_loc = gfc_current_locus;
489 c = gfc_next_char ();
491 if (c == 'e' || c == 'd' || c == 'q')
493 c = gfc_next_char ();
495 goto done; /* Operator named .e. or .d. */
499 goto done; /* Distinguish 1.e9 from 1.eq.2 */
501 gfc_current_locus = temp_loc;
515 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
520 c = gfc_next_char ();
523 if (c == '+' || c == '-')
524 { /* optional sign */
525 c = gfc_next_char ();
531 gfc_error ("Missing exponent in real number at %C");
537 c = gfc_next_char ();
542 /* Check that we have a numeric constant. */
543 if (!seen_digits || (!seen_dp && exp_char == ' '))
545 gfc_current_locus = old_loc;
549 /* Convert the number. */
550 gfc_current_locus = old_loc;
551 gfc_gobble_whitespace ();
553 buffer = alloca (count + 1);
554 memset (buffer, '\0', count + 1);
557 c = gfc_next_char ();
558 if (c == '+' || c == '-')
560 gfc_gobble_whitespace ();
561 c = gfc_next_char ();
564 /* Hack for mpfr_set_str(). */
567 if (c == 'd' || c == 'q')
575 c = gfc_next_char ();
587 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
591 kind = gfc_default_double_kind;
596 kind = gfc_default_real_kind;
598 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
600 gfc_error ("Invalid real kind %d at %C", kind);
605 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
607 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
609 switch (gfc_range_check (e))
614 gfc_error ("Real constant overflows its kind at %C");
617 case ARITH_UNDERFLOW:
618 if (gfc_option.warn_underflow)
619 gfc_warning ("Real constant underflows its kind at %C");
620 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
624 gfc_internal_error ("gfc_range_check() returned bad value");
636 /* Match a substring reference. */
639 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
641 gfc_expr *start, *end;
649 old_loc = gfc_current_locus;
651 m = gfc_match_char ('(');
655 if (gfc_match_char (':') != MATCH_YES)
658 m = gfc_match_init_expr (&start);
660 m = gfc_match_expr (&start);
668 m = gfc_match_char (':');
673 if (gfc_match_char (')') != MATCH_YES)
676 m = gfc_match_init_expr (&end);
678 m = gfc_match_expr (&end);
682 if (m == MATCH_ERROR)
685 m = gfc_match_char (')');
690 /* Optimize away the (:) reference. */
691 if (start == NULL && end == NULL)
695 ref = gfc_get_ref ();
697 ref->type = REF_SUBSTRING;
699 start = gfc_int_expr (1);
700 ref->u.ss.start = start;
701 if (end == NULL && cl)
702 end = gfc_copy_expr (cl->length);
704 ref->u.ss.length = cl;
711 gfc_error ("Syntax error in SUBSTRING specification at %C");
715 gfc_free_expr (start);
718 gfc_current_locus = old_loc;
723 /* Reads the next character of a string constant, taking care to
724 return doubled delimiters on the input as a single instance of
727 Special return values are:
728 -1 End of the string, as determined by the delimiter
729 -2 Unterminated string detected
731 Backslash codes are also expanded at this time. */
734 next_string_char (char delimiter)
739 c = gfc_next_char_literal (1);
744 if (gfc_option.flag_backslash && c == '\\')
746 old_locus = gfc_current_locus;
748 if (gfc_match_special_char (&c) == MATCH_NO)
749 gfc_current_locus = old_locus;
751 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
752 gfc_warning ("Extension: backslash character at %C");
758 old_locus = gfc_current_locus;
759 c = gfc_next_char_literal (0);
763 gfc_current_locus = old_locus;
769 /* Special case of gfc_match_name() that matches a parameter kind name
770 before a string constant. This takes case of the weird but legal
775 where kind____ is a parameter. gfc_match_name() will happily slurp
776 up all the underscores, which leads to problems. If we return
777 MATCH_YES, the parse pointer points to the final underscore, which
778 is not part of the name. We never return MATCH_ERROR-- errors in
779 the name will be detected later. */
782 match_charkind_name (char *name)
788 gfc_gobble_whitespace ();
789 c = gfc_next_char ();
798 old_loc = gfc_current_locus;
799 c = gfc_next_char ();
803 peek = gfc_peek_char ();
805 if (peek == '\'' || peek == '\"')
807 gfc_current_locus = old_loc;
815 && (gfc_option.flag_dollar_ok && c != '$'))
819 if (++len > GFC_MAX_SYMBOL_LEN)
827 /* See if the current input matches a character constant. Lots of
828 contortions have to be done to match the kind parameter which comes
829 before the actual string. The main consideration is that we don't
830 want to error out too quickly. For example, we don't actually do
831 any validation of the kinds until we have actually seen a legal
832 delimiter. Using match_kind_param() generates errors too quickly. */
835 match_string_constant (gfc_expr **result)
837 char *p, name[GFC_MAX_SYMBOL_LEN + 1];
838 int i, c, kind, length, delimiter, warn_ampersand;
839 locus old_locus, start_locus;
845 old_locus = gfc_current_locus;
847 gfc_gobble_whitespace ();
849 start_locus = gfc_current_locus;
851 c = gfc_next_char ();
852 if (c == '\'' || c == '"')
854 kind = gfc_default_character_kind;
864 kind = kind * 10 + c - '0';
867 c = gfc_next_char ();
873 gfc_current_locus = old_locus;
875 m = match_charkind_name (name);
879 if (gfc_find_symbol (name, NULL, 1, &sym)
881 || sym->attr.flavor != FL_PARAMETER)
885 c = gfc_next_char ();
890 gfc_gobble_whitespace ();
891 c = gfc_next_char ();
897 gfc_gobble_whitespace ();
898 start_locus = gfc_current_locus;
900 c = gfc_next_char ();
901 if (c != '\'' && c != '"')
906 q = gfc_extract_int (sym->value, &kind);
912 gfc_set_sym_referenced (sym);
915 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
917 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
922 /* Scan the string into a block of memory by first figuring out how
923 long it is, allocating the structure, then re-reading it. This
924 isn't particularly efficient, but string constants aren't that
925 common in most code. TODO: Use obstacks? */
932 c = next_string_char (delimiter);
937 gfc_current_locus = start_locus;
938 gfc_error ("Unterminated character constant beginning at %C");
945 /* Peek at the next character to see if it is a b, o, z, or x for the
946 postfixed BOZ literal constants. */
947 c = gfc_peek_char ();
948 if (c == 'b' || c == 'o' || c =='z' || c == 'x')
954 e->expr_type = EXPR_CONSTANT;
956 e->ts.type = BT_CHARACTER;
958 e->ts.is_c_interop = 0;
960 e->where = start_locus;
962 e->value.character.string = p = gfc_getmem (length + 1);
963 e->value.character.length = length;
965 gfc_current_locus = start_locus;
966 gfc_next_char (); /* Skip delimiter */
968 /* We disable the warning for the following loop as the warning has already
969 been printed in the loop above. */
970 warn_ampersand = gfc_option.warn_ampersand;
971 gfc_option.warn_ampersand = 0;
973 for (i = 0; i < length; i++)
974 *p++ = next_string_char (delimiter);
976 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
977 gfc_option.warn_ampersand = warn_ampersand;
979 if (next_string_char (delimiter) != -1)
980 gfc_internal_error ("match_string_constant(): Delimiter not found");
982 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
983 e->expr_type = EXPR_SUBSTRING;
990 gfc_current_locus = old_locus;
995 /* Match a .true. or .false. Returns 1 if a .true. was found,
996 0 if a .false. was found, and -1 otherwise. */
998 match_logical_constant_string (void)
1000 locus orig_loc = gfc_current_locus;
1002 gfc_gobble_whitespace ();
1003 if (gfc_next_char () == '.')
1005 int ch = gfc_next_char();
1008 if (gfc_next_char () == 'a'
1009 && gfc_next_char () == 'l'
1010 && gfc_next_char () == 's'
1011 && gfc_next_char () == 'e'
1012 && gfc_next_char () == '.')
1013 /* Matched ".false.". */
1018 if (gfc_next_char () == 'r'
1019 && gfc_next_char () == 'u'
1020 && gfc_next_char () == 'e'
1021 && gfc_next_char () == '.')
1022 /* Matched ".true.". */
1026 gfc_current_locus = orig_loc;
1030 /* Match a .true. or .false. */
1033 match_logical_constant (gfc_expr **result)
1038 i = match_logical_constant_string ();
1046 kind = gfc_default_logical_kind;
1048 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1050 gfc_error ("Bad kind for logical constant at %C");
1054 e = gfc_get_expr ();
1056 e->expr_type = EXPR_CONSTANT;
1057 e->value.logical = i;
1058 e->ts.type = BT_LOGICAL;
1060 e->ts.is_c_interop = 0;
1062 e->where = gfc_current_locus;
1069 /* Match a real or imaginary part of a complex constant that is a
1070 symbolic constant. */
1073 match_sym_complex_part (gfc_expr **result)
1075 char name[GFC_MAX_SYMBOL_LEN + 1];
1080 m = gfc_match_name (name);
1084 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1087 if (sym->attr.flavor != FL_PARAMETER)
1089 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1093 if (!gfc_numeric_ts (&sym->value->ts))
1095 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1099 if (sym->value->rank != 0)
1101 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1105 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1106 "complex constant at %C") == FAILURE)
1109 switch (sym->value->ts.type)
1112 e = gfc_copy_expr (sym->value);
1116 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1122 e = gfc_int2real (sym->value, gfc_default_real_kind);
1128 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1131 *result = e; /* e is a scalar, real, constant expression. */
1135 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1140 /* Match a real or imaginary part of a complex number. */
1143 match_complex_part (gfc_expr **result)
1147 m = match_sym_complex_part (result);
1151 m = match_real_constant (result, 1);
1155 return match_integer_constant (result, 1);
1159 /* Try to match a complex constant. */
1162 match_complex_constant (gfc_expr **result)
1164 gfc_expr *e, *real, *imag;
1165 gfc_error_buf old_error;
1166 gfc_typespec target;
1171 old_loc = gfc_current_locus;
1172 real = imag = e = NULL;
1174 m = gfc_match_char ('(');
1178 gfc_push_error (&old_error);
1180 m = match_complex_part (&real);
1183 gfc_free_error (&old_error);
1187 if (gfc_match_char (',') == MATCH_NO)
1189 gfc_pop_error (&old_error);
1194 /* If m is error, then something was wrong with the real part and we
1195 assume we have a complex constant because we've seen the ','. An
1196 ambiguous case here is the start of an iterator list of some
1197 sort. These sort of lists are matched prior to coming here. */
1199 if (m == MATCH_ERROR)
1201 gfc_free_error (&old_error);
1204 gfc_pop_error (&old_error);
1206 m = match_complex_part (&imag);
1209 if (m == MATCH_ERROR)
1212 m = gfc_match_char (')');
1215 /* Give the matcher for implied do-loops a chance to run. This
1216 yields a much saner error message for (/ (i, 4=i, 6) /). */
1217 if (gfc_peek_char () == '=')
1226 if (m == MATCH_ERROR)
1229 /* Decide on the kind of this complex number. */
1230 if (real->ts.type == BT_REAL)
1232 if (imag->ts.type == BT_REAL)
1233 kind = gfc_kind_max (real, imag);
1235 kind = real->ts.kind;
1239 if (imag->ts.type == BT_REAL)
1240 kind = imag->ts.kind;
1242 kind = gfc_default_real_kind;
1244 target.type = BT_REAL;
1246 target.is_c_interop = 0;
1247 target.is_iso_c = 0;
1249 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1250 gfc_convert_type (real, &target, 2);
1251 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1252 gfc_convert_type (imag, &target, 2);
1254 e = gfc_convert_complex (real, imag, kind);
1255 e->where = gfc_current_locus;
1257 gfc_free_expr (real);
1258 gfc_free_expr (imag);
1264 gfc_error ("Syntax error in COMPLEX constant at %C");
1269 gfc_free_expr (real);
1270 gfc_free_expr (imag);
1271 gfc_current_locus = old_loc;
1277 /* Match constants in any of several forms. Returns nonzero for a
1278 match, zero for no match. */
1281 gfc_match_literal_constant (gfc_expr **result, int signflag)
1285 m = match_complex_constant (result);
1289 m = match_string_constant (result);
1293 m = match_boz_constant (result);
1297 m = match_real_constant (result, signflag);
1301 m = match_hollerith_constant (result);
1305 m = match_integer_constant (result, signflag);
1309 m = match_logical_constant (result);
1317 /* Match a single actual argument value. An actual argument is
1318 usually an expression, but can also be a procedure name. If the
1319 argument is a single name, it is not always possible to tell
1320 whether the name is a dummy procedure or not. We treat these cases
1321 by creating an argument that looks like a dummy procedure and
1322 fixing things later during resolution. */
1325 match_actual_arg (gfc_expr **result)
1327 char name[GFC_MAX_SYMBOL_LEN + 1];
1328 gfc_symtree *symtree;
1333 where = gfc_current_locus;
1335 switch (gfc_match_name (name))
1344 w = gfc_current_locus;
1345 gfc_gobble_whitespace ();
1346 c = gfc_next_char ();
1347 gfc_current_locus = w;
1349 if (c != ',' && c != ')')
1352 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1354 /* Handle error elsewhere. */
1356 /* Eliminate a couple of common cases where we know we don't
1357 have a function argument. */
1358 if (symtree == NULL)
1360 gfc_get_sym_tree (name, NULL, &symtree);
1361 gfc_set_sym_referenced (symtree->n.sym);
1367 sym = symtree->n.sym;
1368 gfc_set_sym_referenced (sym);
1369 if (sym->attr.flavor != FL_PROCEDURE
1370 && sym->attr.flavor != FL_UNKNOWN)
1373 /* If the symbol is a function with itself as the result and
1374 is being defined, then we have a variable. */
1375 if (sym->attr.function && sym->result == sym)
1377 if (gfc_current_ns->proc_name == sym
1378 || (gfc_current_ns->parent != NULL
1379 && gfc_current_ns->parent->proc_name == sym))
1383 && (sym->ns == gfc_current_ns
1384 || sym->ns == gfc_current_ns->parent))
1386 gfc_entry_list *el = NULL;
1388 for (el = sym->ns->entries; el; el = el->next)
1398 e = gfc_get_expr (); /* Leave it unknown for now */
1399 e->symtree = symtree;
1400 e->expr_type = EXPR_VARIABLE;
1401 e->ts.type = BT_PROCEDURE;
1408 gfc_current_locus = where;
1409 return gfc_match_expr (result);
1413 /* Match a keyword argument. */
1416 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1418 char name[GFC_MAX_SYMBOL_LEN + 1];
1419 gfc_actual_arglist *a;
1423 name_locus = gfc_current_locus;
1424 m = gfc_match_name (name);
1428 if (gfc_match_char ('=') != MATCH_YES)
1434 m = match_actual_arg (&actual->expr);
1438 /* Make sure this name has not appeared yet. */
1440 if (name[0] != '\0')
1442 for (a = base; a; a = a->next)
1443 if (a->name != NULL && strcmp (a->name, name) == 0)
1445 gfc_error ("Keyword '%s' at %C has already appeared in the "
1446 "current argument list", name);
1451 actual->name = gfc_get_string (name);
1455 gfc_current_locus = name_locus;
1460 /* Match an argument list function, such as %VAL. */
1463 match_arg_list_function (gfc_actual_arglist *result)
1465 char name[GFC_MAX_SYMBOL_LEN + 1];
1469 old_locus = gfc_current_locus;
1471 if (gfc_match_char ('%') != MATCH_YES)
1477 m = gfc_match ("%n (", name);
1481 if (name[0] != '\0')
1486 if (strncmp (name, "loc", 3) == 0)
1488 result->name = "%LOC";
1492 if (strncmp (name, "ref", 3) == 0)
1494 result->name = "%REF";
1498 if (strncmp (name, "val", 3) == 0)
1500 result->name = "%VAL";
1509 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1510 "function at %C") == FAILURE)
1516 m = match_actual_arg (&result->expr);
1520 if (gfc_match_char (')') != MATCH_YES)
1529 gfc_current_locus = old_locus;
1534 /* Matches an actual argument list of a function or subroutine, from
1535 the opening parenthesis to the closing parenthesis. The argument
1536 list is assumed to allow keyword arguments because we don't know if
1537 the symbol associated with the procedure has an implicit interface
1538 or not. We make sure keywords are unique. If sub_flag is set,
1539 we're matching the argument list of a subroutine. */
1542 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1544 gfc_actual_arglist *head, *tail;
1546 gfc_st_label *label;
1550 *argp = tail = NULL;
1551 old_loc = gfc_current_locus;
1555 if (gfc_match_char ('(') == MATCH_NO)
1556 return (sub_flag) ? MATCH_YES : MATCH_NO;
1558 if (gfc_match_char (')') == MATCH_YES)
1565 head = tail = gfc_get_actual_arglist ();
1568 tail->next = gfc_get_actual_arglist ();
1572 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1574 m = gfc_match_st_label (&label);
1576 gfc_error ("Expected alternate return label at %C");
1580 tail->label = label;
1584 /* After the first keyword argument is seen, the following
1585 arguments must also have keywords. */
1588 m = match_keyword_arg (tail, head);
1590 if (m == MATCH_ERROR)
1594 gfc_error ("Missing keyword name in actual argument list at %C");
1601 /* Try an argument list function, like %VAL. */
1602 m = match_arg_list_function (tail);
1603 if (m == MATCH_ERROR)
1606 /* See if we have the first keyword argument. */
1609 m = match_keyword_arg (tail, head);
1612 if (m == MATCH_ERROR)
1618 /* Try for a non-keyword argument. */
1619 m = match_actual_arg (&tail->expr);
1620 if (m == MATCH_ERROR)
1629 if (gfc_match_char (')') == MATCH_YES)
1631 if (gfc_match_char (',') != MATCH_YES)
1639 gfc_error ("Syntax error in argument list at %C");
1642 gfc_free_actual_arglist (head);
1643 gfc_current_locus = old_loc;
1649 /* Used by match_varspec() to extend the reference list by one
1653 extend_ref (gfc_expr *primary, gfc_ref *tail)
1655 if (primary->ref == NULL)
1656 primary->ref = tail = gfc_get_ref ();
1660 gfc_internal_error ("extend_ref(): Bad tail");
1661 tail->next = gfc_get_ref ();
1669 /* Match any additional specifications associated with the current
1670 variable like member references or substrings. If equiv_flag is
1671 set we only match stuff that is allowed inside an EQUIVALENCE
1675 match_varspec (gfc_expr *primary, int equiv_flag)
1677 char name[GFC_MAX_SYMBOL_LEN + 1];
1678 gfc_ref *substring, *tail;
1679 gfc_component *component;
1680 gfc_symbol *sym = primary->symtree->n.sym;
1686 gfc_gobble_whitespace ();
1687 if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
1689 /* In EQUIVALENCE, we don't know yet whether we are seeing
1690 an array, character variable or array of character
1691 variables. We'll leave the decision till resolve time. */
1692 tail = extend_ref (primary, tail);
1693 tail->type = REF_ARRAY;
1695 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1700 gfc_gobble_whitespace ();
1701 if (equiv_flag && gfc_peek_char () == '(')
1703 tail = extend_ref (primary, tail);
1704 tail->type = REF_ARRAY;
1706 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1712 primary->ts = sym->ts;
1717 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1718 goto check_substring;
1720 sym = sym->ts.derived;
1724 m = gfc_match_name (name);
1726 gfc_error ("Expected structure component name at %C");
1730 component = gfc_find_component (sym, name);
1731 if (component == NULL)
1734 tail = extend_ref (primary, tail);
1735 tail->type = REF_COMPONENT;
1737 tail->u.c.component = component;
1738 tail->u.c.sym = sym;
1740 primary->ts = component->ts;
1742 if (component->as != NULL)
1744 tail = extend_ref (primary, tail);
1745 tail->type = REF_ARRAY;
1747 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1752 if (component->ts.type != BT_DERIVED
1753 || gfc_match_char ('%') != MATCH_YES)
1756 sym = component->ts.derived;
1761 if (primary->ts.type == BT_UNKNOWN)
1763 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1765 gfc_set_default_type (sym, 0, sym->ns);
1766 primary->ts = sym->ts;
1771 if (primary->ts.type == BT_CHARACTER)
1773 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1777 primary->ref = substring;
1779 tail->next = substring;
1781 if (primary->expr_type == EXPR_CONSTANT)
1782 primary->expr_type = EXPR_SUBSTRING;
1785 primary->ts.cl = NULL;
1791 gfc_clear_ts (&primary->ts);
1803 /* Given an expression that is a variable, figure out what the
1804 ultimate variable's type and attribute is, traversing the reference
1805 structures if necessary.
1807 This subroutine is trickier than it looks. We start at the base
1808 symbol and store the attribute. Component references load a
1809 completely new attribute.
1811 A couple of rules come into play. Subobjects of targets are always
1812 targets themselves. If we see a component that goes through a
1813 pointer, then the expression must also be a target, since the
1814 pointer is associated with something (if it isn't core will soon be
1815 dumped). If we see a full part or section of an array, the
1816 expression is also an array.
1818 We can have at most one full array reference. */
1821 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1823 int dimension, pointer, allocatable, target;
1824 symbol_attribute attr;
1827 if (expr->expr_type != EXPR_VARIABLE)
1828 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1831 attr = expr->symtree->n.sym->attr;
1833 dimension = attr.dimension;
1834 pointer = attr.pointer;
1835 allocatable = attr.allocatable;
1837 target = attr.target;
1841 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1842 *ts = expr->symtree->n.sym->ts;
1844 for (; ref; ref = ref->next)
1849 switch (ref->u.ar.type)
1856 allocatable = pointer = 0;
1861 allocatable = pointer = 0;
1865 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1871 gfc_get_component_attr (&attr, ref->u.c.component);
1874 *ts = ref->u.c.component->ts;
1875 /* Don't set the string length if a substring reference
1877 if (ts->type == BT_CHARACTER
1878 && ref->next && ref->next->type == REF_SUBSTRING)
1882 pointer = ref->u.c.component->pointer;
1883 allocatable = ref->u.c.component->allocatable;
1890 allocatable = pointer = 0;
1894 attr.dimension = dimension;
1895 attr.pointer = pointer;
1896 attr.allocatable = allocatable;
1897 attr.target = target;
1903 /* Return the attribute from a general expression. */
1906 gfc_expr_attr (gfc_expr *e)
1908 symbol_attribute attr;
1910 switch (e->expr_type)
1913 attr = gfc_variable_attr (e, NULL);
1917 gfc_clear_attr (&attr);
1919 if (e->value.function.esym != NULL)
1920 attr = e->value.function.esym->result->attr;
1922 /* TODO: NULL() returns pointers. May have to take care of this
1928 gfc_clear_attr (&attr);
1936 /* Match a structure constructor. The initial symbol has already been
1940 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
1942 gfc_constructor *head, *tail;
1943 gfc_component *comp;
1947 bool private_comp = false;
1951 if (gfc_match_char ('(') != MATCH_YES)
1954 where = gfc_current_locus;
1956 gfc_find_component (sym, NULL);
1958 for (comp = sym->components; comp; comp = comp->next)
1960 if (comp->access == ACCESS_PRIVATE)
1962 private_comp = true;
1966 tail = head = gfc_get_constructor ();
1969 tail->next = gfc_get_constructor ();
1973 m = gfc_match_expr (&tail->expr);
1976 if (m == MATCH_ERROR)
1979 if (gfc_match_char (',') == MATCH_YES)
1981 if (comp->next == NULL)
1983 gfc_error ("Too many components in structure constructor at %C");
1993 if (sym->attr.use_assoc
1994 && (sym->component_access == ACCESS_PRIVATE || private_comp))
1996 gfc_error ("Structure constructor for '%s' at %C has PRIVATE "
1997 "components", sym->name);
2001 if (gfc_match_char (')') != MATCH_YES)
2004 if (comp && comp->next != NULL)
2006 gfc_error ("Too few components in structure constructor at %C");
2010 e = gfc_get_expr ();
2012 e->expr_type = EXPR_STRUCTURE;
2014 e->ts.type = BT_DERIVED;
2015 e->ts.derived = sym;
2018 e->value.constructor = head;
2024 gfc_error ("Syntax error in structure constructor at %C");
2027 gfc_free_constructor (head);
2032 /* If the symbol is an implicit do loop index and implicitly typed,
2033 it should not be host associated. Provide a symtree from the
2034 current namespace. */
2036 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2038 if ((*sym)->attr.flavor == FL_VARIABLE
2039 && (*sym)->ns != gfc_current_ns
2040 && (*sym)->attr.implied_index
2041 && (*sym)->attr.implicit_type
2042 && !(*sym)->attr.use_assoc)
2045 i = gfc_get_sym_tree ((*sym)->name, NULL, st);
2048 *sym = (*st)->n.sym;
2054 /* Matches a variable name followed by anything that might follow it--
2055 array reference, argument list of a function, etc. */
2058 gfc_match_rvalue (gfc_expr **result)
2060 gfc_actual_arglist *actual_arglist;
2061 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2064 gfc_symtree *symtree;
2065 locus where, old_loc;
2073 m = gfc_match_name (name);
2077 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2078 && !gfc_current_ns->has_import_set)
2079 i = gfc_get_sym_tree (name, NULL, &symtree);
2081 i = gfc_get_ha_sym_tree (name, &symtree);
2086 sym = symtree->n.sym;
2088 where = gfc_current_locus;
2090 /* If this is an implicit do loop index and implicitly typed,
2091 it should not be host associated. */
2092 m = check_for_implicit_index (&symtree, &sym);
2096 gfc_set_sym_referenced (sym);
2097 sym->attr.implied_index = 0;
2099 if (sym->attr.function && sym->result == sym)
2101 /* See if this is a directly recursive function call. */
2102 gfc_gobble_whitespace ();
2103 if (sym->attr.recursive
2104 && gfc_peek_char () == '('
2105 && gfc_current_ns->proc_name == sym
2106 && !sym->attr.dimension)
2108 gfc_error ("'%s' at %C is the name of a recursive function "
2109 "and so refers to the result variable. Use an "
2110 "explicit RESULT variable for direct recursion "
2111 "(12.5.2.1)", sym->name);
2115 if (gfc_current_ns->proc_name == sym
2116 || (gfc_current_ns->parent != NULL
2117 && gfc_current_ns->parent->proc_name == sym))
2121 && (sym->ns == gfc_current_ns
2122 || sym->ns == gfc_current_ns->parent))
2124 gfc_entry_list *el = NULL;
2126 for (el = sym->ns->entries; el; el = el->next)
2132 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2135 if (sym->attr.generic)
2136 goto generic_function;
2138 switch (sym->attr.flavor)
2142 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
2143 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2144 gfc_set_default_type (sym, 0, sym->ns);
2146 e = gfc_get_expr ();
2148 e->expr_type = EXPR_VARIABLE;
2149 e->symtree = symtree;
2151 m = match_varspec (e, 0);
2155 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2156 end up here. Unfortunately, sym->value->expr_type is set to
2157 EXPR_CONSTANT, and so the if () branch would be followed without
2158 the !sym->as check. */
2159 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2160 e = gfc_copy_expr (sym->value);
2163 e = gfc_get_expr ();
2164 e->expr_type = EXPR_VARIABLE;
2167 e->symtree = symtree;
2168 m = match_varspec (e, 0);
2170 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2173 /* Variable array references to derived type parameters cause
2174 all sorts of headaches in simplification. Treating such
2175 expressions as variable works just fine for all array
2177 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2179 for (ref = e->ref; ref; ref = ref->next)
2180 if (ref->type == REF_ARRAY)
2183 if (ref == NULL || ref->u.ar.type == AR_FULL)
2189 e = gfc_get_expr ();
2190 e->expr_type = EXPR_VARIABLE;
2191 e->symtree = symtree;
2198 sym = gfc_use_derived (sym);
2202 m = gfc_match_structure_constructor (sym, &e);
2205 /* If we're here, then the name is known to be the name of a
2206 procedure, yet it is not sure to be the name of a function. */
2208 if (sym->attr.subroutine)
2210 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2216 /* At this point, the name has to be a non-statement function.
2217 If the name is the same as the current function being
2218 compiled, then we have a variable reference (to the function
2219 result) if the name is non-recursive. */
2221 st = gfc_enclosing_unit (NULL);
2223 if (st != NULL && st->state == COMP_FUNCTION
2225 && !sym->attr.recursive)
2227 e = gfc_get_expr ();
2228 e->symtree = symtree;
2229 e->expr_type = EXPR_VARIABLE;
2231 m = match_varspec (e, 0);
2235 /* Match a function reference. */
2237 m = gfc_match_actual_arglist (0, &actual_arglist);
2240 if (sym->attr.proc == PROC_ST_FUNCTION)
2241 gfc_error ("Statement function '%s' requires argument list at %C",
2244 gfc_error ("Function '%s' requires an argument list at %C",
2257 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2258 sym = symtree->n.sym;
2260 e = gfc_get_expr ();
2261 e->symtree = symtree;
2262 e->expr_type = EXPR_FUNCTION;
2263 e->value.function.actual = actual_arglist;
2264 e->where = gfc_current_locus;
2266 if (sym->as != NULL)
2267 e->rank = sym->as->rank;
2269 if (!sym->attr.function
2270 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2276 /* Check here for the existence of at least one argument for the
2277 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2278 argument(s) given will be checked in gfc_iso_c_func_interface,
2279 during resolution of the function call. */
2280 if (sym->attr.is_iso_c == 1
2281 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2282 && (sym->intmod_sym_id == ISOCBINDING_LOC
2283 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2284 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2286 /* make sure we were given a param */
2287 if (actual_arglist == NULL)
2289 gfc_error ("Missing argument to '%s' at %C", sym->name);
2295 if (sym->result == NULL)
2303 /* Special case for derived type variables that get their types
2304 via an IMPLICIT statement. This can't wait for the
2305 resolution phase. */
2307 if (gfc_peek_char () == '%'
2308 && sym->ts.type == BT_UNKNOWN
2309 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2310 gfc_set_default_type (sym, 0, sym->ns);
2312 /* If the symbol has a dimension attribute, the expression is a
2315 if (sym->attr.dimension)
2317 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2318 sym->name, NULL) == FAILURE)
2324 e = gfc_get_expr ();
2325 e->symtree = symtree;
2326 e->expr_type = EXPR_VARIABLE;
2327 m = match_varspec (e, 0);
2331 /* Name is not an array, so we peek to see if a '(' implies a
2332 function call or a substring reference. Otherwise the
2333 variable is just a scalar. */
2335 gfc_gobble_whitespace ();
2336 if (gfc_peek_char () != '(')
2338 /* Assume a scalar variable */
2339 e = gfc_get_expr ();
2340 e->symtree = symtree;
2341 e->expr_type = EXPR_VARIABLE;
2343 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2344 sym->name, NULL) == FAILURE)
2350 /*FIXME:??? match_varspec does set this for us: */
2352 m = match_varspec (e, 0);
2356 /* See if this is a function reference with a keyword argument
2357 as first argument. We do this because otherwise a spurious
2358 symbol would end up in the symbol table. */
2360 old_loc = gfc_current_locus;
2361 m2 = gfc_match (" ( %n =", argname);
2362 gfc_current_locus = old_loc;
2364 e = gfc_get_expr ();
2365 e->symtree = symtree;
2367 if (m2 != MATCH_YES)
2369 /* Try to figure out whether we're dealing with a character type.
2370 We're peeking ahead here, because we don't want to call
2371 match_substring if we're dealing with an implicitly typed
2372 non-character variable. */
2373 implicit_char = false;
2374 if (sym->ts.type == BT_UNKNOWN)
2376 ts = gfc_get_default_type (sym,NULL);
2377 if (ts->type == BT_CHARACTER)
2378 implicit_char = true;
2381 /* See if this could possibly be a substring reference of a name
2382 that we're not sure is a variable yet. */
2384 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2385 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2388 e->expr_type = EXPR_VARIABLE;
2390 if (sym->attr.flavor != FL_VARIABLE
2391 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2392 sym->name, NULL) == FAILURE)
2398 if (sym->ts.type == BT_UNKNOWN
2399 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2413 /* Give up, assume we have a function. */
2415 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2416 sym = symtree->n.sym;
2417 e->expr_type = EXPR_FUNCTION;
2419 if (!sym->attr.function
2420 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2428 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2430 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2438 /* If our new function returns a character, array or structure
2439 type, it might have subsequent references. */
2441 m = match_varspec (e, 0);
2448 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2450 e = gfc_get_expr ();
2451 e->symtree = symtree;
2452 e->expr_type = EXPR_FUNCTION;
2454 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2458 gfc_error ("Symbol at %C is not appropriate for an expression");
2474 /* Match a variable, ie something that can be assigned to. This
2475 starts as a symbol, can be a structure component or an array
2476 reference. It can be a function if the function doesn't have a
2477 separate RESULT variable. If the symbol has not been previously
2478 seen, we assume it is a variable.
2480 This function is called by two interface functions:
2481 gfc_match_variable, which has host_flag = 1, and
2482 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2483 match of the symbol to the local scope. */
2486 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2494 /* Since nothing has any business being an lvalue in a module
2495 specification block, an interface block or a contains section,
2496 we force the changed_symbols mechanism to work by setting
2497 host_flag to 0. This prevents valid symbols that have the name
2498 of keywords, such as 'end', being turned into variables by
2499 failed matching to assignments for, eg., END INTERFACE. */
2500 if (gfc_current_state () == COMP_MODULE
2501 || gfc_current_state () == COMP_INTERFACE
2502 || gfc_current_state () == COMP_CONTAINS)
2505 m = gfc_match_sym_tree (&st, host_flag);
2508 where = gfc_current_locus;
2512 /* If this is an implicit do loop index and implicitly typed,
2513 it should not be host associated. */
2514 m = check_for_implicit_index (&st, &sym);
2518 sym->attr.implied_index = 0;
2520 gfc_set_sym_referenced (sym);
2521 switch (sym->attr.flavor)
2524 if (sym->attr.protected && sym->attr.use_assoc)
2526 gfc_error ("Assigning to PROTECTED variable at %C");
2533 sym_flavor flavor = FL_UNKNOWN;
2535 gfc_gobble_whitespace ();
2537 if (sym->attr.external || sym->attr.procedure
2538 || sym->attr.function || sym->attr.subroutine)
2539 flavor = FL_PROCEDURE;
2541 /* If it is not a procedure, is not typed and is host associated,
2542 we cannot give it a flavor yet. */
2543 else if (sym->ns == gfc_current_ns->parent
2544 && sym->ts.type == BT_UNKNOWN)
2547 /* These are definitive indicators that this is a variable. */
2548 else if (gfc_peek_char () != '(' || sym->ts.type != BT_UNKNOWN
2549 || sym->attr.pointer || sym->as != NULL)
2550 flavor = FL_VARIABLE;
2552 if (flavor != FL_UNKNOWN
2553 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
2560 gfc_error ("Named constant at %C in an EQUIVALENCE");
2562 gfc_error ("Cannot assign to a named constant at %C");
2567 /* Check for a nonrecursive function result variable. */
2568 if (sym->attr.function
2569 && !sym->attr.external
2570 && sym->result == sym
2571 && ((sym == gfc_current_ns->proc_name
2572 && sym == gfc_current_ns->proc_name->result)
2573 || (gfc_current_ns->parent
2574 && sym == gfc_current_ns->parent->proc_name->result)
2576 && sym->ns == gfc_current_ns)
2578 && sym->ns == gfc_current_ns->parent)))
2580 /* If a function result is a derived type, then the derived
2581 type may still have to be resolved. */
2583 if (sym->ts.type == BT_DERIVED
2584 && gfc_use_derived (sym->ts.derived) == NULL)
2589 /* Fall through to error */
2592 gfc_error ("'%s' at %C is not a variable", sym->name);
2596 /* Special case for derived type variables that get their types
2597 via an IMPLICIT statement. This can't wait for the
2598 resolution phase. */
2601 gfc_namespace * implicit_ns;
2603 if (gfc_current_ns->proc_name == sym)
2604 implicit_ns = gfc_current_ns;
2606 implicit_ns = sym->ns;
2608 if (gfc_peek_char () == '%'
2609 && sym->ts.type == BT_UNKNOWN
2610 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2611 gfc_set_default_type (sym, 0, implicit_ns);
2614 expr = gfc_get_expr ();
2616 expr->expr_type = EXPR_VARIABLE;
2619 expr->where = where;
2621 /* Now see if we have to do more. */
2622 m = match_varspec (expr, equiv_flag);
2625 gfc_free_expr (expr);
2635 gfc_match_variable (gfc_expr **result, int equiv_flag)
2637 return match_variable (result, equiv_flag, 1);
2642 gfc_match_equiv_variable (gfc_expr **result)
2644 return match_variable (result, 1, 0);