1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
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
31 /* Matches a kind-parameter expression, which is either a named
32 symbolic constant or a nonnegative integer constant. If
33 successful, sets the kind value to the correct integer. */
36 match_kind_param (int *kind)
38 char name[GFC_MAX_SYMBOL_LEN + 1];
43 m = gfc_match_small_literal_int (kind, NULL);
47 m = gfc_match_name (name);
51 if (gfc_find_symbol (name, NULL, 1, &sym))
57 if (sym->attr.flavor != FL_PARAMETER)
60 p = gfc_extract_int (sym->value, kind);
71 /* Get a trailing kind-specification for non-character variables.
73 the integer kind value or:
74 -1 if an error was generated
75 -2 if no kind was found */
83 if (gfc_match_char ('_') != MATCH_YES)
86 m = match_kind_param (&kind);
88 gfc_error ("Missing kind-parameter at %C");
90 return (m == MATCH_YES) ? kind : -1;
94 /* Given a character and a radix, see if the character is a valid
95 digit in that radix. */
98 check_digit (int c, int radix)
105 r = ('0' <= c && c <= '1');
109 r = ('0' <= c && c <= '7');
113 r = ('0' <= c && c <= '9');
121 gfc_internal_error ("check_digit(): bad radix");
128 /* Match the digit string part of an integer if signflag is not set,
129 the signed digit string part if signflag is set. If the buffer
130 is NULL, we just count characters for the resolution pass. Returns
131 the number of characters matched, -1 for no match. */
134 match_digits (int signflag, int radix, char *buffer)
140 c = gfc_next_char ();
142 if (signflag && (c == '+' || c == '-'))
146 gfc_gobble_whitespace ();
147 c = gfc_next_char ();
151 if (!check_digit (c, radix))
160 old_loc = gfc_current_locus;
161 c = gfc_next_char ();
163 if (!check_digit (c, radix))
171 gfc_current_locus = old_loc;
177 /* Match an integer (digit string and optional kind).
178 A sign will be accepted if signflag is set. */
181 match_integer_constant (gfc_expr **result, int signflag)
188 old_loc = gfc_current_locus;
189 gfc_gobble_whitespace ();
191 length = match_digits (signflag, 10, NULL);
192 gfc_current_locus = old_loc;
196 buffer = alloca (length + 1);
197 memset (buffer, '\0', length + 1);
199 gfc_gobble_whitespace ();
201 match_digits (signflag, 10, buffer);
205 kind = gfc_default_integer_kind;
209 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
211 gfc_error ("Integer kind %d at %C not available", kind);
215 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
217 if (gfc_range_check (e) != ARITH_OK)
219 gfc_error ("Integer too big for its kind at %C");
230 /* Match a Hollerith constant. */
233 match_hollerith_constant (gfc_expr **result)
242 old_loc = gfc_current_locus;
243 gfc_gobble_whitespace ();
245 if (match_integer_constant (&e, 0) == MATCH_YES
246 && gfc_match_char ('h') == MATCH_YES)
248 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
252 msg = gfc_extract_int (e, &num);
260 gfc_error ("Invalid Hollerith constant: %L must contain at least "
261 "one character", &old_loc);
264 if (e->ts.kind != gfc_default_integer_kind)
266 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
267 "should be default", &old_loc);
272 buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
273 for (i = 0; i < num; i++)
275 buffer[i] = gfc_next_char_literal (1);
278 e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
280 e->value.character.string = gfc_getmem (num + 1);
281 memcpy (e->value.character.string, buffer, num);
282 e->value.character.string[num] = '\0';
283 e->value.character.length = num;
290 gfc_current_locus = old_loc;
299 /* Match a binary, octal or hexadecimal constant that can be found in
300 a DATA statement. The standard permits b'010...', o'73...', and
301 z'a1...' where b, o, and z can be capital letters. This function
302 also accepts postfixed forms of the constants: '01...'b, '73...'o,
303 and 'a1...'z. An additional extension is the use of x for z. */
306 match_boz_constant (gfc_expr **result)
308 int post, radix, delim, length, x_hex, kind;
309 locus old_loc, start_loc;
313 start_loc = old_loc = gfc_current_locus;
314 gfc_gobble_whitespace ();
317 switch (post = gfc_next_char ())
339 radix = 16; /* Set to accept any valid digit string. */
345 /* No whitespace allowed here. */
348 delim = gfc_next_char ();
350 if (delim != '\'' && delim != '\"')
353 if (x_hex && pedantic
354 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
355 "constant at %C uses non-standard syntax.")
359 old_loc = gfc_current_locus;
361 length = match_digits (0, radix, NULL);
364 gfc_error ("Empty set of digits in BOZ constant at %C");
368 if (gfc_next_char () != delim)
370 gfc_error ("Illegal character in BOZ constant at %C");
376 switch (gfc_next_char ())
392 gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
393 "at %C uses non-standard postfix syntax.");
396 gfc_current_locus = old_loc;
398 buffer = alloca (length + 1);
399 memset (buffer, '\0', length + 1);
401 match_digits (0, radix, buffer);
402 gfc_next_char (); /* Eat delimiter. */
404 gfc_next_char (); /* Eat postfixed b, o, z, or x. */
406 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
407 "If a data-stmt-constant is a boz-literal-constant, the corresponding
408 variable shall be of type integer. The boz-literal-constant is treated
409 as if it were an int-literal-constant with a kind-param that specifies
410 the representation method with the largest decimal exponent range
411 supported by the processor." */
413 kind = gfc_max_integer_kind;
414 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
416 if (gfc_range_check (e) != ARITH_OK)
418 gfc_error ("Integer too big for integer kind %i at %C", kind);
427 gfc_current_locus = start_loc;
432 /* Match a real constant of some sort. Allow a signed constant if signflag
433 is nonzero. Allow integer constants if allow_int is true. */
436 match_real_constant (gfc_expr **result, int signflag)
438 int kind, c, count, seen_dp, seen_digits, exp_char;
439 locus old_loc, temp_loc;
444 old_loc = gfc_current_locus;
445 gfc_gobble_whitespace ();
455 c = gfc_next_char ();
456 if (signflag && (c == '+' || c == '-'))
461 gfc_gobble_whitespace ();
462 c = gfc_next_char ();
465 /* Scan significand. */
466 for (;; c = gfc_next_char (), count++)
473 /* Check to see if "." goes with a following operator like
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;
502 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
507 c = gfc_next_char ();
510 if (c == '+' || c == '-')
511 { /* optional sign */
512 c = gfc_next_char ();
518 gfc_error ("Missing exponent in real number at %C");
524 c = gfc_next_char ();
529 /* Check that we have a numeric constant. */
530 if (!seen_digits || (!seen_dp && exp_char == ' '))
532 gfc_current_locus = old_loc;
536 /* Convert the number. */
537 gfc_current_locus = old_loc;
538 gfc_gobble_whitespace ();
540 buffer = alloca (count + 1);
541 memset (buffer, '\0', count + 1);
544 c = gfc_next_char ();
545 if (c == '+' || c == '-')
547 gfc_gobble_whitespace ();
548 c = gfc_next_char ();
551 /* Hack for mpfr_set_str(). */
554 if (c == 'd' || c == 'q')
562 c = gfc_next_char ();
574 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
578 kind = gfc_default_double_kind;
583 kind = gfc_default_real_kind;
585 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
587 gfc_error ("Invalid real kind %d at %C", kind);
592 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
594 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
596 switch (gfc_range_check (e))
601 gfc_error ("Real constant overflows its kind at %C");
604 case ARITH_UNDERFLOW:
605 if (gfc_option.warn_underflow)
606 gfc_warning ("Real constant underflows its kind at %C");
607 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
611 gfc_internal_error ("gfc_range_check() returned bad value");
623 /* Match a substring reference. */
626 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
628 gfc_expr *start, *end;
636 old_loc = gfc_current_locus;
638 m = gfc_match_char ('(');
642 if (gfc_match_char (':') != MATCH_YES)
645 m = gfc_match_init_expr (&start);
647 m = gfc_match_expr (&start);
655 m = gfc_match_char (':');
660 if (gfc_match_char (')') != MATCH_YES)
663 m = gfc_match_init_expr (&end);
665 m = gfc_match_expr (&end);
669 if (m == MATCH_ERROR)
672 m = gfc_match_char (')');
677 /* Optimize away the (:) reference. */
678 if (start == NULL && end == NULL)
682 ref = gfc_get_ref ();
684 ref->type = REF_SUBSTRING;
686 start = gfc_int_expr (1);
687 ref->u.ss.start = start;
688 if (end == NULL && cl)
689 end = gfc_copy_expr (cl->length);
691 ref->u.ss.length = cl;
698 gfc_error ("Syntax error in SUBSTRING specification at %C");
702 gfc_free_expr (start);
705 gfc_current_locus = old_loc;
710 /* Reads the next character of a string constant, taking care to
711 return doubled delimiters on the input as a single instance of
714 Special return values are:
715 -1 End of the string, as determined by the delimiter
716 -2 Unterminated string detected
718 Backslash codes are also expanded at this time. */
721 next_string_char (char delimiter)
726 c = gfc_next_char_literal (1);
731 if (gfc_option.flag_backslash && c == '\\')
733 old_locus = gfc_current_locus;
735 switch (gfc_next_char_literal (1))
763 /* Unknown backslash codes are simply not expanded */
764 gfc_current_locus = old_locus;
772 old_locus = gfc_current_locus;
773 c = gfc_next_char_literal (1);
777 gfc_current_locus = old_locus;
783 /* Special case of gfc_match_name() that matches a parameter kind name
784 before a string constant. This takes case of the weird but legal
789 where kind____ is a parameter. gfc_match_name() will happily slurp
790 up all the underscores, which leads to problems. If we return
791 MATCH_YES, the parse pointer points to the final underscore, which
792 is not part of the name. We never return MATCH_ERROR-- errors in
793 the name will be detected later. */
796 match_charkind_name (char *name)
802 gfc_gobble_whitespace ();
803 c = gfc_next_char ();
812 old_loc = gfc_current_locus;
813 c = gfc_next_char ();
817 peek = gfc_peek_char ();
819 if (peek == '\'' || peek == '\"')
821 gfc_current_locus = old_loc;
829 && (gfc_option.flag_dollar_ok && c != '$'))
833 if (++len > GFC_MAX_SYMBOL_LEN)
841 /* See if the current input matches a character constant. Lots of
842 contortions have to be done to match the kind parameter which comes
843 before the actual string. The main consideration is that we don't
844 want to error out too quickly. For example, we don't actually do
845 any validation of the kinds until we have actually seen a legal
846 delimiter. Using match_kind_param() generates errors too quickly. */
849 match_string_constant (gfc_expr **result)
851 char *p, name[GFC_MAX_SYMBOL_LEN + 1];
852 int i, c, kind, length, delimiter;
853 locus old_locus, start_locus;
859 old_locus = gfc_current_locus;
861 gfc_gobble_whitespace ();
863 start_locus = gfc_current_locus;
865 c = gfc_next_char ();
866 if (c == '\'' || c == '"')
868 kind = gfc_default_character_kind;
878 kind = kind * 10 + c - '0';
881 c = gfc_next_char ();
887 gfc_current_locus = old_locus;
889 m = match_charkind_name (name);
893 if (gfc_find_symbol (name, NULL, 1, &sym)
895 || sym->attr.flavor != FL_PARAMETER)
899 c = gfc_next_char ();
904 gfc_gobble_whitespace ();
905 c = gfc_next_char ();
911 gfc_gobble_whitespace ();
912 start_locus = gfc_current_locus;
914 c = gfc_next_char ();
915 if (c != '\'' && c != '"')
920 q = gfc_extract_int (sym->value, &kind);
928 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
930 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
935 /* Scan the string into a block of memory by first figuring out how
936 long it is, allocating the structure, then re-reading it. This
937 isn't particularly efficient, but string constants aren't that
938 common in most code. TODO: Use obstacks? */
945 c = next_string_char (delimiter);
950 gfc_current_locus = start_locus;
951 gfc_error ("Unterminated character constant beginning at %C");
958 /* Peek at the next character to see if it is a b, o, z, or x for the
959 postfixed BOZ literal constants. */
960 c = gfc_peek_char ();
961 if (c == 'b' || c == 'o' || c =='z' || c == 'x')
967 e->expr_type = EXPR_CONSTANT;
969 e->ts.type = BT_CHARACTER;
971 e->where = start_locus;
973 e->value.character.string = p = gfc_getmem (length + 1);
974 e->value.character.length = length;
976 gfc_current_locus = start_locus;
977 gfc_next_char (); /* Skip delimiter */
979 for (i = 0; i < length; i++)
980 *p++ = next_string_char (delimiter);
982 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
984 if (next_string_char (delimiter) != -1)
985 gfc_internal_error ("match_string_constant(): Delimiter not found");
987 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
988 e->expr_type = EXPR_SUBSTRING;
995 gfc_current_locus = old_locus;
1000 /* Match a .true. or .false. */
1003 match_logical_constant (gfc_expr **result)
1005 static mstring logical_ops[] = {
1006 minit (".false.", 0),
1007 minit (".true.", 1),
1014 i = gfc_match_strings (logical_ops);
1022 kind = gfc_default_logical_kind;
1024 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1025 gfc_error ("Bad kind for logical constant at %C");
1027 e = gfc_get_expr ();
1029 e->expr_type = EXPR_CONSTANT;
1030 e->value.logical = i;
1031 e->ts.type = BT_LOGICAL;
1033 e->where = gfc_current_locus;
1040 /* Match a real or imaginary part of a complex constant that is a
1041 symbolic constant. */
1044 match_sym_complex_part (gfc_expr **result)
1046 char name[GFC_MAX_SYMBOL_LEN + 1];
1051 m = gfc_match_name (name);
1055 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1058 if (sym->attr.flavor != FL_PARAMETER)
1060 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1064 if (!gfc_numeric_ts (&sym->value->ts))
1066 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1070 if (sym->value->rank != 0)
1072 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1076 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1077 "complex constant at %C") == FAILURE)
1080 switch (sym->value->ts.type)
1083 e = gfc_copy_expr (sym->value);
1087 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1093 e = gfc_int2real (sym->value, gfc_default_real_kind);
1099 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1102 *result = e; /* e is a scalar, real, constant expression. */
1106 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1111 /* Match a real or imaginary part of a complex number. */
1114 match_complex_part (gfc_expr **result)
1118 m = match_sym_complex_part (result);
1122 m = match_real_constant (result, 1);
1126 return match_integer_constant (result, 1);
1130 /* Try to match a complex constant. */
1133 match_complex_constant (gfc_expr **result)
1135 gfc_expr *e, *real, *imag;
1136 gfc_error_buf old_error;
1137 gfc_typespec target;
1142 old_loc = gfc_current_locus;
1143 real = imag = e = NULL;
1145 m = gfc_match_char ('(');
1149 gfc_push_error (&old_error);
1151 m = match_complex_part (&real);
1154 gfc_free_error (&old_error);
1158 if (gfc_match_char (',') == MATCH_NO)
1160 gfc_pop_error (&old_error);
1165 /* If m is error, then something was wrong with the real part and we
1166 assume we have a complex constant because we've seen the ','. An
1167 ambiguous case here is the start of an iterator list of some
1168 sort. These sort of lists are matched prior to coming here. */
1170 if (m == MATCH_ERROR)
1172 gfc_free_error (&old_error);
1175 gfc_pop_error (&old_error);
1177 m = match_complex_part (&imag);
1180 if (m == MATCH_ERROR)
1183 m = gfc_match_char (')');
1186 /* Give the matcher for implied do-loops a chance to run. This
1187 yields a much saner error message for (/ (i, 4=i, 6) /). */
1188 if (gfc_peek_char () == '=')
1197 if (m == MATCH_ERROR)
1200 /* Decide on the kind of this complex number. */
1201 if (real->ts.type == BT_REAL)
1203 if (imag->ts.type == BT_REAL)
1204 kind = gfc_kind_max (real, imag);
1206 kind = real->ts.kind;
1210 if (imag->ts.type == BT_REAL)
1211 kind = imag->ts.kind;
1213 kind = gfc_default_real_kind;
1215 target.type = BT_REAL;
1218 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1219 gfc_convert_type (real, &target, 2);
1220 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1221 gfc_convert_type (imag, &target, 2);
1223 e = gfc_convert_complex (real, imag, kind);
1224 e->where = gfc_current_locus;
1226 gfc_free_expr (real);
1227 gfc_free_expr (imag);
1233 gfc_error ("Syntax error in COMPLEX constant at %C");
1238 gfc_free_expr (real);
1239 gfc_free_expr (imag);
1240 gfc_current_locus = old_loc;
1246 /* Match constants in any of several forms. Returns nonzero for a
1247 match, zero for no match. */
1250 gfc_match_literal_constant (gfc_expr **result, int signflag)
1254 m = match_complex_constant (result);
1258 m = match_string_constant (result);
1262 m = match_boz_constant (result);
1266 m = match_real_constant (result, signflag);
1270 m = match_hollerith_constant (result);
1274 m = match_integer_constant (result, signflag);
1278 m = match_logical_constant (result);
1286 /* Match a single actual argument value. An actual argument is
1287 usually an expression, but can also be a procedure name. If the
1288 argument is a single name, it is not always possible to tell
1289 whether the name is a dummy procedure or not. We treat these cases
1290 by creating an argument that looks like a dummy procedure and
1291 fixing things later during resolution. */
1294 match_actual_arg (gfc_expr **result)
1296 char name[GFC_MAX_SYMBOL_LEN + 1];
1297 gfc_symtree *symtree;
1302 where = gfc_current_locus;
1304 switch (gfc_match_name (name))
1313 w = gfc_current_locus;
1314 gfc_gobble_whitespace ();
1315 c = gfc_next_char ();
1316 gfc_current_locus = w;
1318 if (c != ',' && c != ')')
1321 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1323 /* Handle error elsewhere. */
1325 /* Eliminate a couple of common cases where we know we don't
1326 have a function argument. */
1327 if (symtree == NULL)
1329 gfc_get_sym_tree (name, NULL, &symtree);
1330 gfc_set_sym_referenced (symtree->n.sym);
1336 sym = symtree->n.sym;
1337 gfc_set_sym_referenced (sym);
1338 if (sym->attr.flavor != FL_PROCEDURE
1339 && sym->attr.flavor != FL_UNKNOWN)
1342 /* If the symbol is a function with itself as the result and
1343 is being defined, then we have a variable. */
1344 if (sym->attr.function && sym->result == sym)
1346 if (gfc_current_ns->proc_name == sym
1347 || (gfc_current_ns->parent != NULL
1348 && gfc_current_ns->parent->proc_name == sym))
1352 && (sym->ns == gfc_current_ns
1353 || sym->ns == gfc_current_ns->parent))
1355 gfc_entry_list *el = NULL;
1357 for (el = sym->ns->entries; el; el = el->next)
1367 e = gfc_get_expr (); /* Leave it unknown for now */
1368 e->symtree = symtree;
1369 e->expr_type = EXPR_VARIABLE;
1370 e->ts.type = BT_PROCEDURE;
1377 gfc_current_locus = where;
1378 return gfc_match_expr (result);
1382 /* Match a keyword argument. */
1385 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1387 char name[GFC_MAX_SYMBOL_LEN + 1];
1388 gfc_actual_arglist *a;
1392 name_locus = gfc_current_locus;
1393 m = gfc_match_name (name);
1397 if (gfc_match_char ('=') != MATCH_YES)
1403 m = match_actual_arg (&actual->expr);
1407 /* Make sure this name has not appeared yet. */
1409 if (name[0] != '\0')
1411 for (a = base; a; a = a->next)
1412 if (a->name != NULL && strcmp (a->name, name) == 0)
1414 gfc_error ("Keyword '%s' at %C has already appeared in the "
1415 "current argument list", name);
1420 actual->name = gfc_get_string (name);
1424 gfc_current_locus = name_locus;
1429 /* Match an argument list function, such as %VAL. */
1432 match_arg_list_function (gfc_actual_arglist *result)
1434 char name[GFC_MAX_SYMBOL_LEN + 1];
1438 old_locus = gfc_current_locus;
1440 if (gfc_match_char ('%') != MATCH_YES)
1446 m = gfc_match ("%n (", name);
1450 if (name[0] != '\0')
1455 if (strncmp (name, "loc", 3) == 0)
1457 result->name = "%LOC";
1461 if (strncmp (name, "ref", 3) == 0)
1463 result->name = "%REF";
1467 if (strncmp (name, "val", 3) == 0)
1469 result->name = "%VAL";
1478 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1479 "function at %C") == FAILURE)
1485 m = match_actual_arg (&result->expr);
1489 if (gfc_match_char (')') != MATCH_YES)
1498 gfc_current_locus = old_locus;
1503 /* Matches an actual argument list of a function or subroutine, from
1504 the opening parenthesis to the closing parenthesis. The argument
1505 list is assumed to allow keyword arguments because we don't know if
1506 the symbol associated with the procedure has an implicit interface
1507 or not. We make sure keywords are unique. If SUB_FLAG is set,
1508 we're matching the argument list of a subroutine. */
1511 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1513 gfc_actual_arglist *head, *tail;
1515 gfc_st_label *label;
1519 *argp = tail = NULL;
1520 old_loc = gfc_current_locus;
1524 if (gfc_match_char ('(') == MATCH_NO)
1525 return (sub_flag) ? MATCH_YES : MATCH_NO;
1527 if (gfc_match_char (')') == MATCH_YES)
1534 head = tail = gfc_get_actual_arglist ();
1537 tail->next = gfc_get_actual_arglist ();
1541 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1543 m = gfc_match_st_label (&label);
1545 gfc_error ("Expected alternate return label at %C");
1549 tail->label = label;
1553 /* After the first keyword argument is seen, the following
1554 arguments must also have keywords. */
1557 m = match_keyword_arg (tail, head);
1559 if (m == MATCH_ERROR)
1563 gfc_error ("Missing keyword name in actual argument list at %C");
1570 /* Try an argument list function, like %VAL. */
1571 m = match_arg_list_function (tail);
1572 if (m == MATCH_ERROR)
1575 /* See if we have the first keyword argument. */
1578 m = match_keyword_arg (tail, head);
1581 if (m == MATCH_ERROR)
1587 /* Try for a non-keyword argument. */
1588 m = match_actual_arg (&tail->expr);
1589 if (m == MATCH_ERROR)
1598 if (gfc_match_char (')') == MATCH_YES)
1600 if (gfc_match_char (',') != MATCH_YES)
1608 gfc_error ("Syntax error in argument list at %C");
1611 gfc_free_actual_arglist (head);
1612 gfc_current_locus = old_loc;
1618 /* Used by match_varspec() to extend the reference list by one
1622 extend_ref (gfc_expr *primary, gfc_ref *tail)
1624 if (primary->ref == NULL)
1625 primary->ref = tail = gfc_get_ref ();
1629 gfc_internal_error ("extend_ref(): Bad tail");
1630 tail->next = gfc_get_ref ();
1638 /* Match any additional specifications associated with the current
1639 variable like member references or substrings. If equiv_flag is
1640 set we only match stuff that is allowed inside an EQUIVALENCE
1644 match_varspec (gfc_expr *primary, int equiv_flag)
1646 char name[GFC_MAX_SYMBOL_LEN + 1];
1647 gfc_ref *substring, *tail;
1648 gfc_component *component;
1649 gfc_symbol *sym = primary->symtree->n.sym;
1654 if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
1656 /* In EQUIVALENCE, we don't know yet whether we are seeing
1657 an array, character variable or array of character
1658 variables. We'll leave the decision till resolve time. */
1659 tail = extend_ref (primary, tail);
1660 tail->type = REF_ARRAY;
1662 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1667 if (equiv_flag && gfc_peek_char () == '(')
1669 tail = extend_ref (primary, tail);
1670 tail->type = REF_ARRAY;
1672 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1678 primary->ts = sym->ts;
1683 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1684 goto check_substring;
1686 sym = sym->ts.derived;
1690 m = gfc_match_name (name);
1692 gfc_error ("Expected structure component name at %C");
1696 component = gfc_find_component (sym, name);
1697 if (component == NULL)
1700 tail = extend_ref (primary, tail);
1701 tail->type = REF_COMPONENT;
1703 tail->u.c.component = component;
1704 tail->u.c.sym = sym;
1706 primary->ts = component->ts;
1708 if (component->as != NULL)
1710 tail = extend_ref (primary, tail);
1711 tail->type = REF_ARRAY;
1713 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1718 if (component->ts.type != BT_DERIVED
1719 || gfc_match_char ('%') != MATCH_YES)
1722 sym = component->ts.derived;
1726 if (primary->ts.type == BT_UNKNOWN)
1728 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1730 gfc_set_default_type (sym, 0, sym->ns);
1731 primary->ts = sym->ts;
1735 if (primary->ts.type == BT_CHARACTER)
1737 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1741 primary->ref = substring;
1743 tail->next = substring;
1745 if (primary->expr_type == EXPR_CONSTANT)
1746 primary->expr_type = EXPR_SUBSTRING;
1749 primary->ts.cl = NULL;
1765 /* Given an expression that is a variable, figure out what the
1766 ultimate variable's type and attribute is, traversing the reference
1767 structures if necessary.
1769 This subroutine is trickier than it looks. We start at the base
1770 symbol and store the attribute. Component references load a
1771 completely new attribute.
1773 A couple of rules come into play. Subobjects of targets are always
1774 targets themselves. If we see a component that goes through a
1775 pointer, then the expression must also be a target, since the
1776 pointer is associated with something (if it isn't core will soon be
1777 dumped). If we see a full part or section of an array, the
1778 expression is also an array.
1780 We can have at most one full array reference. */
1783 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1785 int dimension, pointer, allocatable, target;
1786 symbol_attribute attr;
1789 if (expr->expr_type != EXPR_VARIABLE)
1790 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1793 attr = expr->symtree->n.sym->attr;
1795 dimension = attr.dimension;
1796 pointer = attr.pointer;
1797 allocatable = attr.allocatable;
1799 target = attr.target;
1803 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1804 *ts = expr->symtree->n.sym->ts;
1806 for (; ref; ref = ref->next)
1811 switch (ref->u.ar.type)
1818 allocatable = pointer = 0;
1823 allocatable = pointer = 0;
1827 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1833 gfc_get_component_attr (&attr, ref->u.c.component);
1835 *ts = ref->u.c.component->ts;
1837 pointer = ref->u.c.component->pointer;
1838 allocatable = ref->u.c.component->allocatable;
1845 allocatable = pointer = 0;
1849 attr.dimension = dimension;
1850 attr.pointer = pointer;
1851 attr.allocatable = allocatable;
1852 attr.target = target;
1858 /* Return the attribute from a general expression. */
1861 gfc_expr_attr (gfc_expr *e)
1863 symbol_attribute attr;
1865 switch (e->expr_type)
1868 attr = gfc_variable_attr (e, NULL);
1872 gfc_clear_attr (&attr);
1874 if (e->value.function.esym != NULL)
1875 attr = e->value.function.esym->result->attr;
1877 /* TODO: NULL() returns pointers. May have to take care of this
1883 gfc_clear_attr (&attr);
1891 /* Match a structure constructor. The initial symbol has already been
1895 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
1897 gfc_constructor *head, *tail;
1898 gfc_component *comp;
1905 if (gfc_match_char ('(') != MATCH_YES)
1908 where = gfc_current_locus;
1910 gfc_find_component (sym, NULL);
1912 for (comp = sym->components; comp; comp = comp->next)
1915 tail = head = gfc_get_constructor ();
1918 tail->next = gfc_get_constructor ();
1922 m = gfc_match_expr (&tail->expr);
1925 if (m == MATCH_ERROR)
1928 if (gfc_match_char (',') == MATCH_YES)
1930 if (comp->next == NULL)
1932 gfc_error ("Too many components in structure constructor at %C");
1942 if (gfc_match_char (')') != MATCH_YES)
1945 if (comp->next != NULL)
1947 gfc_error ("Too few components in structure constructor at %C");
1951 e = gfc_get_expr ();
1953 e->expr_type = EXPR_STRUCTURE;
1955 e->ts.type = BT_DERIVED;
1956 e->ts.derived = sym;
1959 e->value.constructor = head;
1965 gfc_error ("Syntax error in structure constructor at %C");
1968 gfc_free_constructor (head);
1973 /* Matches a variable name followed by anything that might follow it--
1974 array reference, argument list of a function, etc. */
1977 gfc_match_rvalue (gfc_expr **result)
1979 gfc_actual_arglist *actual_arglist;
1980 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1983 gfc_symtree *symtree;
1984 locus where, old_loc;
1991 m = gfc_match_name (name);
1995 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
1996 && !gfc_current_ns->has_import_set)
1997 i = gfc_get_sym_tree (name, NULL, &symtree);
1999 i = gfc_get_ha_sym_tree (name, &symtree);
2004 sym = symtree->n.sym;
2006 where = gfc_current_locus;
2008 gfc_set_sym_referenced (sym);
2010 if (sym->attr.function && sym->result == sym)
2012 /* See if this is a directly recursive function call. */
2013 gfc_gobble_whitespace ();
2014 if (sym->attr.recursive
2015 && gfc_peek_char () == '('
2016 && gfc_current_ns->proc_name == sym)
2018 if (!sym->attr.dimension)
2021 gfc_error ("'%s' is array valued and directly recursive "
2022 "at %C , so the keyword RESULT must be specified "
2023 "in the FUNCTION statement", sym->name);
2027 if (gfc_current_ns->proc_name == sym
2028 || (gfc_current_ns->parent != NULL
2029 && gfc_current_ns->parent->proc_name == sym))
2033 && (sym->ns == gfc_current_ns
2034 || sym->ns == gfc_current_ns->parent))
2036 gfc_entry_list *el = NULL;
2038 for (el = sym->ns->entries; el; el = el->next)
2044 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2047 if (sym->attr.generic)
2048 goto generic_function;
2050 switch (sym->attr.flavor)
2054 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
2055 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2056 gfc_set_default_type (sym, 0, sym->ns);
2058 e = gfc_get_expr ();
2060 e->expr_type = EXPR_VARIABLE;
2061 e->symtree = symtree;
2063 m = match_varspec (e, 0);
2067 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2068 end up here. Unfortunately, sym->value->expr_type is set to
2069 EXPR_CONSTANT, and so the if () branch would be followed without
2070 the !sym->as check. */
2071 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2072 e = gfc_copy_expr (sym->value);
2075 e = gfc_get_expr ();
2076 e->expr_type = EXPR_VARIABLE;
2079 e->symtree = symtree;
2080 m = match_varspec (e, 0);
2084 sym = gfc_use_derived (sym);
2088 m = gfc_match_structure_constructor (sym, &e);
2091 /* If we're here, then the name is known to be the name of a
2092 procedure, yet it is not sure to be the name of a function. */
2094 if (sym->attr.subroutine)
2096 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2102 /* At this point, the name has to be a non-statement function.
2103 If the name is the same as the current function being
2104 compiled, then we have a variable reference (to the function
2105 result) if the name is non-recursive. */
2107 st = gfc_enclosing_unit (NULL);
2109 if (st != NULL && st->state == COMP_FUNCTION
2111 && !sym->attr.recursive)
2113 e = gfc_get_expr ();
2114 e->symtree = symtree;
2115 e->expr_type = EXPR_VARIABLE;
2117 m = match_varspec (e, 0);
2121 /* Match a function reference. */
2123 m = gfc_match_actual_arglist (0, &actual_arglist);
2126 if (sym->attr.proc == PROC_ST_FUNCTION)
2127 gfc_error ("Statement function '%s' requires argument list at %C",
2130 gfc_error ("Function '%s' requires an argument list at %C",
2143 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2144 sym = symtree->n.sym;
2146 e = gfc_get_expr ();
2147 e->symtree = symtree;
2148 e->expr_type = EXPR_FUNCTION;
2149 e->value.function.actual = actual_arglist;
2150 e->where = gfc_current_locus;
2152 if (sym->as != NULL)
2153 e->rank = sym->as->rank;
2155 if (!sym->attr.function
2156 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2162 if (sym->result == NULL)
2170 /* Special case for derived type variables that get their types
2171 via an IMPLICIT statement. This can't wait for the
2172 resolution phase. */
2174 if (gfc_peek_char () == '%'
2175 && sym->ts.type == BT_UNKNOWN
2176 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2177 gfc_set_default_type (sym, 0, sym->ns);
2179 /* If the symbol has a dimension attribute, the expression is a
2182 if (sym->attr.dimension)
2184 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2185 sym->name, NULL) == FAILURE)
2191 e = gfc_get_expr ();
2192 e->symtree = symtree;
2193 e->expr_type = EXPR_VARIABLE;
2194 m = match_varspec (e, 0);
2198 /* Name is not an array, so we peek to see if a '(' implies a
2199 function call or a substring reference. Otherwise the
2200 variable is just a scalar. */
2202 gfc_gobble_whitespace ();
2203 if (gfc_peek_char () != '(')
2205 /* Assume a scalar variable */
2206 e = gfc_get_expr ();
2207 e->symtree = symtree;
2208 e->expr_type = EXPR_VARIABLE;
2210 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2211 sym->name, NULL) == FAILURE)
2218 m = match_varspec (e, 0);
2222 /* See if this is a function reference with a keyword argument
2223 as first argument. We do this because otherwise a spurious
2224 symbol would end up in the symbol table. */
2226 old_loc = gfc_current_locus;
2227 m2 = gfc_match (" ( %n =", argname);
2228 gfc_current_locus = old_loc;
2230 e = gfc_get_expr ();
2231 e->symtree = symtree;
2233 if (m2 != MATCH_YES)
2235 /* Try to figure out whether we're dealing with a character type.
2236 We're peeking ahead here, because we don't want to call
2237 match_substring if we're dealing with an implicitly typed
2238 non-character variable. */
2239 implicit_char = false;
2240 if (sym->ts.type == BT_UNKNOWN)
2242 ts = gfc_get_default_type (sym,NULL);
2243 if (ts->type == BT_CHARACTER)
2244 implicit_char = true;
2247 /* See if this could possibly be a substring reference of a name
2248 that we're not sure is a variable yet. */
2250 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2251 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2254 e->expr_type = EXPR_VARIABLE;
2256 if (sym->attr.flavor != FL_VARIABLE
2257 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2258 sym->name, NULL) == FAILURE)
2264 if (sym->ts.type == BT_UNKNOWN
2265 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2279 /* Give up, assume we have a function. */
2281 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2282 sym = symtree->n.sym;
2283 e->expr_type = EXPR_FUNCTION;
2285 if (!sym->attr.function
2286 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2294 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2296 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2304 /* If our new function returns a character, array or structure
2305 type, it might have subsequent references. */
2307 m = match_varspec (e, 0);
2314 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2316 e = gfc_get_expr ();
2317 e->symtree = symtree;
2318 e->expr_type = EXPR_FUNCTION;
2320 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2324 gfc_error ("Symbol at %C is not appropriate for an expression");
2340 /* Match a variable, ie something that can be assigned to. This
2341 starts as a symbol, can be a structure component or an array
2342 reference. It can be a function if the function doesn't have a
2343 separate RESULT variable. If the symbol has not been previously
2344 seen, we assume it is a variable.
2346 This function is called by two interface functions:
2347 gfc_match_variable, which has host_flag = 1, and
2348 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2349 match of the symbol to the local scope. */
2352 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2360 /* Since nothing has any business being an lvalue in a module
2361 specification block, an interface block or a contains section,
2362 we force the changed_symbols mechanism to work by setting
2363 host_flag to 0. This prevents valid symbols that have the name
2364 of keywords, such as 'end', being turned into variables by
2365 failed matching to assignments for, eg., END INTERFACE. */
2366 if (gfc_current_state () == COMP_MODULE
2367 || gfc_current_state () == COMP_INTERFACE
2368 || gfc_current_state () == COMP_CONTAINS)
2371 m = gfc_match_sym_tree (&st, host_flag);
2374 where = gfc_current_locus;
2377 gfc_set_sym_referenced (sym);
2378 switch (sym->attr.flavor)
2381 if (sym->attr.protected && sym->attr.use_assoc)
2383 gfc_error ("Assigning to PROTECTED variable at %C");
2389 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2390 sym->name, NULL) == FAILURE)
2396 gfc_error ("Named constant at %C in an EQUIVALENCE");
2398 gfc_error ("Cannot assign to a named constant at %C");
2403 /* Check for a nonrecursive function result */
2404 if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2406 /* If a function result is a derived type, then the derived
2407 type may still have to be resolved. */
2409 if (sym->ts.type == BT_DERIVED
2410 && gfc_use_derived (sym->ts.derived) == NULL)
2415 /* Fall through to error */
2418 gfc_error ("Expected VARIABLE at %C");
2422 /* Special case for derived type variables that get their types
2423 via an IMPLICIT statement. This can't wait for the
2424 resolution phase. */
2427 gfc_namespace * implicit_ns;
2429 if (gfc_current_ns->proc_name == sym)
2430 implicit_ns = gfc_current_ns;
2432 implicit_ns = sym->ns;
2434 if (gfc_peek_char () == '%'
2435 && sym->ts.type == BT_UNKNOWN
2436 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2437 gfc_set_default_type (sym, 0, implicit_ns);
2440 expr = gfc_get_expr ();
2442 expr->expr_type = EXPR_VARIABLE;
2445 expr->where = where;
2447 /* Now see if we have to do more. */
2448 m = match_varspec (expr, equiv_flag);
2451 gfc_free_expr (expr);
2461 gfc_match_variable (gfc_expr **result, int equiv_flag)
2463 return match_variable (result, equiv_flag, 1);
2468 gfc_match_equiv_variable (gfc_expr **result)
2470 return match_variable (result, 1, 0);