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. This check can be "
220 "disabled with the option -fno-range-check");
231 /* Match a Hollerith constant. */
234 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);
273 e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
276 e->representation.string = gfc_getmem (num + 1);
277 for (i = 0; i < num; i++)
279 e->representation.string[i] = gfc_next_char_literal (1);
281 e->representation.string[num] = '\0';
282 e->representation.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 if (gfc_match_special_char (&c) == MATCH_NO)
736 gfc_current_locus = old_locus;
738 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
739 gfc_warning ("Extension: backslash character at %C");
745 old_locus = gfc_current_locus;
746 c = gfc_next_char_literal (0);
750 gfc_current_locus = old_locus;
756 /* Special case of gfc_match_name() that matches a parameter kind name
757 before a string constant. This takes case of the weird but legal
762 where kind____ is a parameter. gfc_match_name() will happily slurp
763 up all the underscores, which leads to problems. If we return
764 MATCH_YES, the parse pointer points to the final underscore, which
765 is not part of the name. We never return MATCH_ERROR-- errors in
766 the name will be detected later. */
769 match_charkind_name (char *name)
775 gfc_gobble_whitespace ();
776 c = gfc_next_char ();
785 old_loc = gfc_current_locus;
786 c = gfc_next_char ();
790 peek = gfc_peek_char ();
792 if (peek == '\'' || peek == '\"')
794 gfc_current_locus = old_loc;
802 && (gfc_option.flag_dollar_ok && c != '$'))
806 if (++len > GFC_MAX_SYMBOL_LEN)
814 /* See if the current input matches a character constant. Lots of
815 contortions have to be done to match the kind parameter which comes
816 before the actual string. The main consideration is that we don't
817 want to error out too quickly. For example, we don't actually do
818 any validation of the kinds until we have actually seen a legal
819 delimiter. Using match_kind_param() generates errors too quickly. */
822 match_string_constant (gfc_expr **result)
824 char *p, name[GFC_MAX_SYMBOL_LEN + 1];
825 int i, c, kind, length, delimiter, warn_ampersand;
826 locus old_locus, start_locus;
832 old_locus = gfc_current_locus;
834 gfc_gobble_whitespace ();
836 start_locus = gfc_current_locus;
838 c = gfc_next_char ();
839 if (c == '\'' || c == '"')
841 kind = gfc_default_character_kind;
851 kind = kind * 10 + c - '0';
854 c = gfc_next_char ();
860 gfc_current_locus = old_locus;
862 m = match_charkind_name (name);
866 if (gfc_find_symbol (name, NULL, 1, &sym)
868 || sym->attr.flavor != FL_PARAMETER)
872 c = gfc_next_char ();
877 gfc_gobble_whitespace ();
878 c = gfc_next_char ();
884 gfc_gobble_whitespace ();
885 start_locus = gfc_current_locus;
887 c = gfc_next_char ();
888 if (c != '\'' && c != '"')
893 q = gfc_extract_int (sym->value, &kind);
901 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
903 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
908 /* Scan the string into a block of memory by first figuring out how
909 long it is, allocating the structure, then re-reading it. This
910 isn't particularly efficient, but string constants aren't that
911 common in most code. TODO: Use obstacks? */
918 c = next_string_char (delimiter);
923 gfc_current_locus = start_locus;
924 gfc_error ("Unterminated character constant beginning at %C");
931 /* Peek at the next character to see if it is a b, o, z, or x for the
932 postfixed BOZ literal constants. */
933 c = gfc_peek_char ();
934 if (c == 'b' || c == 'o' || c =='z' || c == 'x')
940 e->expr_type = EXPR_CONSTANT;
942 e->ts.type = BT_CHARACTER;
944 e->where = start_locus;
946 e->value.character.string = p = gfc_getmem (length + 1);
947 e->value.character.length = length;
949 gfc_current_locus = start_locus;
950 gfc_next_char (); /* Skip delimiter */
952 /* We disable the warning for the following loop as the warning has already
953 been printed in the loop above. */
954 warn_ampersand = gfc_option.warn_ampersand;
955 gfc_option.warn_ampersand = 0;
957 for (i = 0; i < length; i++)
958 *p++ = next_string_char (delimiter);
960 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
961 gfc_option.warn_ampersand = warn_ampersand;
963 if (next_string_char (delimiter) != -1)
964 gfc_internal_error ("match_string_constant(): Delimiter not found");
966 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
967 e->expr_type = EXPR_SUBSTRING;
974 gfc_current_locus = old_locus;
979 /* Match a .true. or .false. */
982 match_logical_constant (gfc_expr **result)
984 static mstring logical_ops[] = {
985 minit (".false.", 0),
993 i = gfc_match_strings (logical_ops);
1001 kind = gfc_default_logical_kind;
1003 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1005 gfc_error ("Bad kind for logical constant at %C");
1009 e = gfc_get_expr ();
1011 e->expr_type = EXPR_CONSTANT;
1012 e->value.logical = i;
1013 e->ts.type = BT_LOGICAL;
1015 e->where = gfc_current_locus;
1022 /* Match a real or imaginary part of a complex constant that is a
1023 symbolic constant. */
1026 match_sym_complex_part (gfc_expr **result)
1028 char name[GFC_MAX_SYMBOL_LEN + 1];
1033 m = gfc_match_name (name);
1037 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1040 if (sym->attr.flavor != FL_PARAMETER)
1042 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1046 if (!gfc_numeric_ts (&sym->value->ts))
1048 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1052 if (sym->value->rank != 0)
1054 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1058 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1059 "complex constant at %C") == FAILURE)
1062 switch (sym->value->ts.type)
1065 e = gfc_copy_expr (sym->value);
1069 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1075 e = gfc_int2real (sym->value, gfc_default_real_kind);
1081 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1084 *result = e; /* e is a scalar, real, constant expression. */
1088 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1093 /* Match a real or imaginary part of a complex number. */
1096 match_complex_part (gfc_expr **result)
1100 m = match_sym_complex_part (result);
1104 m = match_real_constant (result, 1);
1108 return match_integer_constant (result, 1);
1112 /* Try to match a complex constant. */
1115 match_complex_constant (gfc_expr **result)
1117 gfc_expr *e, *real, *imag;
1118 gfc_error_buf old_error;
1119 gfc_typespec target;
1124 old_loc = gfc_current_locus;
1125 real = imag = e = NULL;
1127 m = gfc_match_char ('(');
1131 gfc_push_error (&old_error);
1133 m = match_complex_part (&real);
1136 gfc_free_error (&old_error);
1140 if (gfc_match_char (',') == MATCH_NO)
1142 gfc_pop_error (&old_error);
1147 /* If m is error, then something was wrong with the real part and we
1148 assume we have a complex constant because we've seen the ','. An
1149 ambiguous case here is the start of an iterator list of some
1150 sort. These sort of lists are matched prior to coming here. */
1152 if (m == MATCH_ERROR)
1154 gfc_free_error (&old_error);
1157 gfc_pop_error (&old_error);
1159 m = match_complex_part (&imag);
1162 if (m == MATCH_ERROR)
1165 m = gfc_match_char (')');
1168 /* Give the matcher for implied do-loops a chance to run. This
1169 yields a much saner error message for (/ (i, 4=i, 6) /). */
1170 if (gfc_peek_char () == '=')
1179 if (m == MATCH_ERROR)
1182 /* Decide on the kind of this complex number. */
1183 if (real->ts.type == BT_REAL)
1185 if (imag->ts.type == BT_REAL)
1186 kind = gfc_kind_max (real, imag);
1188 kind = real->ts.kind;
1192 if (imag->ts.type == BT_REAL)
1193 kind = imag->ts.kind;
1195 kind = gfc_default_real_kind;
1197 target.type = BT_REAL;
1200 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1201 gfc_convert_type (real, &target, 2);
1202 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1203 gfc_convert_type (imag, &target, 2);
1205 e = gfc_convert_complex (real, imag, kind);
1206 e->where = gfc_current_locus;
1208 gfc_free_expr (real);
1209 gfc_free_expr (imag);
1215 gfc_error ("Syntax error in COMPLEX constant at %C");
1220 gfc_free_expr (real);
1221 gfc_free_expr (imag);
1222 gfc_current_locus = old_loc;
1228 /* Match constants in any of several forms. Returns nonzero for a
1229 match, zero for no match. */
1232 gfc_match_literal_constant (gfc_expr **result, int signflag)
1236 m = match_complex_constant (result);
1240 m = match_string_constant (result);
1244 m = match_boz_constant (result);
1248 m = match_real_constant (result, signflag);
1252 m = match_hollerith_constant (result);
1256 m = match_integer_constant (result, signflag);
1260 m = match_logical_constant (result);
1268 /* Match a single actual argument value. An actual argument is
1269 usually an expression, but can also be a procedure name. If the
1270 argument is a single name, it is not always possible to tell
1271 whether the name is a dummy procedure or not. We treat these cases
1272 by creating an argument that looks like a dummy procedure and
1273 fixing things later during resolution. */
1276 match_actual_arg (gfc_expr **result)
1278 char name[GFC_MAX_SYMBOL_LEN + 1];
1279 gfc_symtree *symtree;
1284 where = gfc_current_locus;
1286 switch (gfc_match_name (name))
1295 w = gfc_current_locus;
1296 gfc_gobble_whitespace ();
1297 c = gfc_next_char ();
1298 gfc_current_locus = w;
1300 if (c != ',' && c != ')')
1303 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1305 /* Handle error elsewhere. */
1307 /* Eliminate a couple of common cases where we know we don't
1308 have a function argument. */
1309 if (symtree == NULL)
1311 gfc_get_sym_tree (name, NULL, &symtree);
1312 gfc_set_sym_referenced (symtree->n.sym);
1318 sym = symtree->n.sym;
1319 gfc_set_sym_referenced (sym);
1320 if (sym->attr.flavor != FL_PROCEDURE
1321 && sym->attr.flavor != FL_UNKNOWN)
1324 /* If the symbol is a function with itself as the result and
1325 is being defined, then we have a variable. */
1326 if (sym->attr.function && sym->result == sym)
1328 if (gfc_current_ns->proc_name == sym
1329 || (gfc_current_ns->parent != NULL
1330 && gfc_current_ns->parent->proc_name == sym))
1334 && (sym->ns == gfc_current_ns
1335 || sym->ns == gfc_current_ns->parent))
1337 gfc_entry_list *el = NULL;
1339 for (el = sym->ns->entries; el; el = el->next)
1349 e = gfc_get_expr (); /* Leave it unknown for now */
1350 e->symtree = symtree;
1351 e->expr_type = EXPR_VARIABLE;
1352 e->ts.type = BT_PROCEDURE;
1359 gfc_current_locus = where;
1360 return gfc_match_expr (result);
1364 /* Match a keyword argument. */
1367 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1369 char name[GFC_MAX_SYMBOL_LEN + 1];
1370 gfc_actual_arglist *a;
1374 name_locus = gfc_current_locus;
1375 m = gfc_match_name (name);
1379 if (gfc_match_char ('=') != MATCH_YES)
1385 m = match_actual_arg (&actual->expr);
1389 /* Make sure this name has not appeared yet. */
1391 if (name[0] != '\0')
1393 for (a = base; a; a = a->next)
1394 if (a->name != NULL && strcmp (a->name, name) == 0)
1396 gfc_error ("Keyword '%s' at %C has already appeared in the "
1397 "current argument list", name);
1402 actual->name = gfc_get_string (name);
1406 gfc_current_locus = name_locus;
1411 /* Match an argument list function, such as %VAL. */
1414 match_arg_list_function (gfc_actual_arglist *result)
1416 char name[GFC_MAX_SYMBOL_LEN + 1];
1420 old_locus = gfc_current_locus;
1422 if (gfc_match_char ('%') != MATCH_YES)
1428 m = gfc_match ("%n (", name);
1432 if (name[0] != '\0')
1437 if (strncmp (name, "loc", 3) == 0)
1439 result->name = "%LOC";
1443 if (strncmp (name, "ref", 3) == 0)
1445 result->name = "%REF";
1449 if (strncmp (name, "val", 3) == 0)
1451 result->name = "%VAL";
1460 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1461 "function at %C") == FAILURE)
1467 m = match_actual_arg (&result->expr);
1471 if (gfc_match_char (')') != MATCH_YES)
1480 gfc_current_locus = old_locus;
1485 /* Matches an actual argument list of a function or subroutine, from
1486 the opening parenthesis to the closing parenthesis. The argument
1487 list is assumed to allow keyword arguments because we don't know if
1488 the symbol associated with the procedure has an implicit interface
1489 or not. We make sure keywords are unique. If sub_flag is set,
1490 we're matching the argument list of a subroutine. */
1493 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1495 gfc_actual_arglist *head, *tail;
1497 gfc_st_label *label;
1501 *argp = tail = NULL;
1502 old_loc = gfc_current_locus;
1506 if (gfc_match_char ('(') == MATCH_NO)
1507 return (sub_flag) ? MATCH_YES : MATCH_NO;
1509 if (gfc_match_char (')') == MATCH_YES)
1516 head = tail = gfc_get_actual_arglist ();
1519 tail->next = gfc_get_actual_arglist ();
1523 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1525 m = gfc_match_st_label (&label);
1527 gfc_error ("Expected alternate return label at %C");
1531 tail->label = label;
1535 /* After the first keyword argument is seen, the following
1536 arguments must also have keywords. */
1539 m = match_keyword_arg (tail, head);
1541 if (m == MATCH_ERROR)
1545 gfc_error ("Missing keyword name in actual argument list at %C");
1552 /* Try an argument list function, like %VAL. */
1553 m = match_arg_list_function (tail);
1554 if (m == MATCH_ERROR)
1557 /* See if we have the first keyword argument. */
1560 m = match_keyword_arg (tail, head);
1563 if (m == MATCH_ERROR)
1569 /* Try for a non-keyword argument. */
1570 m = match_actual_arg (&tail->expr);
1571 if (m == MATCH_ERROR)
1580 if (gfc_match_char (')') == MATCH_YES)
1582 if (gfc_match_char (',') != MATCH_YES)
1590 gfc_error ("Syntax error in argument list at %C");
1593 gfc_free_actual_arglist (head);
1594 gfc_current_locus = old_loc;
1600 /* Used by match_varspec() to extend the reference list by one
1604 extend_ref (gfc_expr *primary, gfc_ref *tail)
1606 if (primary->ref == NULL)
1607 primary->ref = tail = gfc_get_ref ();
1611 gfc_internal_error ("extend_ref(): Bad tail");
1612 tail->next = gfc_get_ref ();
1620 /* Match any additional specifications associated with the current
1621 variable like member references or substrings. If equiv_flag is
1622 set we only match stuff that is allowed inside an EQUIVALENCE
1626 match_varspec (gfc_expr *primary, int equiv_flag)
1628 char name[GFC_MAX_SYMBOL_LEN + 1];
1629 gfc_ref *substring, *tail;
1630 gfc_component *component;
1631 gfc_symbol *sym = primary->symtree->n.sym;
1636 if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
1638 /* In EQUIVALENCE, we don't know yet whether we are seeing
1639 an array, character variable or array of character
1640 variables. We'll leave the decision till resolve time. */
1641 tail = extend_ref (primary, tail);
1642 tail->type = REF_ARRAY;
1644 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1649 if (equiv_flag && gfc_peek_char () == '(')
1651 tail = extend_ref (primary, tail);
1652 tail->type = REF_ARRAY;
1654 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1660 primary->ts = sym->ts;
1665 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1666 goto check_substring;
1668 sym = sym->ts.derived;
1672 m = gfc_match_name (name);
1674 gfc_error ("Expected structure component name at %C");
1678 component = gfc_find_component (sym, name);
1679 if (component == NULL)
1682 tail = extend_ref (primary, tail);
1683 tail->type = REF_COMPONENT;
1685 tail->u.c.component = component;
1686 tail->u.c.sym = sym;
1688 primary->ts = component->ts;
1690 if (component->as != NULL)
1692 tail = extend_ref (primary, tail);
1693 tail->type = REF_ARRAY;
1695 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1700 if (component->ts.type != BT_DERIVED
1701 || gfc_match_char ('%') != MATCH_YES)
1704 sym = component->ts.derived;
1708 if (primary->ts.type == BT_UNKNOWN)
1710 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1712 gfc_set_default_type (sym, 0, sym->ns);
1713 primary->ts = sym->ts;
1717 if (primary->ts.type == BT_CHARACTER)
1719 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1723 primary->ref = substring;
1725 tail->next = substring;
1727 if (primary->expr_type == EXPR_CONSTANT)
1728 primary->expr_type = EXPR_SUBSTRING;
1731 primary->ts.cl = NULL;
1747 /* Given an expression that is a variable, figure out what the
1748 ultimate variable's type and attribute is, traversing the reference
1749 structures if necessary.
1751 This subroutine is trickier than it looks. We start at the base
1752 symbol and store the attribute. Component references load a
1753 completely new attribute.
1755 A couple of rules come into play. Subobjects of targets are always
1756 targets themselves. If we see a component that goes through a
1757 pointer, then the expression must also be a target, since the
1758 pointer is associated with something (if it isn't core will soon be
1759 dumped). If we see a full part or section of an array, the
1760 expression is also an array.
1762 We can have at most one full array reference. */
1765 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1767 int dimension, pointer, allocatable, target;
1768 symbol_attribute attr;
1771 if (expr->expr_type != EXPR_VARIABLE)
1772 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1775 attr = expr->symtree->n.sym->attr;
1777 dimension = attr.dimension;
1778 pointer = attr.pointer;
1779 allocatable = attr.allocatable;
1781 target = attr.target;
1785 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1786 *ts = expr->symtree->n.sym->ts;
1788 for (; ref; ref = ref->next)
1793 switch (ref->u.ar.type)
1800 allocatable = pointer = 0;
1805 allocatable = pointer = 0;
1809 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1815 gfc_get_component_attr (&attr, ref->u.c.component);
1818 *ts = ref->u.c.component->ts;
1819 /* Don't set the string length if a substring reference
1821 if (ts->type == BT_CHARACTER
1822 && ref->next && ref->next->type == REF_SUBSTRING)
1826 pointer = ref->u.c.component->pointer;
1827 allocatable = ref->u.c.component->allocatable;
1834 allocatable = pointer = 0;
1838 attr.dimension = dimension;
1839 attr.pointer = pointer;
1840 attr.allocatable = allocatable;
1841 attr.target = target;
1847 /* Return the attribute from a general expression. */
1850 gfc_expr_attr (gfc_expr *e)
1852 symbol_attribute attr;
1854 switch (e->expr_type)
1857 attr = gfc_variable_attr (e, NULL);
1861 gfc_clear_attr (&attr);
1863 if (e->value.function.esym != NULL)
1864 attr = e->value.function.esym->result->attr;
1866 /* TODO: NULL() returns pointers. May have to take care of this
1872 gfc_clear_attr (&attr);
1880 /* Match a structure constructor. The initial symbol has already been
1884 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
1886 gfc_constructor *head, *tail;
1887 gfc_component *comp;
1891 bool private_comp = false;
1895 if (gfc_match_char ('(') != MATCH_YES)
1898 where = gfc_current_locus;
1900 gfc_find_component (sym, NULL);
1902 for (comp = sym->components; comp; comp = comp->next)
1904 if (comp->access == ACCESS_PRIVATE)
1906 private_comp = true;
1910 tail = head = gfc_get_constructor ();
1913 tail->next = gfc_get_constructor ();
1917 m = gfc_match_expr (&tail->expr);
1920 if (m == MATCH_ERROR)
1923 if (gfc_match_char (',') == MATCH_YES)
1925 if (comp->next == NULL)
1927 gfc_error ("Too many components in structure constructor at %C");
1937 if (sym->attr.use_assoc
1938 && (sym->component_access == ACCESS_PRIVATE || private_comp))
1940 gfc_error ("Structure constructor for '%s' at %C has PRIVATE "
1941 "components", sym->name);
1945 if (gfc_match_char (')') != MATCH_YES)
1948 if (comp->next != NULL)
1950 gfc_error ("Too few components in structure constructor at %C");
1954 e = gfc_get_expr ();
1956 e->expr_type = EXPR_STRUCTURE;
1958 e->ts.type = BT_DERIVED;
1959 e->ts.derived = sym;
1962 e->value.constructor = head;
1968 gfc_error ("Syntax error in structure constructor at %C");
1971 gfc_free_constructor (head);
1976 /* If the symbol is an implicit do loop index and implicitly typed,
1977 it should not be host associated. Provide a symtree from the
1978 current namespace. */
1980 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
1982 if ((*sym)->attr.flavor == FL_VARIABLE
1983 && (*sym)->ns != gfc_current_ns
1984 && (*sym)->attr.implied_index
1985 && (*sym)->attr.implicit_type
1986 && !(*sym)->attr.use_assoc)
1989 i = gfc_get_sym_tree ((*sym)->name, NULL, st);
1992 *sym = (*st)->n.sym;
1998 /* Matches a variable name followed by anything that might follow it--
1999 array reference, argument list of a function, etc. */
2002 gfc_match_rvalue (gfc_expr **result)
2004 gfc_actual_arglist *actual_arglist;
2005 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2008 gfc_symtree *symtree;
2009 locus where, old_loc;
2016 m = gfc_match_name (name);
2020 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2021 && !gfc_current_ns->has_import_set)
2022 i = gfc_get_sym_tree (name, NULL, &symtree);
2024 i = gfc_get_ha_sym_tree (name, &symtree);
2029 sym = symtree->n.sym;
2031 where = gfc_current_locus;
2033 /* If this is an implicit do loop index and implicitly typed,
2034 it should not be host associated. */
2035 m = check_for_implicit_index (&symtree, &sym);
2039 gfc_set_sym_referenced (sym);
2040 sym->attr.implied_index = 0;
2042 if (sym->attr.function && sym->result == sym)
2044 /* See if this is a directly recursive function call. */
2045 gfc_gobble_whitespace ();
2046 if (sym->attr.recursive
2047 && gfc_peek_char () == '('
2048 && gfc_current_ns->proc_name == sym
2049 && !sym->attr.dimension)
2051 gfc_error ("'%s' at %C is the name of a recursive function "
2052 "and so refers to the result variable. Use an "
2053 "explicit RESULT variable for direct recursion "
2054 "(12.5.2.1)", sym->name);
2058 if (gfc_current_ns->proc_name == sym
2059 || (gfc_current_ns->parent != NULL
2060 && gfc_current_ns->parent->proc_name == sym))
2064 && (sym->ns == gfc_current_ns
2065 || sym->ns == gfc_current_ns->parent))
2067 gfc_entry_list *el = NULL;
2069 for (el = sym->ns->entries; el; el = el->next)
2075 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2078 if (sym->attr.generic)
2079 goto generic_function;
2081 switch (sym->attr.flavor)
2085 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
2086 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2087 gfc_set_default_type (sym, 0, sym->ns);
2089 e = gfc_get_expr ();
2091 e->expr_type = EXPR_VARIABLE;
2092 e->symtree = symtree;
2094 m = match_varspec (e, 0);
2098 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2099 end up here. Unfortunately, sym->value->expr_type is set to
2100 EXPR_CONSTANT, and so the if () branch would be followed without
2101 the !sym->as check. */
2102 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2103 e = gfc_copy_expr (sym->value);
2106 e = gfc_get_expr ();
2107 e->expr_type = EXPR_VARIABLE;
2110 e->symtree = symtree;
2111 m = match_varspec (e, 0);
2115 sym = gfc_use_derived (sym);
2119 m = gfc_match_structure_constructor (sym, &e);
2122 /* If we're here, then the name is known to be the name of a
2123 procedure, yet it is not sure to be the name of a function. */
2125 if (sym->attr.subroutine)
2127 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2133 /* At this point, the name has to be a non-statement function.
2134 If the name is the same as the current function being
2135 compiled, then we have a variable reference (to the function
2136 result) if the name is non-recursive. */
2138 st = gfc_enclosing_unit (NULL);
2140 if (st != NULL && st->state == COMP_FUNCTION
2142 && !sym->attr.recursive)
2144 e = gfc_get_expr ();
2145 e->symtree = symtree;
2146 e->expr_type = EXPR_VARIABLE;
2148 m = match_varspec (e, 0);
2152 /* Match a function reference. */
2154 m = gfc_match_actual_arglist (0, &actual_arglist);
2157 if (sym->attr.proc == PROC_ST_FUNCTION)
2158 gfc_error ("Statement function '%s' requires argument list at %C",
2161 gfc_error ("Function '%s' requires an argument list at %C",
2174 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2175 sym = symtree->n.sym;
2177 e = gfc_get_expr ();
2178 e->symtree = symtree;
2179 e->expr_type = EXPR_FUNCTION;
2180 e->value.function.actual = actual_arglist;
2181 e->where = gfc_current_locus;
2183 if (sym->as != NULL)
2184 e->rank = sym->as->rank;
2186 if (!sym->attr.function
2187 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2193 if (sym->result == NULL)
2201 /* Special case for derived type variables that get their types
2202 via an IMPLICIT statement. This can't wait for the
2203 resolution phase. */
2205 if (gfc_peek_char () == '%'
2206 && sym->ts.type == BT_UNKNOWN
2207 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2208 gfc_set_default_type (sym, 0, sym->ns);
2210 /* If the symbol has a dimension attribute, the expression is a
2213 if (sym->attr.dimension)
2215 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2216 sym->name, NULL) == FAILURE)
2222 e = gfc_get_expr ();
2223 e->symtree = symtree;
2224 e->expr_type = EXPR_VARIABLE;
2225 m = match_varspec (e, 0);
2229 /* Name is not an array, so we peek to see if a '(' implies a
2230 function call or a substring reference. Otherwise the
2231 variable is just a scalar. */
2233 gfc_gobble_whitespace ();
2234 if (gfc_peek_char () != '(')
2236 /* Assume a scalar variable */
2237 e = gfc_get_expr ();
2238 e->symtree = symtree;
2239 e->expr_type = EXPR_VARIABLE;
2241 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2242 sym->name, NULL) == FAILURE)
2248 /*FIXME:??? match_varspec does set this for us: */
2250 m = match_varspec (e, 0);
2254 /* See if this is a function reference with a keyword argument
2255 as first argument. We do this because otherwise a spurious
2256 symbol would end up in the symbol table. */
2258 old_loc = gfc_current_locus;
2259 m2 = gfc_match (" ( %n =", argname);
2260 gfc_current_locus = old_loc;
2262 e = gfc_get_expr ();
2263 e->symtree = symtree;
2265 if (m2 != MATCH_YES)
2267 /* Try to figure out whether we're dealing with a character type.
2268 We're peeking ahead here, because we don't want to call
2269 match_substring if we're dealing with an implicitly typed
2270 non-character variable. */
2271 implicit_char = false;
2272 if (sym->ts.type == BT_UNKNOWN)
2274 ts = gfc_get_default_type (sym,NULL);
2275 if (ts->type == BT_CHARACTER)
2276 implicit_char = true;
2279 /* See if this could possibly be a substring reference of a name
2280 that we're not sure is a variable yet. */
2282 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2283 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2286 e->expr_type = EXPR_VARIABLE;
2288 if (sym->attr.flavor != FL_VARIABLE
2289 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2290 sym->name, NULL) == FAILURE)
2296 if (sym->ts.type == BT_UNKNOWN
2297 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2311 /* Give up, assume we have a function. */
2313 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2314 sym = symtree->n.sym;
2315 e->expr_type = EXPR_FUNCTION;
2317 if (!sym->attr.function
2318 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2326 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2328 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2336 /* If our new function returns a character, array or structure
2337 type, it might have subsequent references. */
2339 m = match_varspec (e, 0);
2346 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2348 e = gfc_get_expr ();
2349 e->symtree = symtree;
2350 e->expr_type = EXPR_FUNCTION;
2352 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2356 gfc_error ("Symbol at %C is not appropriate for an expression");
2372 /* Match a variable, ie something that can be assigned to. This
2373 starts as a symbol, can be a structure component or an array
2374 reference. It can be a function if the function doesn't have a
2375 separate RESULT variable. If the symbol has not been previously
2376 seen, we assume it is a variable.
2378 This function is called by two interface functions:
2379 gfc_match_variable, which has host_flag = 1, and
2380 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2381 match of the symbol to the local scope. */
2384 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2392 /* Since nothing has any business being an lvalue in a module
2393 specification block, an interface block or a contains section,
2394 we force the changed_symbols mechanism to work by setting
2395 host_flag to 0. This prevents valid symbols that have the name
2396 of keywords, such as 'end', being turned into variables by
2397 failed matching to assignments for, eg., END INTERFACE. */
2398 if (gfc_current_state () == COMP_MODULE
2399 || gfc_current_state () == COMP_INTERFACE
2400 || gfc_current_state () == COMP_CONTAINS)
2403 m = gfc_match_sym_tree (&st, host_flag);
2406 where = gfc_current_locus;
2410 /* If this is an implicit do loop index and implicitly typed,
2411 it should not be host associated. */
2412 m = check_for_implicit_index (&st, &sym);
2416 sym->attr.implied_index = 0;
2418 gfc_set_sym_referenced (sym);
2419 switch (sym->attr.flavor)
2422 if (sym->attr.protected && sym->attr.use_assoc)
2424 gfc_error ("Assigning to PROTECTED variable at %C");
2430 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2431 sym->name, NULL) == FAILURE)
2437 gfc_error ("Named constant at %C in an EQUIVALENCE");
2439 gfc_error ("Cannot assign to a named constant at %C");
2444 /* Check for a nonrecursive function result */
2445 if (sym->attr.function && (sym->result == sym || sym->attr.entry)
2446 && !sym->attr.external)
2448 /* If a function result is a derived type, then the derived
2449 type may still have to be resolved. */
2451 if (sym->ts.type == BT_DERIVED
2452 && gfc_use_derived (sym->ts.derived) == NULL)
2457 /* Fall through to error */
2460 gfc_error ("Expected VARIABLE at %C");
2464 /* Special case for derived type variables that get their types
2465 via an IMPLICIT statement. This can't wait for the
2466 resolution phase. */
2469 gfc_namespace * implicit_ns;
2471 if (gfc_current_ns->proc_name == sym)
2472 implicit_ns = gfc_current_ns;
2474 implicit_ns = sym->ns;
2476 if (gfc_peek_char () == '%'
2477 && sym->ts.type == BT_UNKNOWN
2478 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2479 gfc_set_default_type (sym, 0, implicit_ns);
2482 expr = gfc_get_expr ();
2484 expr->expr_type = EXPR_VARIABLE;
2487 expr->where = where;
2489 /* Now see if we have to do more. */
2490 m = match_varspec (expr, equiv_flag);
2493 gfc_free_expr (expr);
2503 gfc_match_variable (gfc_expr **result, int equiv_flag)
2505 return match_variable (result, equiv_flag, 1);
2510 gfc_match_equiv_variable (gfc_expr **result)
2512 return match_variable (result, 1, 0);