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.string[num] = '\0';
285 e->value.character.length = num;
292 gfc_current_locus = old_loc;
301 /* Match a binary, octal or hexadecimal constant that can be found in
302 a DATA statement. The standard permits b'010...', o'73...', and
303 z'a1...' where b, o, and z can be capital letters. This function
304 also accepts postfixed forms of the constants: '01...'b, '73...'o,
305 and 'a1...'z. An additional extension is the use of x for z. */
308 match_boz_constant (gfc_expr ** result)
310 int post, radix, delim, length, x_hex, kind;
311 locus old_loc, start_loc;
315 start_loc = old_loc = gfc_current_locus;
316 gfc_gobble_whitespace ();
319 switch (post = gfc_next_char ())
341 radix = 16; /* Set to accept any valid digit string. */
347 /* No whitespace allowed here. */
350 delim = gfc_next_char ();
352 if (delim != '\'' && delim != '\"')
355 if (x_hex && pedantic
356 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
357 "constant at %C uses non-standard syntax.")
361 old_loc = gfc_current_locus;
363 length = match_digits (0, radix, NULL);
366 gfc_error ("Empty set of digits in BOZ constant at %C");
370 if (gfc_next_char () != delim)
372 gfc_error ("Illegal character in BOZ constant at %C");
378 switch (gfc_next_char ())
394 gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
395 "at %C uses non-standard postfix syntax.");
398 gfc_current_locus = old_loc;
400 buffer = alloca (length + 1);
401 memset (buffer, '\0', length + 1);
403 match_digits (0, radix, buffer);
404 gfc_next_char (); /* Eat delimiter. */
406 gfc_next_char (); /* Eat postfixed b, o, z, or x. */
408 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
409 "If a data-stmt-constant is a boz-literal-constant, the corresponding
410 variable shall be of type integer. The boz-literal-constant is treated
411 as if it were an int-literal-constant with a kind-param that specifies
412 the representation method with the largest decimal exponent range
413 supported by the processor." */
415 kind = gfc_max_integer_kind;
416 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
418 if (gfc_range_check (e) != ARITH_OK)
420 gfc_error ("Integer too big for integer kind %i at %C", kind);
429 gfc_current_locus = start_loc;
434 /* Match a real constant of some sort. Allow a signed constant if signflag
435 is nonzero. Allow integer constants if allow_int is true. */
438 match_real_constant (gfc_expr ** result, int signflag)
440 int kind, c, count, seen_dp, seen_digits, exp_char;
441 locus old_loc, temp_loc;
446 old_loc = gfc_current_locus;
447 gfc_gobble_whitespace ();
457 c = gfc_next_char ();
458 if (signflag && (c == '+' || c == '-'))
463 gfc_gobble_whitespace ();
464 c = gfc_next_char ();
467 /* Scan significand. */
468 for (;; c = gfc_next_char (), count++)
475 /* Check to see if "." goes with a following operator like ".eq.". */
476 temp_loc = gfc_current_locus;
477 c = gfc_next_char ();
479 if (c == 'e' || c == 'd' || c == 'q')
481 c = gfc_next_char ();
483 goto done; /* Operator named .e. or .d. */
487 goto done; /* Distinguish 1.e9 from 1.eq.2 */
489 gfc_current_locus = temp_loc;
504 || (c != 'e' && c != 'd' && c != 'q'))
509 c = gfc_next_char ();
512 if (c == '+' || c == '-')
513 { /* optional sign */
514 c = gfc_next_char ();
520 gfc_error ("Missing exponent in real number at %C");
526 c = gfc_next_char ();
531 /* Check that we have a numeric constant. */
532 if (!seen_digits || (!seen_dp && exp_char == ' '))
534 gfc_current_locus = old_loc;
538 /* Convert the number. */
539 gfc_current_locus = old_loc;
540 gfc_gobble_whitespace ();
542 buffer = alloca (count + 1);
543 memset (buffer, '\0', count + 1);
546 c = gfc_next_char ();
547 if (c == '+' || c == '-')
549 gfc_gobble_whitespace ();
550 c = gfc_next_char ();
553 /* Hack for mpfr_set_str(). */
556 if (c == 'd' || c == 'q')
564 c = gfc_next_char ();
577 ("Real number at %C has a 'd' exponent and an explicit kind");
580 kind = gfc_default_double_kind;
585 kind = gfc_default_real_kind;
587 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
589 gfc_error ("Invalid real kind %d at %C", kind);
594 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
596 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
598 switch (gfc_range_check (e))
603 gfc_error ("Real constant overflows its kind at %C");
606 case ARITH_UNDERFLOW:
607 if (gfc_option.warn_underflow)
608 gfc_warning ("Real constant underflows its kind at %C");
609 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
613 gfc_internal_error ("gfc_range_check() returned bad value");
625 /* Match a substring reference. */
628 match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
630 gfc_expr *start, *end;
638 old_loc = gfc_current_locus;
640 m = gfc_match_char ('(');
644 if (gfc_match_char (':') != MATCH_YES)
647 m = gfc_match_init_expr (&start);
649 m = gfc_match_expr (&start);
657 m = gfc_match_char (':');
662 if (gfc_match_char (')') != MATCH_YES)
665 m = gfc_match_init_expr (&end);
667 m = gfc_match_expr (&end);
671 if (m == MATCH_ERROR)
674 m = gfc_match_char (')');
679 /* Optimize away the (:) reference. */
680 if (start == NULL && end == NULL)
684 ref = gfc_get_ref ();
686 ref->type = REF_SUBSTRING;
688 start = gfc_int_expr (1);
689 ref->u.ss.start = start;
690 if (end == NULL && cl)
691 end = gfc_copy_expr (cl->length);
693 ref->u.ss.length = cl;
700 gfc_error ("Syntax error in SUBSTRING specification at %C");
704 gfc_free_expr (start);
707 gfc_current_locus = old_loc;
712 /* Reads the next character of a string constant, taking care to
713 return doubled delimiters on the input as a single instance of
716 Special return values are:
717 -1 End of the string, as determined by the delimiter
718 -2 Unterminated string detected
720 Backslash codes are also expanded at this time. */
723 next_string_char (char delimiter)
728 c = gfc_next_char_literal (1);
733 if (gfc_option.flag_backslash && c == '\\')
735 old_locus = gfc_current_locus;
737 switch (gfc_next_char_literal (1))
765 /* Unknown backslash codes are simply not expanded */
766 gfc_current_locus = old_locus;
774 old_locus = gfc_current_locus;
775 c = gfc_next_char_literal (1);
779 gfc_current_locus = old_locus;
785 /* Special case of gfc_match_name() that matches a parameter kind name
786 before a string constant. This takes case of the weird but legal
791 where kind____ is a parameter. gfc_match_name() will happily slurp
792 up all the underscores, which leads to problems. If we return
793 MATCH_YES, the parse pointer points to the final underscore, which
794 is not part of the name. We never return MATCH_ERROR-- errors in
795 the name will be detected later. */
798 match_charkind_name (char *name)
804 gfc_gobble_whitespace ();
805 c = gfc_next_char ();
814 old_loc = gfc_current_locus;
815 c = gfc_next_char ();
819 peek = gfc_peek_char ();
821 if (peek == '\'' || peek == '\"')
823 gfc_current_locus = old_loc;
831 && (gfc_option.flag_dollar_ok && c != '$'))
835 if (++len > GFC_MAX_SYMBOL_LEN)
843 /* See if the current input matches a character constant. Lots of
844 contortions have to be done to match the kind parameter which comes
845 before the actual string. The main consideration is that we don't
846 want to error out too quickly. For example, we don't actually do
847 any validation of the kinds until we have actually seen a legal
848 delimiter. Using match_kind_param() generates errors too quickly. */
851 match_string_constant (gfc_expr ** result)
853 char *p, name[GFC_MAX_SYMBOL_LEN + 1];
854 int i, c, kind, length, delimiter;
855 locus old_locus, start_locus;
861 old_locus = gfc_current_locus;
863 gfc_gobble_whitespace ();
865 start_locus = gfc_current_locus;
867 c = gfc_next_char ();
868 if (c == '\'' || c == '"')
870 kind = gfc_default_character_kind;
880 kind = kind * 10 + c - '0';
883 c = gfc_next_char ();
889 gfc_current_locus = old_locus;
891 m = match_charkind_name (name);
895 if (gfc_find_symbol (name, NULL, 1, &sym)
897 || sym->attr.flavor != FL_PARAMETER)
901 c = gfc_next_char ();
906 gfc_gobble_whitespace ();
907 c = gfc_next_char ();
913 gfc_gobble_whitespace ();
914 start_locus = gfc_current_locus;
916 c = gfc_next_char ();
917 if (c != '\'' && c != '"')
922 q = gfc_extract_int (sym->value, &kind);
930 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
932 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
937 /* Scan the string into a block of memory by first figuring out how
938 long it is, allocating the structure, then re-reading it. This
939 isn't particularly efficient, but string constants aren't that
940 common in most code. TODO: Use obstacks? */
947 c = next_string_char (delimiter);
952 gfc_current_locus = start_locus;
953 gfc_error ("Unterminated character constant beginning at %C");
960 /* Peek at the next character to see if it is a b, o, z, or x for the
961 postfixed BOZ literal constants. */
962 c = gfc_peek_char ();
963 if (c == 'b' || c == 'o' || c =='z' || c == 'x')
969 e->expr_type = EXPR_CONSTANT;
971 e->ts.type = BT_CHARACTER;
973 e->where = start_locus;
975 e->value.character.string = p = gfc_getmem (length + 1);
976 e->value.character.length = length;
978 gfc_current_locus = start_locus;
979 gfc_next_char (); /* Skip delimiter */
981 for (i = 0; i < length; i++)
982 *p++ = next_string_char (delimiter);
984 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
986 if (next_string_char (delimiter) != -1)
987 gfc_internal_error ("match_string_constant(): Delimiter not found");
989 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
990 e->expr_type = EXPR_SUBSTRING;
997 gfc_current_locus = old_locus;
1002 /* Match a .true. or .false. */
1005 match_logical_constant (gfc_expr ** result)
1007 static mstring logical_ops[] = {
1008 minit (".false.", 0),
1009 minit (".true.", 1),
1016 i = gfc_match_strings (logical_ops);
1024 kind = gfc_default_logical_kind;
1026 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1027 gfc_error ("Bad kind for logical constant at %C");
1029 e = gfc_get_expr ();
1031 e->expr_type = EXPR_CONSTANT;
1032 e->value.logical = i;
1033 e->ts.type = BT_LOGICAL;
1035 e->where = gfc_current_locus;
1042 /* Match a real or imaginary part of a complex constant that is a
1043 symbolic constant. */
1046 match_sym_complex_part (gfc_expr ** result)
1048 char name[GFC_MAX_SYMBOL_LEN + 1];
1053 m = gfc_match_name (name);
1057 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1060 if (sym->attr.flavor != FL_PARAMETER)
1062 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1066 if (!gfc_numeric_ts (&sym->value->ts))
1068 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1072 if (sym->value->rank != 0)
1074 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1078 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1079 "complex constant at %C") == FAILURE)
1082 switch (sym->value->ts.type)
1085 e = gfc_copy_expr (sym->value);
1089 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1095 e = gfc_int2real (sym->value, gfc_default_real_kind);
1101 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1104 *result = e; /* e is a scalar, real, constant expression */
1108 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1113 /* Match a real or imaginary part of a complex number. */
1116 match_complex_part (gfc_expr ** result)
1120 m = match_sym_complex_part (result);
1124 m = match_real_constant (result, 1);
1128 return match_integer_constant (result, 1);
1132 /* Try to match a complex constant. */
1135 match_complex_constant (gfc_expr ** result)
1137 gfc_expr *e, *real, *imag;
1138 gfc_error_buf old_error;
1139 gfc_typespec target;
1144 old_loc = gfc_current_locus;
1145 real = imag = e = NULL;
1147 m = gfc_match_char ('(');
1151 gfc_push_error (&old_error);
1153 m = match_complex_part (&real);
1156 gfc_free_error (&old_error);
1160 if (gfc_match_char (',') == MATCH_NO)
1162 gfc_pop_error (&old_error);
1167 /* If m is error, then something was wrong with the real part and we
1168 assume we have a complex constant because we've seen the ','. An
1169 ambiguous case here is the start of an iterator list of some
1170 sort. These sort of lists are matched prior to coming here. */
1172 if (m == MATCH_ERROR)
1174 gfc_free_error (&old_error);
1177 gfc_pop_error (&old_error);
1179 m = match_complex_part (&imag);
1182 if (m == MATCH_ERROR)
1185 m = gfc_match_char (')');
1188 /* Give the matcher for implied do-loops a chance to run. This
1189 yields a much saner error message for (/ (i, 4=i, 6) /). */
1190 if (gfc_peek_char () == '=')
1199 if (m == MATCH_ERROR)
1202 /* Decide on the kind of this complex number. */
1203 if (real->ts.type == BT_REAL)
1205 if (imag->ts.type == BT_REAL)
1206 kind = gfc_kind_max (real, imag);
1208 kind = real->ts.kind;
1212 if (imag->ts.type == BT_REAL)
1213 kind = imag->ts.kind;
1215 kind = gfc_default_real_kind;
1217 target.type = BT_REAL;
1220 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1221 gfc_convert_type (real, &target, 2);
1222 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1223 gfc_convert_type (imag, &target, 2);
1225 e = gfc_convert_complex (real, imag, kind);
1226 e->where = gfc_current_locus;
1228 gfc_free_expr (real);
1229 gfc_free_expr (imag);
1235 gfc_error ("Syntax error in COMPLEX constant at %C");
1240 gfc_free_expr (real);
1241 gfc_free_expr (imag);
1242 gfc_current_locus = old_loc;
1248 /* Match constants in any of several forms. Returns nonzero for a
1249 match, zero for no match. */
1252 gfc_match_literal_constant (gfc_expr ** result, int signflag)
1256 m = match_complex_constant (result);
1260 m = match_string_constant (result);
1264 m = match_boz_constant (result);
1268 m = match_real_constant (result, signflag);
1272 m = match_hollerith_constant (result);
1276 m = match_integer_constant (result, signflag);
1280 m = match_logical_constant (result);
1288 /* Match a single actual argument value. An actual argument is
1289 usually an expression, but can also be a procedure name. If the
1290 argument is a single name, it is not always possible to tell
1291 whether the name is a dummy procedure or not. We treat these cases
1292 by creating an argument that looks like a dummy procedure and
1293 fixing things later during resolution. */
1296 match_actual_arg (gfc_expr ** result)
1298 char name[GFC_MAX_SYMBOL_LEN + 1];
1299 gfc_symtree *symtree;
1304 where = gfc_current_locus;
1306 switch (gfc_match_name (name))
1315 w = gfc_current_locus;
1316 gfc_gobble_whitespace ();
1317 c = gfc_next_char ();
1318 gfc_current_locus = w;
1320 if (c != ',' && c != ')')
1323 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1325 /* Handle error elsewhere. */
1327 /* Eliminate a couple of common cases where we know we don't
1328 have a function argument. */
1329 if (symtree == NULL)
1331 gfc_get_sym_tree (name, NULL, &symtree);
1332 gfc_set_sym_referenced (symtree->n.sym);
1338 sym = symtree->n.sym;
1339 gfc_set_sym_referenced (sym);
1340 if (sym->attr.flavor != FL_PROCEDURE
1341 && sym->attr.flavor != FL_UNKNOWN)
1344 /* If the symbol is a function with itself as the result and
1345 is being defined, then we have a variable. */
1346 if (sym->attr.function && sym->result == sym)
1348 if (gfc_current_ns->proc_name == sym
1349 || (gfc_current_ns->parent != NULL
1350 && gfc_current_ns->parent->proc_name == sym))
1354 && (sym->ns == gfc_current_ns
1355 || sym->ns == gfc_current_ns->parent))
1357 gfc_entry_list *el = NULL;
1359 for (el = sym->ns->entries; el; el = el->next)
1369 e = gfc_get_expr (); /* Leave it unknown for now */
1370 e->symtree = symtree;
1371 e->expr_type = EXPR_VARIABLE;
1372 e->ts.type = BT_PROCEDURE;
1379 gfc_current_locus = where;
1380 return gfc_match_expr (result);
1384 /* Match a keyword argument. */
1387 match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
1389 char name[GFC_MAX_SYMBOL_LEN + 1];
1390 gfc_actual_arglist *a;
1394 name_locus = gfc_current_locus;
1395 m = gfc_match_name (name);
1399 if (gfc_match_char ('=') != MATCH_YES)
1405 m = match_actual_arg (&actual->expr);
1409 /* Make sure this name has not appeared yet. */
1411 if (name[0] != '\0')
1413 for (a = base; a; a = a->next)
1414 if (a->name != NULL && strcmp (a->name, name) == 0)
1417 ("Keyword '%s' at %C has already appeared in the current "
1418 "argument list", name);
1423 actual->name = gfc_get_string (name);
1427 gfc_current_locus = name_locus;
1432 /* Match an argument list function, such as %VAL. */
1435 match_arg_list_function (gfc_actual_arglist *result)
1437 char name[GFC_MAX_SYMBOL_LEN + 1];
1441 old_locus = gfc_current_locus;
1443 if (gfc_match_char ('%') != MATCH_YES)
1449 m = gfc_match ("%n (", name);
1453 if (name[0] != '\0')
1458 if (strncmp(name, "loc", 3) == 0)
1460 result->name = "%LOC";
1464 if (strncmp(name, "ref", 3) == 0)
1466 result->name = "%REF";
1470 if (strncmp(name, "val", 3) == 0)
1472 result->name = "%VAL";
1481 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1482 "function at %C") == FAILURE)
1488 m = match_actual_arg (&result->expr);
1492 if (gfc_match_char (')') != MATCH_YES)
1501 gfc_current_locus = old_locus;
1506 /* Matches an actual argument list of a function or subroutine, from
1507 the opening parenthesis to the closing parenthesis. The argument
1508 list is assumed to allow keyword arguments because we don't know if
1509 the symbol associated with the procedure has an implicit interface
1510 or not. We make sure keywords are unique. If SUB_FLAG is set,
1511 we're matching the argument list of a subroutine. */
1514 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
1516 gfc_actual_arglist *head, *tail;
1518 gfc_st_label *label;
1522 *argp = tail = NULL;
1523 old_loc = gfc_current_locus;
1527 if (gfc_match_char ('(') == MATCH_NO)
1528 return (sub_flag) ? MATCH_YES : MATCH_NO;
1530 if (gfc_match_char (')') == MATCH_YES)
1537 head = tail = gfc_get_actual_arglist ();
1540 tail->next = gfc_get_actual_arglist ();
1544 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1546 m = gfc_match_st_label (&label);
1548 gfc_error ("Expected alternate return label at %C");
1552 tail->label = label;
1556 /* After the first keyword argument is seen, the following
1557 arguments must also have keywords. */
1560 m = match_keyword_arg (tail, head);
1562 if (m == MATCH_ERROR)
1567 ("Missing keyword name in actual argument list at %C");
1574 /* Try an argument list function, like %VAL. */
1575 m = match_arg_list_function (tail);
1576 if (m == MATCH_ERROR)
1579 /* See if we have the first keyword argument. */
1582 m = match_keyword_arg (tail, head);
1585 if (m == MATCH_ERROR)
1591 /* Try for a non-keyword argument. */
1592 m = match_actual_arg (&tail->expr);
1593 if (m == MATCH_ERROR)
1602 if (gfc_match_char (')') == MATCH_YES)
1604 if (gfc_match_char (',') != MATCH_YES)
1612 gfc_error ("Syntax error in argument list at %C");
1615 gfc_free_actual_arglist (head);
1616 gfc_current_locus = old_loc;
1622 /* Used by match_varspec() to extend the reference list by one
1626 extend_ref (gfc_expr * primary, gfc_ref * tail)
1629 if (primary->ref == NULL)
1630 primary->ref = tail = gfc_get_ref ();
1634 gfc_internal_error ("extend_ref(): Bad tail");
1635 tail->next = gfc_get_ref ();
1643 /* Match any additional specifications associated with the current
1644 variable like member references or substrings. If equiv_flag is
1645 set we only match stuff that is allowed inside an EQUIVALENCE
1649 match_varspec (gfc_expr * primary, int equiv_flag)
1651 char name[GFC_MAX_SYMBOL_LEN + 1];
1652 gfc_ref *substring, *tail;
1653 gfc_component *component;
1654 gfc_symbol *sym = primary->symtree->n.sym;
1659 if ((equiv_flag && gfc_peek_char () == '(')
1660 || sym->attr.dimension)
1662 /* In EQUIVALENCE, we don't know yet whether we are seeing
1663 an array, character variable or array of character
1664 variables. We'll leave the decision till resolve
1666 tail = extend_ref (primary, tail);
1667 tail->type = REF_ARRAY;
1669 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1674 if (equiv_flag && gfc_peek_char () == '(')
1676 tail = extend_ref (primary, tail);
1677 tail->type = REF_ARRAY;
1679 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1685 primary->ts = sym->ts;
1690 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1691 goto check_substring;
1693 sym = sym->ts.derived;
1697 m = gfc_match_name (name);
1699 gfc_error ("Expected structure component name at %C");
1703 component = gfc_find_component (sym, name);
1704 if (component == NULL)
1707 tail = extend_ref (primary, tail);
1708 tail->type = REF_COMPONENT;
1710 tail->u.c.component = component;
1711 tail->u.c.sym = sym;
1713 primary->ts = component->ts;
1715 if (component->as != NULL)
1717 tail = extend_ref (primary, tail);
1718 tail->type = REF_ARRAY;
1720 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1725 if (component->ts.type != BT_DERIVED
1726 || gfc_match_char ('%') != MATCH_YES)
1729 sym = component->ts.derived;
1733 if (primary->ts.type == BT_UNKNOWN)
1735 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1737 gfc_set_default_type (sym, 0, sym->ns);
1738 primary->ts = sym->ts;
1742 if (primary->ts.type == BT_CHARACTER)
1744 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1748 primary->ref = substring;
1750 tail->next = substring;
1752 if (primary->expr_type == EXPR_CONSTANT)
1753 primary->expr_type = EXPR_SUBSTRING;
1756 primary->ts.cl = NULL;
1772 /* Given an expression that is a variable, figure out what the
1773 ultimate variable's type and attribute is, traversing the reference
1774 structures if necessary.
1776 This subroutine is trickier than it looks. We start at the base
1777 symbol and store the attribute. Component references load a
1778 completely new attribute.
1780 A couple of rules come into play. Subobjects of targets are always
1781 targets themselves. If we see a component that goes through a
1782 pointer, then the expression must also be a target, since the
1783 pointer is associated with something (if it isn't core will soon be
1784 dumped). If we see a full part or section of an array, the
1785 expression is also an array.
1787 We can have at most one full array reference. */
1790 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1792 int dimension, pointer, allocatable, target;
1793 symbol_attribute attr;
1796 if (expr->expr_type != EXPR_VARIABLE)
1797 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1800 attr = expr->symtree->n.sym->attr;
1802 dimension = attr.dimension;
1803 pointer = attr.pointer;
1804 allocatable = attr.allocatable;
1806 target = attr.target;
1810 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1811 *ts = expr->symtree->n.sym->ts;
1813 for (; ref; ref = ref->next)
1818 switch (ref->u.ar.type)
1825 allocatable = pointer = 0;
1830 allocatable = pointer = 0;
1834 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1840 gfc_get_component_attr (&attr, ref->u.c.component);
1842 *ts = ref->u.c.component->ts;
1844 pointer = ref->u.c.component->pointer;
1845 allocatable = ref->u.c.component->allocatable;
1852 allocatable = pointer = 0;
1856 attr.dimension = dimension;
1857 attr.pointer = pointer;
1858 attr.allocatable = allocatable;
1859 attr.target = target;
1865 /* Return the attribute from a general expression. */
1868 gfc_expr_attr (gfc_expr * e)
1870 symbol_attribute attr;
1872 switch (e->expr_type)
1875 attr = gfc_variable_attr (e, NULL);
1879 gfc_clear_attr (&attr);
1881 if (e->value.function.esym != NULL)
1882 attr = e->value.function.esym->result->attr;
1884 /* TODO: NULL() returns pointers. May have to take care of this
1890 gfc_clear_attr (&attr);
1898 /* Match a structure constructor. The initial symbol has already been
1902 gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1904 gfc_constructor *head, *tail;
1905 gfc_component *comp;
1912 if (gfc_match_char ('(') != MATCH_YES)
1915 where = gfc_current_locus;
1917 gfc_find_component (sym, NULL);
1919 for (comp = sym->components; comp; comp = comp->next)
1922 tail = head = gfc_get_constructor ();
1925 tail->next = gfc_get_constructor ();
1929 m = gfc_match_expr (&tail->expr);
1932 if (m == MATCH_ERROR)
1935 if (gfc_match_char (',') == MATCH_YES)
1937 if (comp->next == NULL)
1940 ("Too many components in structure constructor at %C");
1950 if (gfc_match_char (')') != MATCH_YES)
1953 if (comp->next != NULL)
1955 gfc_error ("Too few components in structure constructor at %C");
1959 e = gfc_get_expr ();
1961 e->expr_type = EXPR_STRUCTURE;
1963 e->ts.type = BT_DERIVED;
1964 e->ts.derived = sym;
1967 e->value.constructor = head;
1973 gfc_error ("Syntax error in structure constructor at %C");
1976 gfc_free_constructor (head);
1981 /* Matches a variable name followed by anything that might follow it--
1982 array reference, argument list of a function, etc. */
1985 gfc_match_rvalue (gfc_expr ** result)
1987 gfc_actual_arglist *actual_arglist;
1988 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1991 gfc_symtree *symtree;
1992 locus where, old_loc;
1999 m = gfc_match_name (name);
2003 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2004 && !gfc_current_ns->has_import_set)
2005 i = gfc_get_sym_tree (name, NULL, &symtree);
2007 i = gfc_get_ha_sym_tree (name, &symtree);
2012 sym = symtree->n.sym;
2014 where = gfc_current_locus;
2016 gfc_set_sym_referenced (sym);
2018 if (sym->attr.function && sym->result == sym)
2020 /* See if this is a directly recursive function call. */
2021 gfc_gobble_whitespace ();
2022 if (sym->attr.recursive
2023 && gfc_peek_char () == '('
2024 && gfc_current_ns->proc_name == sym)
2026 if (!sym->attr.dimension)
2029 gfc_error ("'%s' is array valued and directly recursive "
2030 "at %C , so the keyword RESULT must be specified "
2031 "in the FUNCTION statement", sym->name);
2035 if (gfc_current_ns->proc_name == sym
2036 || (gfc_current_ns->parent != NULL
2037 && gfc_current_ns->parent->proc_name == sym))
2041 && (sym->ns == gfc_current_ns
2042 || sym->ns == gfc_current_ns->parent))
2044 gfc_entry_list *el = NULL;
2046 for (el = sym->ns->entries; el; el = el->next)
2052 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2055 if (sym->attr.generic)
2056 goto generic_function;
2058 switch (sym->attr.flavor)
2062 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
2063 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2064 gfc_set_default_type (sym, 0, sym->ns);
2066 e = gfc_get_expr ();
2068 e->expr_type = EXPR_VARIABLE;
2069 e->symtree = symtree;
2071 m = match_varspec (e, 0);
2075 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2076 end up here. Unfortunately, sym->value->expr_type is set to
2077 EXPR_CONSTANT, and so the if () branch would be followed without
2078 the !sym->as check. */
2079 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2080 e = gfc_copy_expr (sym->value);
2083 e = gfc_get_expr ();
2084 e->expr_type = EXPR_VARIABLE;
2087 e->symtree = symtree;
2088 m = match_varspec (e, 0);
2092 sym = gfc_use_derived (sym);
2096 m = gfc_match_structure_constructor (sym, &e);
2099 /* If we're here, then the name is known to be the name of a
2100 procedure, yet it is not sure to be the name of a function. */
2102 if (sym->attr.subroutine)
2104 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2110 /* At this point, the name has to be a non-statement function.
2111 If the name is the same as the current function being
2112 compiled, then we have a variable reference (to the function
2113 result) if the name is non-recursive. */
2115 st = gfc_enclosing_unit (NULL);
2117 if (st != NULL && st->state == COMP_FUNCTION
2119 && !sym->attr.recursive)
2121 e = gfc_get_expr ();
2122 e->symtree = symtree;
2123 e->expr_type = EXPR_VARIABLE;
2125 m = match_varspec (e, 0);
2129 /* Match a function reference. */
2131 m = gfc_match_actual_arglist (0, &actual_arglist);
2134 if (sym->attr.proc == PROC_ST_FUNCTION)
2135 gfc_error ("Statement function '%s' requires argument list at %C",
2138 gfc_error ("Function '%s' requires an argument list at %C",
2151 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2152 sym = symtree->n.sym;
2154 e = gfc_get_expr ();
2155 e->symtree = symtree;
2156 e->expr_type = EXPR_FUNCTION;
2157 e->value.function.actual = actual_arglist;
2158 e->where = gfc_current_locus;
2160 if (sym->as != NULL)
2161 e->rank = sym->as->rank;
2163 if (!sym->attr.function
2164 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2170 if (sym->result == NULL)
2178 /* Special case for derived type variables that get their types
2179 via an IMPLICIT statement. This can't wait for the
2180 resolution phase. */
2182 if (gfc_peek_char () == '%'
2183 && sym->ts.type == BT_UNKNOWN
2184 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2185 gfc_set_default_type (sym, 0, sym->ns);
2187 /* If the symbol has a dimension attribute, the expression is a
2190 if (sym->attr.dimension)
2192 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2193 sym->name, NULL) == FAILURE)
2199 e = gfc_get_expr ();
2200 e->symtree = symtree;
2201 e->expr_type = EXPR_VARIABLE;
2202 m = match_varspec (e, 0);
2206 /* Name is not an array, so we peek to see if a '(' implies a
2207 function call or a substring reference. Otherwise the
2208 variable is just a scalar. */
2210 gfc_gobble_whitespace ();
2211 if (gfc_peek_char () != '(')
2213 /* Assume a scalar variable */
2214 e = gfc_get_expr ();
2215 e->symtree = symtree;
2216 e->expr_type = EXPR_VARIABLE;
2218 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2219 sym->name, NULL) == FAILURE)
2226 m = match_varspec (e, 0);
2230 /* See if this is a function reference with a keyword argument
2231 as first argument. We do this because otherwise a spurious
2232 symbol would end up in the symbol table. */
2234 old_loc = gfc_current_locus;
2235 m2 = gfc_match (" ( %n =", argname);
2236 gfc_current_locus = old_loc;
2238 e = gfc_get_expr ();
2239 e->symtree = symtree;
2241 if (m2 != MATCH_YES)
2243 /* Try to figure out whether we're dealing with a character type.
2244 We're peeking ahead here, because we don't want to call
2245 match_substring if we're dealing with an implicitly typed
2246 non-character variable. */
2247 implicit_char = false;
2248 if (sym->ts.type == BT_UNKNOWN)
2250 ts = gfc_get_default_type (sym,NULL);
2251 if (ts->type == BT_CHARACTER)
2252 implicit_char = true;
2255 /* See if this could possibly be a substring reference of a name
2256 that we're not sure is a variable yet. */
2258 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2259 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2262 e->expr_type = EXPR_VARIABLE;
2264 if (sym->attr.flavor != FL_VARIABLE
2265 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2266 sym->name, NULL) == FAILURE)
2272 if (sym->ts.type == BT_UNKNOWN
2273 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2287 /* Give up, assume we have a function. */
2289 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2290 sym = symtree->n.sym;
2291 e->expr_type = EXPR_FUNCTION;
2293 if (!sym->attr.function
2294 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2302 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2304 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2312 /* If our new function returns a character, array or structure
2313 type, it might have subsequent references. */
2315 m = match_varspec (e, 0);
2322 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2324 e = gfc_get_expr ();
2325 e->symtree = symtree;
2326 e->expr_type = EXPR_FUNCTION;
2328 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2332 gfc_error ("Symbol at %C is not appropriate for an expression");
2348 /* Match a variable, ie something that can be assigned to. This
2349 starts as a symbol, can be a structure component or an array
2350 reference. It can be a function if the function doesn't have a
2351 separate RESULT variable. If the symbol has not been previously
2352 seen, we assume it is a variable.
2354 This function is called by two interface functions:
2355 gfc_match_variable, which has host_flag = 1, and
2356 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2357 match of the symbol to the local scope. */
2360 match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
2368 /* Since nothing has any business being an lvalue in a module
2369 specification block, an interface block or a contains section,
2370 we force the changed_symbols mechanism to work by setting
2371 host_flag to 0. This prevents valid symbols that have the name
2372 of keywords, such as 'end', being turned into variables by
2373 failed matching to assignments for, eg., END INTERFACE. */
2374 if (gfc_current_state () == COMP_MODULE
2375 || gfc_current_state () == COMP_INTERFACE
2376 || gfc_current_state () == COMP_CONTAINS)
2379 m = gfc_match_sym_tree (&st, host_flag);
2382 where = gfc_current_locus;
2385 gfc_set_sym_referenced (sym);
2386 switch (sym->attr.flavor)
2389 if (sym->attr.protected && sym->attr.use_assoc)
2391 gfc_error ("Assigning to PROTECTED variable at %C");
2397 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2398 sym->name, NULL) == FAILURE)
2404 gfc_error ("Named constant at %C in an EQUIVALENCE");
2406 gfc_error ("Cannot assign to a named constant at %C");
2411 /* Check for a nonrecursive function result */
2412 if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2414 /* If a function result is a derived type, then the derived
2415 type may still have to be resolved. */
2417 if (sym->ts.type == BT_DERIVED
2418 && gfc_use_derived (sym->ts.derived) == NULL)
2423 /* Fall through to error */
2426 gfc_error ("Expected VARIABLE at %C");
2430 /* Special case for derived type variables that get their types
2431 via an IMPLICIT statement. This can't wait for the
2432 resolution phase. */
2435 gfc_namespace * implicit_ns;
2437 if (gfc_current_ns->proc_name == sym)
2438 implicit_ns = gfc_current_ns;
2440 implicit_ns = sym->ns;
2442 if (gfc_peek_char () == '%'
2443 && sym->ts.type == BT_UNKNOWN
2444 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2445 gfc_set_default_type (sym, 0, implicit_ns);
2448 expr = gfc_get_expr ();
2450 expr->expr_type = EXPR_VARIABLE;
2453 expr->where = where;
2455 /* Now see if we have to do more. */
2456 m = match_varspec (expr, equiv_flag);
2459 gfc_free_expr (expr);
2468 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2470 return match_variable (result, equiv_flag, 1);
2474 gfc_match_equiv_variable (gfc_expr ** result)
2476 return match_variable (result, 1, 0);