1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
32 /* Matches a kind-parameter expression, which is either a named
33 symbolic constant or a nonnegative integer constant. If
34 successful, sets the kind value to the correct integer. */
37 match_kind_param (int *kind)
39 char name[GFC_MAX_SYMBOL_LEN + 1];
44 m = gfc_match_small_literal_int (kind, NULL);
48 m = gfc_match_name (name);
52 if (gfc_find_symbol (name, NULL, 1, &sym))
58 if (sym->attr.flavor != FL_PARAMETER)
61 p = gfc_extract_int (sym->value, kind);
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");
231 /* Match a Hollerith constant. */
234 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,
250 "Extension: Hollerith constant at %C")
254 msg = gfc_extract_int (e, &num);
262 gfc_error ("Invalid Hollerith constant: %L must contain at least one "
263 "character", &old_loc);
266 if (e->ts.kind != gfc_default_integer_kind)
268 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
269 "should be default", &old_loc);
274 buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
275 for (i = 0; i < num; i++)
277 buffer[i] = gfc_next_char_literal (1);
280 e = gfc_constant_result (BT_HOLLERITH,
281 gfc_default_character_kind, &gfc_current_locus);
282 e->value.character.string = gfc_getmem (num+1);
283 memcpy (e->value.character.string, buffer, num);
284 e->value.character.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 != '\"')
354 if (x_hex && pedantic
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 ())
393 gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
394 "at %C uses non-standard postfix syntax.");
397 gfc_current_locus = old_loc;
399 buffer = alloca (length + 1);
400 memset (buffer, '\0', length + 1);
402 match_digits (0, radix, buffer);
403 gfc_next_char (); /* Eat delimiter. */
405 gfc_next_char (); /* Eat postfixed b, o, z, or x. */
407 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
408 "If a data-stmt-constant is a boz-literal-constant, the corresponding
409 variable shall be of type integer. The boz-literal-constant is treated
410 as if it were an int-literal-constant with a kind-param that specifies
411 the representation method with the largest decimal exponent range
412 supported by the processor." */
414 kind = gfc_max_integer_kind;
415 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
417 if (gfc_range_check (e) != ARITH_OK)
419 gfc_error ("Integer too big for integer kind %i at %C", kind);
428 gfc_current_locus = start_loc;
433 /* Match a real constant of some sort. Allow a signed constant if signflag
434 is nonzero. Allow integer constants if allow_int is true. */
437 match_real_constant (gfc_expr ** result, int signflag)
439 int kind, c, count, seen_dp, seen_digits, exp_char;
440 locus old_loc, temp_loc;
445 old_loc = gfc_current_locus;
446 gfc_gobble_whitespace ();
456 c = gfc_next_char ();
457 if (signflag && (c == '+' || c == '-'))
462 gfc_gobble_whitespace ();
463 c = gfc_next_char ();
466 /* Scan significand. */
467 for (;; c = gfc_next_char (), count++)
474 /* Check to see if "." goes with a following operator like ".eq.". */
475 temp_loc = gfc_current_locus;
476 c = gfc_next_char ();
478 if (c == 'e' || c == 'd' || c == 'q')
480 c = gfc_next_char ();
482 goto done; /* Operator named .e. or .d. */
486 goto done; /* Distinguish 1.e9 from 1.eq.2 */
488 gfc_current_locus = temp_loc;
503 || (c != 'e' && c != 'd' && c != 'q'))
508 c = gfc_next_char ();
511 if (c == '+' || c == '-')
512 { /* optional sign */
513 c = gfc_next_char ();
519 gfc_error ("Missing exponent in real number at %C");
525 c = gfc_next_char ();
530 /* Check that we have a numeric constant. */
531 if (!seen_digits || (!seen_dp && exp_char == ' '))
533 gfc_current_locus = old_loc;
537 /* Convert the number. */
538 gfc_current_locus = old_loc;
539 gfc_gobble_whitespace ();
541 buffer = alloca (count + 1);
542 memset (buffer, '\0', count + 1);
545 c = gfc_next_char ();
546 if (c == '+' || c == '-')
548 gfc_gobble_whitespace ();
549 c = gfc_next_char ();
552 /* Hack for mpfr_set_str(). */
555 if (c == 'd' || c == 'q')
563 c = gfc_next_char ();
576 ("Real number at %C has a 'd' exponent and an explicit kind");
579 kind = gfc_default_double_kind;
586 ("Real number at %C has a 'q' exponent and an explicit kind");
589 kind = gfc_option.q_kind;
594 kind = gfc_default_real_kind;
596 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
598 gfc_error ("Invalid real kind %d at %C", kind);
603 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
605 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
607 switch (gfc_range_check (e))
612 gfc_error ("Real constant overflows its kind at %C");
615 case ARITH_UNDERFLOW:
616 if (gfc_option.warn_underflow)
617 gfc_warning ("Real constant underflows its kind at %C");
618 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
622 gfc_internal_error ("gfc_range_check() returned bad value");
634 /* Match a substring reference. */
637 match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
639 gfc_expr *start, *end;
647 old_loc = gfc_current_locus;
649 m = gfc_match_char ('(');
653 if (gfc_match_char (':') != MATCH_YES)
656 m = gfc_match_init_expr (&start);
658 m = gfc_match_expr (&start);
666 m = gfc_match_char (':');
671 if (gfc_match_char (')') != MATCH_YES)
674 m = gfc_match_init_expr (&end);
676 m = gfc_match_expr (&end);
680 if (m == MATCH_ERROR)
683 m = gfc_match_char (')');
688 /* Optimize away the (:) reference. */
689 if (start == NULL && end == NULL)
693 ref = gfc_get_ref ();
695 ref->type = REF_SUBSTRING;
697 start = gfc_int_expr (1);
698 ref->u.ss.start = start;
699 if (end == NULL && cl)
700 end = gfc_copy_expr (cl->length);
702 ref->u.ss.length = cl;
709 gfc_error ("Syntax error in SUBSTRING specification at %C");
713 gfc_free_expr (start);
716 gfc_current_locus = old_loc;
721 /* Reads the next character of a string constant, taking care to
722 return doubled delimiters on the input as a single instance of
725 Special return values are:
726 -1 End of the string, as determined by the delimiter
727 -2 Unterminated string detected
729 Backslash codes are also expanded at this time. */
732 next_string_char (char delimiter)
737 c = gfc_next_char_literal (1);
742 if (gfc_option.flag_backslash && c == '\\')
744 old_locus = gfc_current_locus;
746 switch (gfc_next_char_literal (1))
774 /* Unknown backslash codes are simply not expanded */
775 gfc_current_locus = old_locus;
783 old_locus = gfc_current_locus;
784 c = gfc_next_char_literal (1);
788 gfc_current_locus = old_locus;
794 /* Special case of gfc_match_name() that matches a parameter kind name
795 before a string constant. This takes case of the weird but legal
800 where kind____ is a parameter. gfc_match_name() will happily slurp
801 up all the underscores, which leads to problems. If we return
802 MATCH_YES, the parse pointer points to the final underscore, which
803 is not part of the name. We never return MATCH_ERROR-- errors in
804 the name will be detected later. */
807 match_charkind_name (char *name)
813 gfc_gobble_whitespace ();
814 c = gfc_next_char ();
823 old_loc = gfc_current_locus;
824 c = gfc_next_char ();
828 peek = gfc_peek_char ();
830 if (peek == '\'' || peek == '\"')
832 gfc_current_locus = old_loc;
840 && (gfc_option.flag_dollar_ok && c != '$'))
844 if (++len > GFC_MAX_SYMBOL_LEN)
852 /* See if the current input matches a character constant. Lots of
853 contortions have to be done to match the kind parameter which comes
854 before the actual string. The main consideration is that we don't
855 want to error out too quickly. For example, we don't actually do
856 any validation of the kinds until we have actually seen a legal
857 delimiter. Using match_kind_param() generates errors too quickly. */
860 match_string_constant (gfc_expr ** result)
862 char *p, name[GFC_MAX_SYMBOL_LEN + 1];
863 int i, c, kind, length, delimiter;
864 locus old_locus, start_locus;
870 old_locus = gfc_current_locus;
872 gfc_gobble_whitespace ();
874 start_locus = gfc_current_locus;
876 c = gfc_next_char ();
877 if (c == '\'' || c == '"')
879 kind = gfc_default_character_kind;
889 kind = kind * 10 + c - '0';
892 c = gfc_next_char ();
898 gfc_current_locus = old_locus;
900 m = match_charkind_name (name);
904 if (gfc_find_symbol (name, NULL, 1, &sym)
906 || sym->attr.flavor != FL_PARAMETER)
910 c = gfc_next_char ();
915 gfc_gobble_whitespace ();
916 c = gfc_next_char ();
922 gfc_gobble_whitespace ();
923 start_locus = gfc_current_locus;
925 c = gfc_next_char ();
926 if (c != '\'' && c != '"')
931 q = gfc_extract_int (sym->value, &kind);
939 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
941 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
946 /* Scan the string into a block of memory by first figuring out how
947 long it is, allocating the structure, then re-reading it. This
948 isn't particularly efficient, but string constants aren't that
949 common in most code. TODO: Use obstacks? */
956 c = next_string_char (delimiter);
961 gfc_current_locus = start_locus;
962 gfc_error ("Unterminated character constant beginning at %C");
969 /* Peek at the next character to see if it is a b, o, z, or x for the
970 postfixed BOZ literal constants. */
971 c = gfc_peek_char ();
972 if (c == 'b' || c == 'o' || c =='z' || c == 'x')
978 e->expr_type = EXPR_CONSTANT;
980 e->ts.type = BT_CHARACTER;
982 e->where = start_locus;
984 e->value.character.string = p = gfc_getmem (length + 1);
985 e->value.character.length = length;
987 gfc_current_locus = start_locus;
988 gfc_next_char (); /* Skip delimiter */
990 for (i = 0; i < length; i++)
991 *p++ = next_string_char (delimiter);
993 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
995 if (next_string_char (delimiter) != -1)
996 gfc_internal_error ("match_string_constant(): Delimiter not found");
998 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
999 e->expr_type = EXPR_SUBSTRING;
1006 gfc_current_locus = old_locus;
1011 /* Match a .true. or .false. */
1014 match_logical_constant (gfc_expr ** result)
1016 static mstring logical_ops[] = {
1017 minit (".false.", 0),
1018 minit (".true.", 1),
1025 i = gfc_match_strings (logical_ops);
1033 kind = gfc_default_logical_kind;
1035 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1036 gfc_error ("Bad kind for logical constant at %C");
1038 e = gfc_get_expr ();
1040 e->expr_type = EXPR_CONSTANT;
1041 e->value.logical = i;
1042 e->ts.type = BT_LOGICAL;
1044 e->where = gfc_current_locus;
1051 /* Match a real or imaginary part of a complex constant that is a
1052 symbolic constant. */
1055 match_sym_complex_part (gfc_expr ** result)
1057 char name[GFC_MAX_SYMBOL_LEN + 1];
1062 m = gfc_match_name (name);
1066 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1069 if (sym->attr.flavor != FL_PARAMETER)
1071 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1075 if (!gfc_numeric_ts (&sym->value->ts))
1077 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1081 if (sym->value->rank != 0)
1083 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1087 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1088 "complex constant at %C") == FAILURE)
1091 switch (sym->value->ts.type)
1094 e = gfc_copy_expr (sym->value);
1098 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1104 e = gfc_int2real (sym->value, gfc_default_real_kind);
1110 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1113 *result = e; /* e is a scalar, real, constant expression */
1117 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1122 /* Match a real or imaginary part of a complex number. */
1125 match_complex_part (gfc_expr ** result)
1129 m = match_sym_complex_part (result);
1133 m = match_real_constant (result, 1);
1137 return match_integer_constant (result, 1);
1141 /* Try to match a complex constant. */
1144 match_complex_constant (gfc_expr ** result)
1146 gfc_expr *e, *real, *imag;
1147 gfc_error_buf old_error;
1148 gfc_typespec target;
1153 old_loc = gfc_current_locus;
1154 real = imag = e = NULL;
1156 m = gfc_match_char ('(');
1160 gfc_push_error (&old_error);
1162 m = match_complex_part (&real);
1165 gfc_free_error (&old_error);
1169 if (gfc_match_char (',') == MATCH_NO)
1171 gfc_pop_error (&old_error);
1176 /* If m is error, then something was wrong with the real part and we
1177 assume we have a complex constant because we've seen the ','. An
1178 ambiguous case here is the start of an iterator list of some
1179 sort. These sort of lists are matched prior to coming here. */
1181 if (m == MATCH_ERROR)
1183 gfc_free_error (&old_error);
1186 gfc_pop_error (&old_error);
1188 m = match_complex_part (&imag);
1191 if (m == MATCH_ERROR)
1194 m = gfc_match_char (')');
1197 /* Give the matcher for implied do-loops a chance to run. This
1198 yields a much saner error message for (/ (i, 4=i, 6) /). */
1199 if (gfc_peek_char () == '=')
1208 if (m == MATCH_ERROR)
1211 /* Decide on the kind of this complex number. */
1212 if (real->ts.type == BT_REAL)
1214 if (imag->ts.type == BT_REAL)
1215 kind = gfc_kind_max (real, imag);
1217 kind = real->ts.kind;
1221 if (imag->ts.type == BT_REAL)
1222 kind = imag->ts.kind;
1224 kind = gfc_default_real_kind;
1226 target.type = BT_REAL;
1229 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1230 gfc_convert_type (real, &target, 2);
1231 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1232 gfc_convert_type (imag, &target, 2);
1234 e = gfc_convert_complex (real, imag, kind);
1235 e->where = gfc_current_locus;
1237 gfc_free_expr (real);
1238 gfc_free_expr (imag);
1244 gfc_error ("Syntax error in COMPLEX constant at %C");
1249 gfc_free_expr (real);
1250 gfc_free_expr (imag);
1251 gfc_current_locus = old_loc;
1257 /* Match constants in any of several forms. Returns nonzero for a
1258 match, zero for no match. */
1261 gfc_match_literal_constant (gfc_expr ** result, int signflag)
1265 m = match_complex_constant (result);
1269 m = match_string_constant (result);
1273 m = match_boz_constant (result);
1277 m = match_real_constant (result, signflag);
1281 m = match_hollerith_constant (result);
1285 m = match_integer_constant (result, signflag);
1289 m = match_logical_constant (result);
1297 /* Match a single actual argument value. An actual argument is
1298 usually an expression, but can also be a procedure name. If the
1299 argument is a single name, it is not always possible to tell
1300 whether the name is a dummy procedure or not. We treat these cases
1301 by creating an argument that looks like a dummy procedure and
1302 fixing things later during resolution. */
1305 match_actual_arg (gfc_expr ** result)
1307 char name[GFC_MAX_SYMBOL_LEN + 1];
1308 gfc_symtree *symtree;
1313 where = gfc_current_locus;
1315 switch (gfc_match_name (name))
1324 w = gfc_current_locus;
1325 gfc_gobble_whitespace ();
1326 c = gfc_next_char ();
1327 gfc_current_locus = w;
1329 if (c != ',' && c != ')')
1332 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1334 /* Handle error elsewhere. */
1336 /* Eliminate a couple of common cases where we know we don't
1337 have a function argument. */
1338 if (symtree == NULL)
1340 gfc_get_sym_tree (name, NULL, &symtree);
1341 gfc_set_sym_referenced (symtree->n.sym);
1347 sym = symtree->n.sym;
1348 gfc_set_sym_referenced (sym);
1349 if (sym->attr.flavor != FL_PROCEDURE
1350 && sym->attr.flavor != FL_UNKNOWN)
1353 /* If the symbol is a function with itself as the result and
1354 is being defined, then we have a variable. */
1355 if (sym->attr.function && sym->result == sym)
1357 if (gfc_current_ns->proc_name == sym
1358 || (gfc_current_ns->parent != NULL
1359 && gfc_current_ns->parent->proc_name == sym))
1363 && (sym->ns == gfc_current_ns
1364 || sym->ns == gfc_current_ns->parent))
1366 gfc_entry_list *el = NULL;
1368 for (el = sym->ns->entries; el; el = el->next)
1378 e = gfc_get_expr (); /* Leave it unknown for now */
1379 e->symtree = symtree;
1380 e->expr_type = EXPR_VARIABLE;
1381 e->ts.type = BT_PROCEDURE;
1388 gfc_current_locus = where;
1389 return gfc_match_expr (result);
1393 /* Match a keyword argument. */
1396 match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
1398 char name[GFC_MAX_SYMBOL_LEN + 1];
1399 gfc_actual_arglist *a;
1403 name_locus = gfc_current_locus;
1404 m = gfc_match_name (name);
1408 if (gfc_match_char ('=') != MATCH_YES)
1414 m = match_actual_arg (&actual->expr);
1418 /* Make sure this name has not appeared yet. */
1420 if (name[0] != '\0')
1422 for (a = base; a; a = a->next)
1423 if (a->name != NULL && strcmp (a->name, name) == 0)
1426 ("Keyword '%s' at %C has already appeared in the current "
1427 "argument list", name);
1432 actual->name = gfc_get_string (name);
1436 gfc_current_locus = name_locus;
1441 /* Matches an actual argument list of a function or subroutine, from
1442 the opening parenthesis to the closing parenthesis. The argument
1443 list is assumed to allow keyword arguments because we don't know if
1444 the symbol associated with the procedure has an implicit interface
1445 or not. We make sure keywords are unique. If SUB_FLAG is set,
1446 we're matching the argument list of a subroutine. */
1449 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
1451 gfc_actual_arglist *head, *tail;
1453 gfc_st_label *label;
1457 *argp = tail = NULL;
1458 old_loc = gfc_current_locus;
1462 if (gfc_match_char ('(') == MATCH_NO)
1463 return (sub_flag) ? MATCH_YES : MATCH_NO;
1465 if (gfc_match_char (')') == MATCH_YES)
1472 head = tail = gfc_get_actual_arglist ();
1475 tail->next = gfc_get_actual_arglist ();
1479 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1481 m = gfc_match_st_label (&label);
1483 gfc_error ("Expected alternate return label at %C");
1487 tail->label = label;
1491 /* After the first keyword argument is seen, the following
1492 arguments must also have keywords. */
1495 m = match_keyword_arg (tail, head);
1497 if (m == MATCH_ERROR)
1502 ("Missing keyword name in actual argument list at %C");
1509 /* See if we have the first keyword argument. */
1510 m = match_keyword_arg (tail, head);
1513 if (m == MATCH_ERROR)
1518 /* Try for a non-keyword argument. */
1519 m = match_actual_arg (&tail->expr);
1520 if (m == MATCH_ERROR)
1528 if (gfc_match_char (')') == MATCH_YES)
1530 if (gfc_match_char (',') != MATCH_YES)
1538 gfc_error ("Syntax error in argument list at %C");
1541 gfc_free_actual_arglist (head);
1542 gfc_current_locus = old_loc;
1548 /* Used by match_varspec() to extend the reference list by one
1552 extend_ref (gfc_expr * primary, gfc_ref * tail)
1555 if (primary->ref == NULL)
1556 primary->ref = tail = gfc_get_ref ();
1560 gfc_internal_error ("extend_ref(): Bad tail");
1561 tail->next = gfc_get_ref ();
1569 /* Match any additional specifications associated with the current
1570 variable like member references or substrings. If equiv_flag is
1571 set we only match stuff that is allowed inside an EQUIVALENCE
1575 match_varspec (gfc_expr * primary, int equiv_flag)
1577 char name[GFC_MAX_SYMBOL_LEN + 1];
1578 gfc_ref *substring, *tail;
1579 gfc_component *component;
1580 gfc_symbol *sym = primary->symtree->n.sym;
1585 if ((equiv_flag && gfc_peek_char () == '(')
1586 || sym->attr.dimension)
1588 /* In EQUIVALENCE, we don't know yet whether we are seeing
1589 an array, character variable or array of character
1590 variables. We'll leave the decision till resolve
1592 tail = extend_ref (primary, tail);
1593 tail->type = REF_ARRAY;
1595 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1600 if (equiv_flag && gfc_peek_char () == '(')
1602 tail = extend_ref (primary, tail);
1603 tail->type = REF_ARRAY;
1605 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1611 primary->ts = sym->ts;
1616 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1617 goto check_substring;
1619 sym = sym->ts.derived;
1623 m = gfc_match_name (name);
1625 gfc_error ("Expected structure component name at %C");
1629 component = gfc_find_component (sym, name);
1630 if (component == NULL)
1633 tail = extend_ref (primary, tail);
1634 tail->type = REF_COMPONENT;
1636 tail->u.c.component = component;
1637 tail->u.c.sym = sym;
1639 primary->ts = component->ts;
1641 if (component->as != NULL)
1643 tail = extend_ref (primary, tail);
1644 tail->type = REF_ARRAY;
1646 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1651 if (component->ts.type != BT_DERIVED
1652 || gfc_match_char ('%') != MATCH_YES)
1655 sym = component->ts.derived;
1659 if (primary->ts.type == BT_UNKNOWN)
1661 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1663 gfc_set_default_type (sym, 0, sym->ns);
1664 primary->ts = sym->ts;
1668 if (primary->ts.type == BT_CHARACTER)
1670 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1674 primary->ref = substring;
1676 tail->next = substring;
1678 if (primary->expr_type == EXPR_CONSTANT)
1679 primary->expr_type = EXPR_SUBSTRING;
1682 primary->ts.cl = NULL;
1698 /* Given an expression that is a variable, figure out what the
1699 ultimate variable's type and attribute is, traversing the reference
1700 structures if necessary.
1702 This subroutine is trickier than it looks. We start at the base
1703 symbol and store the attribute. Component references load a
1704 completely new attribute.
1706 A couple of rules come into play. Subobjects of targets are always
1707 targets themselves. If we see a component that goes through a
1708 pointer, then the expression must also be a target, since the
1709 pointer is associated with something (if it isn't core will soon be
1710 dumped). If we see a full part or section of an array, the
1711 expression is also an array.
1713 We can have at most one full array reference. */
1716 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1718 int dimension, pointer, allocatable, target;
1719 symbol_attribute attr;
1722 if (expr->expr_type != EXPR_VARIABLE)
1723 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1726 attr = expr->symtree->n.sym->attr;
1728 dimension = attr.dimension;
1729 pointer = attr.pointer;
1730 allocatable = attr.allocatable;
1732 target = attr.target;
1736 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1737 *ts = expr->symtree->n.sym->ts;
1739 for (; ref; ref = ref->next)
1744 switch (ref->u.ar.type)
1751 allocatable = pointer = 0;
1756 allocatable = pointer = 0;
1760 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1766 gfc_get_component_attr (&attr, ref->u.c.component);
1768 *ts = ref->u.c.component->ts;
1770 pointer = ref->u.c.component->pointer;
1771 allocatable = ref->u.c.component->allocatable;
1778 allocatable = pointer = 0;
1782 attr.dimension = dimension;
1783 attr.pointer = pointer;
1784 attr.allocatable = allocatable;
1785 attr.target = target;
1791 /* Return the attribute from a general expression. */
1794 gfc_expr_attr (gfc_expr * e)
1796 symbol_attribute attr;
1798 switch (e->expr_type)
1801 attr = gfc_variable_attr (e, NULL);
1805 gfc_clear_attr (&attr);
1807 if (e->value.function.esym != NULL)
1808 attr = e->value.function.esym->result->attr;
1810 /* TODO: NULL() returns pointers. May have to take care of this
1816 gfc_clear_attr (&attr);
1824 /* Match a structure constructor. The initial symbol has already been
1828 gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1830 gfc_constructor *head, *tail;
1831 gfc_component *comp;
1838 if (gfc_match_char ('(') != MATCH_YES)
1841 where = gfc_current_locus;
1843 gfc_find_component (sym, NULL);
1845 for (comp = sym->components; comp; comp = comp->next)
1848 tail = head = gfc_get_constructor ();
1851 tail->next = gfc_get_constructor ();
1855 m = gfc_match_expr (&tail->expr);
1858 if (m == MATCH_ERROR)
1861 if (gfc_match_char (',') == MATCH_YES)
1863 if (comp->next == NULL)
1866 ("Too many components in structure constructor at %C");
1876 if (gfc_match_char (')') != MATCH_YES)
1879 if (comp->next != NULL)
1881 gfc_error ("Too few components in structure constructor at %C");
1885 e = gfc_get_expr ();
1887 e->expr_type = EXPR_STRUCTURE;
1889 e->ts.type = BT_DERIVED;
1890 e->ts.derived = sym;
1893 e->value.constructor = head;
1899 gfc_error ("Syntax error in structure constructor at %C");
1902 gfc_free_constructor (head);
1907 /* Matches a variable name followed by anything that might follow it--
1908 array reference, argument list of a function, etc. */
1911 gfc_match_rvalue (gfc_expr ** result)
1913 gfc_actual_arglist *actual_arglist;
1914 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1917 gfc_symtree *symtree;
1918 locus where, old_loc;
1925 m = gfc_match_name (name);
1929 if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
1930 i = gfc_get_sym_tree (name, NULL, &symtree);
1932 i = gfc_get_ha_sym_tree (name, &symtree);
1937 sym = symtree->n.sym;
1939 where = gfc_current_locus;
1941 gfc_set_sym_referenced (sym);
1943 if (sym->attr.function && sym->result == sym)
1945 /* See if this is a directly recursive function call. */
1946 gfc_gobble_whitespace ();
1947 if (sym->attr.recursive
1948 && gfc_peek_char () == '('
1949 && gfc_current_ns->proc_name == sym)
1951 if (!sym->attr.dimension)
1954 gfc_error ("'%s' is array valued and directly recursive "
1955 "at %C , so the keyword RESULT must be specified "
1956 "in the FUNCTION statement", sym->name);
1960 if (gfc_current_ns->proc_name == sym
1961 || (gfc_current_ns->parent != NULL
1962 && gfc_current_ns->parent->proc_name == sym))
1966 && (sym->ns == gfc_current_ns
1967 || sym->ns == gfc_current_ns->parent))
1969 gfc_entry_list *el = NULL;
1971 for (el = sym->ns->entries; el; el = el->next)
1977 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1980 if (sym->attr.generic)
1981 goto generic_function;
1983 switch (sym->attr.flavor)
1987 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1988 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1989 gfc_set_default_type (sym, 0, sym->ns);
1991 e = gfc_get_expr ();
1993 e->expr_type = EXPR_VARIABLE;
1994 e->symtree = symtree;
1996 m = match_varspec (e, 0);
2000 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2001 end up here. Unfortunately, sym->value->expr_type is set to
2002 EXPR_CONSTANT, and so the if () branch would be followed without
2003 the !sym->as check. */
2004 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2005 e = gfc_copy_expr (sym->value);
2008 e = gfc_get_expr ();
2009 e->expr_type = EXPR_VARIABLE;
2012 e->symtree = symtree;
2013 m = match_varspec (e, 0);
2017 sym = gfc_use_derived (sym);
2021 m = gfc_match_structure_constructor (sym, &e);
2024 /* If we're here, then the name is known to be the name of a
2025 procedure, yet it is not sure to be the name of a function. */
2027 if (sym->attr.subroutine)
2029 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2035 /* At this point, the name has to be a non-statement function.
2036 If the name is the same as the current function being
2037 compiled, then we have a variable reference (to the function
2038 result) if the name is non-recursive. */
2040 st = gfc_enclosing_unit (NULL);
2042 if (st != NULL && st->state == COMP_FUNCTION
2044 && !sym->attr.recursive)
2046 e = gfc_get_expr ();
2047 e->symtree = symtree;
2048 e->expr_type = EXPR_VARIABLE;
2050 m = match_varspec (e, 0);
2054 /* Match a function reference. */
2056 m = gfc_match_actual_arglist (0, &actual_arglist);
2059 if (sym->attr.proc == PROC_ST_FUNCTION)
2060 gfc_error ("Statement function '%s' requires argument list at %C",
2063 gfc_error ("Function '%s' requires an argument list at %C",
2076 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2077 sym = symtree->n.sym;
2079 e = gfc_get_expr ();
2080 e->symtree = symtree;
2081 e->expr_type = EXPR_FUNCTION;
2082 e->value.function.actual = actual_arglist;
2083 e->where = gfc_current_locus;
2085 if (sym->as != NULL)
2086 e->rank = sym->as->rank;
2088 if (!sym->attr.function
2089 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2095 if (sym->result == NULL)
2103 /* Special case for derived type variables that get their types
2104 via an IMPLICIT statement. This can't wait for the
2105 resolution phase. */
2107 if (gfc_peek_char () == '%'
2108 && sym->ts.type == BT_UNKNOWN
2109 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2110 gfc_set_default_type (sym, 0, sym->ns);
2112 /* If the symbol has a dimension attribute, the expression is a
2115 if (sym->attr.dimension)
2117 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2118 sym->name, NULL) == FAILURE)
2124 e = gfc_get_expr ();
2125 e->symtree = symtree;
2126 e->expr_type = EXPR_VARIABLE;
2127 m = match_varspec (e, 0);
2131 /* Name is not an array, so we peek to see if a '(' implies a
2132 function call or a substring reference. Otherwise the
2133 variable is just a scalar. */
2135 gfc_gobble_whitespace ();
2136 if (gfc_peek_char () != '(')
2138 /* Assume a scalar variable */
2139 e = gfc_get_expr ();
2140 e->symtree = symtree;
2141 e->expr_type = EXPR_VARIABLE;
2143 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2144 sym->name, NULL) == FAILURE)
2151 m = match_varspec (e, 0);
2155 /* See if this is a function reference with a keyword argument
2156 as first argument. We do this because otherwise a spurious
2157 symbol would end up in the symbol table. */
2159 old_loc = gfc_current_locus;
2160 m2 = gfc_match (" ( %n =", argname);
2161 gfc_current_locus = old_loc;
2163 e = gfc_get_expr ();
2164 e->symtree = symtree;
2166 if (m2 != MATCH_YES)
2168 /* Try to figure out whether we're dealing with a character type.
2169 We're peeking ahead here, because we don't want to call
2170 match_substring if we're dealing with an implicitly typed
2171 non-character variable. */
2172 implicit_char = false;
2173 if (sym->ts.type == BT_UNKNOWN)
2175 ts = gfc_get_default_type (sym,NULL);
2176 if (ts->type == BT_CHARACTER)
2177 implicit_char = true;
2180 /* See if this could possibly be a substring reference of a name
2181 that we're not sure is a variable yet. */
2183 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2184 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2187 e->expr_type = EXPR_VARIABLE;
2189 if (sym->attr.flavor != FL_VARIABLE
2190 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2191 sym->name, NULL) == FAILURE)
2197 if (sym->ts.type == BT_UNKNOWN
2198 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2212 /* Give up, assume we have a function. */
2214 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2215 sym = symtree->n.sym;
2216 e->expr_type = EXPR_FUNCTION;
2218 if (!sym->attr.function
2219 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2227 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2229 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2237 /* If our new function returns a character, array or structure
2238 type, it might have subsequent references. */
2240 m = match_varspec (e, 0);
2247 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2249 e = gfc_get_expr ();
2250 e->symtree = symtree;
2251 e->expr_type = EXPR_FUNCTION;
2253 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2257 gfc_error ("Symbol at %C is not appropriate for an expression");
2273 /* Match a variable, ie something that can be assigned to. This
2274 starts as a symbol, can be a structure component or an array
2275 reference. It can be a function if the function doesn't have a
2276 separate RESULT variable. If the symbol has not been previously
2277 seen, we assume it is a variable.
2279 This function is called by two interface functions:
2280 gfc_match_variable, which has host_flag = 1, and
2281 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2282 match of the symbol to the local scope. */
2285 match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
2293 /* Since nothing has any business being an lvalue in a module
2294 specification block, an interface block or a contains section,
2295 we force the changed_symbols mechanism to work by setting
2296 host_flag to 0. This prevents valid symbols that have the name
2297 of keywords, such as 'end', being turned into variables by
2298 failed matching to assignments for, eg., END INTERFACE. */
2299 if (gfc_current_state () == COMP_MODULE
2300 || gfc_current_state () == COMP_INTERFACE
2301 || gfc_current_state () == COMP_CONTAINS)
2304 m = gfc_match_sym_tree (&st, host_flag);
2307 where = gfc_current_locus;
2310 gfc_set_sym_referenced (sym);
2311 switch (sym->attr.flavor)
2317 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2318 sym->name, NULL) == FAILURE)
2324 gfc_error ("Named constant at %C in an EQUIVALENCE");
2326 gfc_error ("Cannot assign to a named constant at %C");
2331 /* Check for a nonrecursive function result */
2332 if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2334 /* If a function result is a derived type, then the derived
2335 type may still have to be resolved. */
2337 if (sym->ts.type == BT_DERIVED
2338 && gfc_use_derived (sym->ts.derived) == NULL)
2343 /* Fall through to error */
2346 gfc_error ("Expected VARIABLE at %C");
2350 /* Special case for derived type variables that get their types
2351 via an IMPLICIT statement. This can't wait for the
2352 resolution phase. */
2355 gfc_namespace * implicit_ns;
2357 if (gfc_current_ns->proc_name == sym)
2358 implicit_ns = gfc_current_ns;
2360 implicit_ns = sym->ns;
2362 if (gfc_peek_char () == '%'
2363 && sym->ts.type == BT_UNKNOWN
2364 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2365 gfc_set_default_type (sym, 0, implicit_ns);
2368 expr = gfc_get_expr ();
2370 expr->expr_type = EXPR_VARIABLE;
2373 expr->where = where;
2375 /* Now see if we have to do more. */
2376 m = match_varspec (expr, equiv_flag);
2379 gfc_free_expr (expr);
2388 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2390 return match_variable (result, equiv_flag, 1);
2394 gfc_match_equiv_variable (gfc_expr ** result)
2396 return match_variable (result, 1, 0);