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 /* Matches an actual argument list of a function or subroutine, from
1433 the opening parenthesis to the closing parenthesis. The argument
1434 list is assumed to allow keyword arguments because we don't know if
1435 the symbol associated with the procedure has an implicit interface
1436 or not. We make sure keywords are unique. If SUB_FLAG is set,
1437 we're matching the argument list of a subroutine. */
1440 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
1442 gfc_actual_arglist *head, *tail;
1444 gfc_st_label *label;
1448 *argp = tail = NULL;
1449 old_loc = gfc_current_locus;
1453 if (gfc_match_char ('(') == MATCH_NO)
1454 return (sub_flag) ? MATCH_YES : MATCH_NO;
1456 if (gfc_match_char (')') == MATCH_YES)
1463 head = tail = gfc_get_actual_arglist ();
1466 tail->next = gfc_get_actual_arglist ();
1470 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1472 m = gfc_match_st_label (&label);
1474 gfc_error ("Expected alternate return label at %C");
1478 tail->label = label;
1482 /* After the first keyword argument is seen, the following
1483 arguments must also have keywords. */
1486 m = match_keyword_arg (tail, head);
1488 if (m == MATCH_ERROR)
1493 ("Missing keyword name in actual argument list at %C");
1500 /* See if we have the first keyword argument. */
1501 m = match_keyword_arg (tail, head);
1504 if (m == MATCH_ERROR)
1509 /* Try for a non-keyword argument. */
1510 m = match_actual_arg (&tail->expr);
1511 if (m == MATCH_ERROR)
1519 if (gfc_match_char (')') == MATCH_YES)
1521 if (gfc_match_char (',') != MATCH_YES)
1529 gfc_error ("Syntax error in argument list at %C");
1532 gfc_free_actual_arglist (head);
1533 gfc_current_locus = old_loc;
1539 /* Used by match_varspec() to extend the reference list by one
1543 extend_ref (gfc_expr * primary, gfc_ref * tail)
1546 if (primary->ref == NULL)
1547 primary->ref = tail = gfc_get_ref ();
1551 gfc_internal_error ("extend_ref(): Bad tail");
1552 tail->next = gfc_get_ref ();
1560 /* Match any additional specifications associated with the current
1561 variable like member references or substrings. If equiv_flag is
1562 set we only match stuff that is allowed inside an EQUIVALENCE
1566 match_varspec (gfc_expr * primary, int equiv_flag)
1568 char name[GFC_MAX_SYMBOL_LEN + 1];
1569 gfc_ref *substring, *tail;
1570 gfc_component *component;
1571 gfc_symbol *sym = primary->symtree->n.sym;
1576 if ((equiv_flag && gfc_peek_char () == '(')
1577 || sym->attr.dimension)
1579 /* In EQUIVALENCE, we don't know yet whether we are seeing
1580 an array, character variable or array of character
1581 variables. We'll leave the decision till resolve
1583 tail = extend_ref (primary, tail);
1584 tail->type = REF_ARRAY;
1586 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1591 if (equiv_flag && gfc_peek_char () == '(')
1593 tail = extend_ref (primary, tail);
1594 tail->type = REF_ARRAY;
1596 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1602 primary->ts = sym->ts;
1607 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1608 goto check_substring;
1610 sym = sym->ts.derived;
1614 m = gfc_match_name (name);
1616 gfc_error ("Expected structure component name at %C");
1620 component = gfc_find_component (sym, name);
1621 if (component == NULL)
1624 tail = extend_ref (primary, tail);
1625 tail->type = REF_COMPONENT;
1627 tail->u.c.component = component;
1628 tail->u.c.sym = sym;
1630 primary->ts = component->ts;
1632 if (component->as != NULL)
1634 tail = extend_ref (primary, tail);
1635 tail->type = REF_ARRAY;
1637 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1642 if (component->ts.type != BT_DERIVED
1643 || gfc_match_char ('%') != MATCH_YES)
1646 sym = component->ts.derived;
1650 if (primary->ts.type == BT_UNKNOWN)
1652 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1654 gfc_set_default_type (sym, 0, sym->ns);
1655 primary->ts = sym->ts;
1659 if (primary->ts.type == BT_CHARACTER)
1661 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1665 primary->ref = substring;
1667 tail->next = substring;
1669 if (primary->expr_type == EXPR_CONSTANT)
1670 primary->expr_type = EXPR_SUBSTRING;
1673 primary->ts.cl = NULL;
1689 /* Given an expression that is a variable, figure out what the
1690 ultimate variable's type and attribute is, traversing the reference
1691 structures if necessary.
1693 This subroutine is trickier than it looks. We start at the base
1694 symbol and store the attribute. Component references load a
1695 completely new attribute.
1697 A couple of rules come into play. Subobjects of targets are always
1698 targets themselves. If we see a component that goes through a
1699 pointer, then the expression must also be a target, since the
1700 pointer is associated with something (if it isn't core will soon be
1701 dumped). If we see a full part or section of an array, the
1702 expression is also an array.
1704 We can have at most one full array reference. */
1707 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1709 int dimension, pointer, allocatable, target;
1710 symbol_attribute attr;
1713 if (expr->expr_type != EXPR_VARIABLE)
1714 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1717 attr = expr->symtree->n.sym->attr;
1719 dimension = attr.dimension;
1720 pointer = attr.pointer;
1721 allocatable = attr.allocatable;
1723 target = attr.target;
1727 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1728 *ts = expr->symtree->n.sym->ts;
1730 for (; ref; ref = ref->next)
1735 switch (ref->u.ar.type)
1742 allocatable = pointer = 0;
1747 allocatable = pointer = 0;
1751 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1757 gfc_get_component_attr (&attr, ref->u.c.component);
1759 *ts = ref->u.c.component->ts;
1761 pointer = ref->u.c.component->pointer;
1762 allocatable = ref->u.c.component->allocatable;
1769 allocatable = pointer = 0;
1773 attr.dimension = dimension;
1774 attr.pointer = pointer;
1775 attr.allocatable = allocatable;
1776 attr.target = target;
1782 /* Return the attribute from a general expression. */
1785 gfc_expr_attr (gfc_expr * e)
1787 symbol_attribute attr;
1789 switch (e->expr_type)
1792 attr = gfc_variable_attr (e, NULL);
1796 gfc_clear_attr (&attr);
1798 if (e->value.function.esym != NULL)
1799 attr = e->value.function.esym->result->attr;
1801 /* TODO: NULL() returns pointers. May have to take care of this
1807 gfc_clear_attr (&attr);
1815 /* Match a structure constructor. The initial symbol has already been
1819 gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1821 gfc_constructor *head, *tail;
1822 gfc_component *comp;
1829 if (gfc_match_char ('(') != MATCH_YES)
1832 where = gfc_current_locus;
1834 gfc_find_component (sym, NULL);
1836 for (comp = sym->components; comp; comp = comp->next)
1839 tail = head = gfc_get_constructor ();
1842 tail->next = gfc_get_constructor ();
1846 m = gfc_match_expr (&tail->expr);
1849 if (m == MATCH_ERROR)
1852 if (gfc_match_char (',') == MATCH_YES)
1854 if (comp->next == NULL)
1857 ("Too many components in structure constructor at %C");
1867 if (gfc_match_char (')') != MATCH_YES)
1870 if (comp->next != NULL)
1872 gfc_error ("Too few components in structure constructor at %C");
1876 e = gfc_get_expr ();
1878 e->expr_type = EXPR_STRUCTURE;
1880 e->ts.type = BT_DERIVED;
1881 e->ts.derived = sym;
1884 e->value.constructor = head;
1890 gfc_error ("Syntax error in structure constructor at %C");
1893 gfc_free_constructor (head);
1898 /* Matches a variable name followed by anything that might follow it--
1899 array reference, argument list of a function, etc. */
1902 gfc_match_rvalue (gfc_expr ** result)
1904 gfc_actual_arglist *actual_arglist;
1905 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1908 gfc_symtree *symtree;
1909 locus where, old_loc;
1916 m = gfc_match_name (name);
1920 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
1921 && !gfc_current_ns->has_import_set)
1922 i = gfc_get_sym_tree (name, NULL, &symtree);
1924 i = gfc_get_ha_sym_tree (name, &symtree);
1929 sym = symtree->n.sym;
1931 where = gfc_current_locus;
1933 gfc_set_sym_referenced (sym);
1935 if (sym->attr.function && sym->result == sym)
1937 /* See if this is a directly recursive function call. */
1938 gfc_gobble_whitespace ();
1939 if (sym->attr.recursive
1940 && gfc_peek_char () == '('
1941 && gfc_current_ns->proc_name == sym)
1943 if (!sym->attr.dimension)
1946 gfc_error ("'%s' is array valued and directly recursive "
1947 "at %C , so the keyword RESULT must be specified "
1948 "in the FUNCTION statement", sym->name);
1952 if (gfc_current_ns->proc_name == sym
1953 || (gfc_current_ns->parent != NULL
1954 && gfc_current_ns->parent->proc_name == sym))
1958 && (sym->ns == gfc_current_ns
1959 || sym->ns == gfc_current_ns->parent))
1961 gfc_entry_list *el = NULL;
1963 for (el = sym->ns->entries; el; el = el->next)
1969 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1972 if (sym->attr.generic)
1973 goto generic_function;
1975 switch (sym->attr.flavor)
1979 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1980 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1981 gfc_set_default_type (sym, 0, sym->ns);
1983 e = gfc_get_expr ();
1985 e->expr_type = EXPR_VARIABLE;
1986 e->symtree = symtree;
1988 m = match_varspec (e, 0);
1992 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
1993 end up here. Unfortunately, sym->value->expr_type is set to
1994 EXPR_CONSTANT, and so the if () branch would be followed without
1995 the !sym->as check. */
1996 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
1997 e = gfc_copy_expr (sym->value);
2000 e = gfc_get_expr ();
2001 e->expr_type = EXPR_VARIABLE;
2004 e->symtree = symtree;
2005 m = match_varspec (e, 0);
2009 sym = gfc_use_derived (sym);
2013 m = gfc_match_structure_constructor (sym, &e);
2016 /* If we're here, then the name is known to be the name of a
2017 procedure, yet it is not sure to be the name of a function. */
2019 if (sym->attr.subroutine)
2021 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2027 /* At this point, the name has to be a non-statement function.
2028 If the name is the same as the current function being
2029 compiled, then we have a variable reference (to the function
2030 result) if the name is non-recursive. */
2032 st = gfc_enclosing_unit (NULL);
2034 if (st != NULL && st->state == COMP_FUNCTION
2036 && !sym->attr.recursive)
2038 e = gfc_get_expr ();
2039 e->symtree = symtree;
2040 e->expr_type = EXPR_VARIABLE;
2042 m = match_varspec (e, 0);
2046 /* Match a function reference. */
2048 m = gfc_match_actual_arglist (0, &actual_arglist);
2051 if (sym->attr.proc == PROC_ST_FUNCTION)
2052 gfc_error ("Statement function '%s' requires argument list at %C",
2055 gfc_error ("Function '%s' requires an argument list at %C",
2068 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2069 sym = symtree->n.sym;
2071 e = gfc_get_expr ();
2072 e->symtree = symtree;
2073 e->expr_type = EXPR_FUNCTION;
2074 e->value.function.actual = actual_arglist;
2075 e->where = gfc_current_locus;
2077 if (sym->as != NULL)
2078 e->rank = sym->as->rank;
2080 if (!sym->attr.function
2081 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2087 if (sym->result == NULL)
2095 /* Special case for derived type variables that get their types
2096 via an IMPLICIT statement. This can't wait for the
2097 resolution phase. */
2099 if (gfc_peek_char () == '%'
2100 && sym->ts.type == BT_UNKNOWN
2101 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2102 gfc_set_default_type (sym, 0, sym->ns);
2104 /* If the symbol has a dimension attribute, the expression is a
2107 if (sym->attr.dimension)
2109 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2110 sym->name, NULL) == FAILURE)
2116 e = gfc_get_expr ();
2117 e->symtree = symtree;
2118 e->expr_type = EXPR_VARIABLE;
2119 m = match_varspec (e, 0);
2123 /* Name is not an array, so we peek to see if a '(' implies a
2124 function call or a substring reference. Otherwise the
2125 variable is just a scalar. */
2127 gfc_gobble_whitespace ();
2128 if (gfc_peek_char () != '(')
2130 /* Assume a scalar variable */
2131 e = gfc_get_expr ();
2132 e->symtree = symtree;
2133 e->expr_type = EXPR_VARIABLE;
2135 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2136 sym->name, NULL) == FAILURE)
2143 m = match_varspec (e, 0);
2147 /* See if this is a function reference with a keyword argument
2148 as first argument. We do this because otherwise a spurious
2149 symbol would end up in the symbol table. */
2151 old_loc = gfc_current_locus;
2152 m2 = gfc_match (" ( %n =", argname);
2153 gfc_current_locus = old_loc;
2155 e = gfc_get_expr ();
2156 e->symtree = symtree;
2158 if (m2 != MATCH_YES)
2160 /* Try to figure out whether we're dealing with a character type.
2161 We're peeking ahead here, because we don't want to call
2162 match_substring if we're dealing with an implicitly typed
2163 non-character variable. */
2164 implicit_char = false;
2165 if (sym->ts.type == BT_UNKNOWN)
2167 ts = gfc_get_default_type (sym,NULL);
2168 if (ts->type == BT_CHARACTER)
2169 implicit_char = true;
2172 /* See if this could possibly be a substring reference of a name
2173 that we're not sure is a variable yet. */
2175 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2176 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2179 e->expr_type = EXPR_VARIABLE;
2181 if (sym->attr.flavor != FL_VARIABLE
2182 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2183 sym->name, NULL) == FAILURE)
2189 if (sym->ts.type == BT_UNKNOWN
2190 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2204 /* Give up, assume we have a function. */
2206 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2207 sym = symtree->n.sym;
2208 e->expr_type = EXPR_FUNCTION;
2210 if (!sym->attr.function
2211 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2219 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2221 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2229 /* If our new function returns a character, array or structure
2230 type, it might have subsequent references. */
2232 m = match_varspec (e, 0);
2239 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2241 e = gfc_get_expr ();
2242 e->symtree = symtree;
2243 e->expr_type = EXPR_FUNCTION;
2245 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2249 gfc_error ("Symbol at %C is not appropriate for an expression");
2265 /* Match a variable, ie something that can be assigned to. This
2266 starts as a symbol, can be a structure component or an array
2267 reference. It can be a function if the function doesn't have a
2268 separate RESULT variable. If the symbol has not been previously
2269 seen, we assume it is a variable.
2271 This function is called by two interface functions:
2272 gfc_match_variable, which has host_flag = 1, and
2273 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2274 match of the symbol to the local scope. */
2277 match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
2285 /* Since nothing has any business being an lvalue in a module
2286 specification block, an interface block or a contains section,
2287 we force the changed_symbols mechanism to work by setting
2288 host_flag to 0. This prevents valid symbols that have the name
2289 of keywords, such as 'end', being turned into variables by
2290 failed matching to assignments for, eg., END INTERFACE. */
2291 if (gfc_current_state () == COMP_MODULE
2292 || gfc_current_state () == COMP_INTERFACE
2293 || gfc_current_state () == COMP_CONTAINS)
2296 m = gfc_match_sym_tree (&st, host_flag);
2299 where = gfc_current_locus;
2302 gfc_set_sym_referenced (sym);
2303 switch (sym->attr.flavor)
2309 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2310 sym->name, NULL) == FAILURE)
2316 gfc_error ("Named constant at %C in an EQUIVALENCE");
2318 gfc_error ("Cannot assign to a named constant at %C");
2323 /* Check for a nonrecursive function result */
2324 if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2326 /* If a function result is a derived type, then the derived
2327 type may still have to be resolved. */
2329 if (sym->ts.type == BT_DERIVED
2330 && gfc_use_derived (sym->ts.derived) == NULL)
2335 /* Fall through to error */
2338 gfc_error ("Expected VARIABLE at %C");
2342 /* Special case for derived type variables that get their types
2343 via an IMPLICIT statement. This can't wait for the
2344 resolution phase. */
2347 gfc_namespace * implicit_ns;
2349 if (gfc_current_ns->proc_name == sym)
2350 implicit_ns = gfc_current_ns;
2352 implicit_ns = sym->ns;
2354 if (gfc_peek_char () == '%'
2355 && sym->ts.type == BT_UNKNOWN
2356 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2357 gfc_set_default_type (sym, 0, implicit_ns);
2360 expr = gfc_get_expr ();
2362 expr->expr_type = EXPR_VARIABLE;
2365 expr->where = where;
2367 /* Now see if we have to do more. */
2368 m = match_varspec (expr, equiv_flag);
2371 gfc_free_expr (expr);
2380 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2382 return match_variable (result, equiv_flag, 1);
2386 gfc_match_equiv_variable (gfc_expr ** result)
2388 return match_variable (result, 1, 0);