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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
30 /* Matches a kind-parameter expression, which is either a named
31 symbolic constant or a nonnegative integer constant. If
32 successful, sets the kind value to the correct integer. */
35 match_kind_param (int *kind)
37 char name[GFC_MAX_SYMBOL_LEN + 1];
42 m = gfc_match_small_literal_int (kind, NULL);
46 m = gfc_match_name (name);
50 if (gfc_find_symbol (name, NULL, 1, &sym))
56 if (sym->attr.flavor != FL_PARAMETER)
59 p = gfc_extract_int (sym->value, kind);
70 /* Get a trailing kind-specification for non-character variables.
72 the integer kind value or:
73 -1 if an error was generated
74 -2 if no kind was found */
82 if (gfc_match_char ('_') != MATCH_YES)
85 m = match_kind_param (&kind);
87 gfc_error ("Missing kind-parameter at %C");
89 return (m == MATCH_YES) ? kind : -1;
93 /* Given a character and a radix, see if the character is a valid
94 digit in that radix. */
97 check_digit (int c, int radix)
104 r = ('0' <= c && c <= '1');
108 r = ('0' <= c && c <= '7');
112 r = ('0' <= c && c <= '9');
120 gfc_internal_error ("check_digit(): bad radix");
127 /* Match the digit string part of an integer if signflag is not set,
128 the signed digit string part if signflag is set. If the buffer
129 is NULL, we just count characters for the resolution pass. Returns
130 the number of characters matched, -1 for no match. */
133 match_digits (int signflag, int radix, char *buffer)
139 c = gfc_next_char ();
141 if (signflag && (c == '+' || c == '-'))
145 gfc_gobble_whitespace ();
146 c = gfc_next_char ();
150 if (!check_digit (c, radix))
159 old_loc = gfc_current_locus;
160 c = gfc_next_char ();
162 if (!check_digit (c, radix))
170 gfc_current_locus = old_loc;
176 /* Match an integer (digit string and optional kind).
177 A sign will be accepted if signflag is set. */
180 match_integer_constant (gfc_expr **result, int signflag)
187 old_loc = gfc_current_locus;
188 gfc_gobble_whitespace ();
190 length = match_digits (signflag, 10, NULL);
191 gfc_current_locus = old_loc;
195 buffer = alloca (length + 1);
196 memset (buffer, '\0', length + 1);
198 gfc_gobble_whitespace ();
200 match_digits (signflag, 10, buffer);
204 kind = gfc_default_integer_kind;
208 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
210 gfc_error ("Integer kind %d at %C not available", kind);
214 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
216 if (gfc_range_check (e) != ARITH_OK)
218 gfc_error ("Integer too big for its kind at %C. This check can be "
219 "disabled with the option -fno-range-check");
230 /* Match a Hollerith constant. */
233 match_hollerith_constant (gfc_expr **result)
241 old_loc = gfc_current_locus;
242 gfc_gobble_whitespace ();
244 if (match_integer_constant (&e, 0) == MATCH_YES
245 && gfc_match_char ('h') == MATCH_YES)
247 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
251 msg = gfc_extract_int (e, &num);
259 gfc_error ("Invalid Hollerith constant: %L must contain at least "
260 "one character", &old_loc);
263 if (e->ts.kind != gfc_default_integer_kind)
265 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
266 "should be default", &old_loc);
272 e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
275 e->representation.string = gfc_getmem (num + 1);
276 for (i = 0; i < num; i++)
278 e->representation.string[i] = gfc_next_char_literal (1);
280 e->representation.string[num] = '\0';
281 e->representation.length = num;
289 gfc_current_locus = old_loc;
298 /* Match a binary, octal or hexadecimal constant that can be found in
299 a DATA statement. The standard permits b'010...', o'73...', and
300 z'a1...' where b, o, and z can be capital letters. This function
301 also accepts postfixed forms of the constants: '01...'b, '73...'o,
302 and 'a1...'z. An additional extension is the use of x for z. */
305 match_boz_constant (gfc_expr **result)
307 int post, radix, delim, length, x_hex, kind;
308 locus old_loc, start_loc;
312 start_loc = old_loc = gfc_current_locus;
313 gfc_gobble_whitespace ();
316 switch (post = gfc_next_char ())
338 radix = 16; /* Set to accept any valid digit string. */
344 /* No whitespace allowed here. */
347 delim = gfc_next_char ();
349 if (delim != '\'' && delim != '\"')
353 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
354 "constant at %C uses non-standard syntax")
358 old_loc = gfc_current_locus;
360 length = match_digits (0, radix, NULL);
363 gfc_error ("Empty set of digits in BOZ constant at %C");
367 if (gfc_next_char () != delim)
369 gfc_error ("Illegal character in BOZ constant at %C");
375 switch (gfc_next_char ())
392 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
393 "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 /* Mark as boz variable. */
421 if (gfc_range_check (e) != ARITH_OK)
423 gfc_error ("Integer too big for integer kind %i at %C", kind);
428 if (!gfc_in_match_data ()
429 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
438 gfc_current_locus = start_loc;
443 /* Match a real constant of some sort. Allow a signed constant if signflag
447 match_real_constant (gfc_expr **result, int signflag)
449 int kind, c, count, seen_dp, seen_digits, exp_char;
450 locus old_loc, temp_loc;
455 old_loc = gfc_current_locus;
456 gfc_gobble_whitespace ();
466 c = gfc_next_char ();
467 if (signflag && (c == '+' || c == '-'))
472 gfc_gobble_whitespace ();
473 c = gfc_next_char ();
476 /* Scan significand. */
477 for (;; c = gfc_next_char (), count++)
484 /* Check to see if "." goes with a following operator like
486 temp_loc = gfc_current_locus;
487 c = gfc_next_char ();
489 if (c == 'e' || c == 'd' || c == 'q')
491 c = gfc_next_char ();
493 goto done; /* Operator named .e. or .d. */
497 goto done; /* Distinguish 1.e9 from 1.eq.2 */
499 gfc_current_locus = temp_loc;
513 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
518 c = gfc_next_char ();
521 if (c == '+' || c == '-')
522 { /* optional sign */
523 c = gfc_next_char ();
529 gfc_error ("Missing exponent in real number at %C");
535 c = gfc_next_char ();
540 /* Check that we have a numeric constant. */
541 if (!seen_digits || (!seen_dp && exp_char == ' '))
543 gfc_current_locus = old_loc;
547 /* Convert the number. */
548 gfc_current_locus = old_loc;
549 gfc_gobble_whitespace ();
551 buffer = alloca (count + 1);
552 memset (buffer, '\0', count + 1);
555 c = gfc_next_char ();
556 if (c == '+' || c == '-')
558 gfc_gobble_whitespace ();
559 c = gfc_next_char ();
562 /* Hack for mpfr_set_str(). */
565 if (c == 'd' || c == 'q')
573 c = gfc_next_char ();
585 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
589 kind = gfc_default_double_kind;
594 kind = gfc_default_real_kind;
596 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
598 gfc_error ("Invalid real kind %d at %C", kind);
603 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
605 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
607 switch (gfc_range_check (e))
612 gfc_error ("Real constant overflows its kind at %C");
615 case ARITH_UNDERFLOW:
616 if (gfc_option.warn_underflow)
617 gfc_warning ("Real constant underflows its kind at %C");
618 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
622 gfc_internal_error ("gfc_range_check() returned bad value");
634 /* Match a substring reference. */
637 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
639 gfc_expr *start, *end;
647 old_loc = gfc_current_locus;
649 m = gfc_match_char ('(');
653 if (gfc_match_char (':') != MATCH_YES)
656 m = gfc_match_init_expr (&start);
658 m = gfc_match_expr (&start);
666 m = gfc_match_char (':');
671 if (gfc_match_char (')') != MATCH_YES)
674 m = gfc_match_init_expr (&end);
676 m = gfc_match_expr (&end);
680 if (m == MATCH_ERROR)
683 m = gfc_match_char (')');
688 /* Optimize away the (:) reference. */
689 if (start == NULL && end == NULL)
693 ref = gfc_get_ref ();
695 ref->type = REF_SUBSTRING;
697 start = gfc_int_expr (1);
698 ref->u.ss.start = start;
699 if (end == NULL && cl)
700 end = gfc_copy_expr (cl->length);
702 ref->u.ss.length = cl;
709 gfc_error ("Syntax error in SUBSTRING specification at %C");
713 gfc_free_expr (start);
716 gfc_current_locus = old_loc;
721 /* Reads the next character of a string constant, taking care to
722 return doubled delimiters on the input as a single instance of
725 Special return values are:
726 -1 End of the string, as determined by the delimiter
727 -2 Unterminated string detected
729 Backslash codes are also expanded at this time. */
732 next_string_char (char delimiter)
737 c = gfc_next_char_literal (1);
742 if (gfc_option.flag_backslash && c == '\\')
744 old_locus = gfc_current_locus;
746 if (gfc_match_special_char (&c) == MATCH_NO)
747 gfc_current_locus = old_locus;
749 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
750 gfc_warning ("Extension: backslash character at %C");
756 old_locus = gfc_current_locus;
757 c = gfc_next_char_literal (0);
761 gfc_current_locus = old_locus;
767 /* Special case of gfc_match_name() that matches a parameter kind name
768 before a string constant. This takes case of the weird but legal
773 where kind____ is a parameter. gfc_match_name() will happily slurp
774 up all the underscores, which leads to problems. If we return
775 MATCH_YES, the parse pointer points to the final underscore, which
776 is not part of the name. We never return MATCH_ERROR-- errors in
777 the name will be detected later. */
780 match_charkind_name (char *name)
786 gfc_gobble_whitespace ();
787 c = gfc_next_char ();
796 old_loc = gfc_current_locus;
797 c = gfc_next_char ();
801 peek = gfc_peek_char ();
803 if (peek == '\'' || peek == '\"')
805 gfc_current_locus = old_loc;
813 && (gfc_option.flag_dollar_ok && c != '$'))
817 if (++len > GFC_MAX_SYMBOL_LEN)
825 /* See if the current input matches a character constant. Lots of
826 contortions have to be done to match the kind parameter which comes
827 before the actual string. The main consideration is that we don't
828 want to error out too quickly. For example, we don't actually do
829 any validation of the kinds until we have actually seen a legal
830 delimiter. Using match_kind_param() generates errors too quickly. */
833 match_string_constant (gfc_expr **result)
835 char *p, name[GFC_MAX_SYMBOL_LEN + 1];
836 int i, c, kind, length, delimiter, warn_ampersand;
837 locus old_locus, start_locus;
843 old_locus = gfc_current_locus;
845 gfc_gobble_whitespace ();
847 start_locus = gfc_current_locus;
849 c = gfc_next_char ();
850 if (c == '\'' || c == '"')
852 kind = gfc_default_character_kind;
862 kind = kind * 10 + c - '0';
865 c = gfc_next_char ();
871 gfc_current_locus = old_locus;
873 m = match_charkind_name (name);
877 if (gfc_find_symbol (name, NULL, 1, &sym)
879 || sym->attr.flavor != FL_PARAMETER)
883 c = gfc_next_char ();
888 gfc_gobble_whitespace ();
889 c = gfc_next_char ();
895 gfc_gobble_whitespace ();
896 start_locus = gfc_current_locus;
898 c = gfc_next_char ();
899 if (c != '\'' && c != '"')
904 q = gfc_extract_int (sym->value, &kind);
912 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
914 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
919 /* Scan the string into a block of memory by first figuring out how
920 long it is, allocating the structure, then re-reading it. This
921 isn't particularly efficient, but string constants aren't that
922 common in most code. TODO: Use obstacks? */
929 c = next_string_char (delimiter);
934 gfc_current_locus = start_locus;
935 gfc_error ("Unterminated character constant beginning at %C");
942 /* Peek at the next character to see if it is a b, o, z, or x for the
943 postfixed BOZ literal constants. */
944 c = gfc_peek_char ();
945 if (c == 'b' || c == 'o' || c =='z' || c == 'x')
951 e->expr_type = EXPR_CONSTANT;
953 e->ts.type = BT_CHARACTER;
955 e->ts.is_c_interop = 0;
957 e->where = start_locus;
959 e->value.character.string = p = gfc_getmem (length + 1);
960 e->value.character.length = length;
962 gfc_current_locus = start_locus;
963 gfc_next_char (); /* Skip delimiter */
965 /* We disable the warning for the following loop as the warning has already
966 been printed in the loop above. */
967 warn_ampersand = gfc_option.warn_ampersand;
968 gfc_option.warn_ampersand = 0;
970 for (i = 0; i < length; i++)
971 *p++ = next_string_char (delimiter);
973 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
974 gfc_option.warn_ampersand = warn_ampersand;
976 if (next_string_char (delimiter) != -1)
977 gfc_internal_error ("match_string_constant(): Delimiter not found");
979 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
980 e->expr_type = EXPR_SUBSTRING;
987 gfc_current_locus = old_locus;
992 /* Match a .true. or .false. Returns 1 if a .true. was found,
993 0 if a .false. was found, and -1 otherwise. */
995 match_logical_constant_string (void)
997 locus orig_loc = gfc_current_locus;
999 gfc_gobble_whitespace ();
1000 if (gfc_next_char () == '.')
1002 int ch = gfc_next_char();
1005 if (gfc_next_char () == 'a'
1006 && gfc_next_char () == 'l'
1007 && gfc_next_char () == 's'
1008 && gfc_next_char () == 'e'
1009 && gfc_next_char () == '.')
1010 /* Matched ".false.". */
1015 if (gfc_next_char () == 'r'
1016 && gfc_next_char () == 'u'
1017 && gfc_next_char () == 'e'
1018 && gfc_next_char () == '.')
1019 /* Matched ".true.". */
1023 gfc_current_locus = orig_loc;
1027 /* Match a .true. or .false. */
1030 match_logical_constant (gfc_expr **result)
1035 i = match_logical_constant_string ();
1043 kind = gfc_default_logical_kind;
1045 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1047 gfc_error ("Bad kind for logical constant at %C");
1051 e = gfc_get_expr ();
1053 e->expr_type = EXPR_CONSTANT;
1054 e->value.logical = i;
1055 e->ts.type = BT_LOGICAL;
1057 e->ts.is_c_interop = 0;
1059 e->where = gfc_current_locus;
1066 /* Match a real or imaginary part of a complex constant that is a
1067 symbolic constant. */
1070 match_sym_complex_part (gfc_expr **result)
1072 char name[GFC_MAX_SYMBOL_LEN + 1];
1077 m = gfc_match_name (name);
1081 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1084 if (sym->attr.flavor != FL_PARAMETER)
1086 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1090 if (!gfc_numeric_ts (&sym->value->ts))
1092 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1096 if (sym->value->rank != 0)
1098 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1102 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1103 "complex constant at %C") == FAILURE)
1106 switch (sym->value->ts.type)
1109 e = gfc_copy_expr (sym->value);
1113 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1119 e = gfc_int2real (sym->value, gfc_default_real_kind);
1125 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1128 *result = e; /* e is a scalar, real, constant expression. */
1132 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1137 /* Match a real or imaginary part of a complex number. */
1140 match_complex_part (gfc_expr **result)
1144 m = match_sym_complex_part (result);
1148 m = match_real_constant (result, 1);
1152 return match_integer_constant (result, 1);
1156 /* Try to match a complex constant. */
1159 match_complex_constant (gfc_expr **result)
1161 gfc_expr *e, *real, *imag;
1162 gfc_error_buf old_error;
1163 gfc_typespec target;
1168 old_loc = gfc_current_locus;
1169 real = imag = e = NULL;
1171 m = gfc_match_char ('(');
1175 gfc_push_error (&old_error);
1177 m = match_complex_part (&real);
1180 gfc_free_error (&old_error);
1184 if (gfc_match_char (',') == MATCH_NO)
1186 gfc_pop_error (&old_error);
1191 /* If m is error, then something was wrong with the real part and we
1192 assume we have a complex constant because we've seen the ','. An
1193 ambiguous case here is the start of an iterator list of some
1194 sort. These sort of lists are matched prior to coming here. */
1196 if (m == MATCH_ERROR)
1198 gfc_free_error (&old_error);
1201 gfc_pop_error (&old_error);
1203 m = match_complex_part (&imag);
1206 if (m == MATCH_ERROR)
1209 m = gfc_match_char (')');
1212 /* Give the matcher for implied do-loops a chance to run. This
1213 yields a much saner error message for (/ (i, 4=i, 6) /). */
1214 if (gfc_peek_char () == '=')
1223 if (m == MATCH_ERROR)
1226 /* Decide on the kind of this complex number. */
1227 if (real->ts.type == BT_REAL)
1229 if (imag->ts.type == BT_REAL)
1230 kind = gfc_kind_max (real, imag);
1232 kind = real->ts.kind;
1236 if (imag->ts.type == BT_REAL)
1237 kind = imag->ts.kind;
1239 kind = gfc_default_real_kind;
1241 target.type = BT_REAL;
1243 target.is_c_interop = 0;
1244 target.is_iso_c = 0;
1246 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1247 gfc_convert_type (real, &target, 2);
1248 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1249 gfc_convert_type (imag, &target, 2);
1251 e = gfc_convert_complex (real, imag, kind);
1252 e->where = gfc_current_locus;
1254 gfc_free_expr (real);
1255 gfc_free_expr (imag);
1261 gfc_error ("Syntax error in COMPLEX constant at %C");
1266 gfc_free_expr (real);
1267 gfc_free_expr (imag);
1268 gfc_current_locus = old_loc;
1274 /* Match constants in any of several forms. Returns nonzero for a
1275 match, zero for no match. */
1278 gfc_match_literal_constant (gfc_expr **result, int signflag)
1282 m = match_complex_constant (result);
1286 m = match_string_constant (result);
1290 m = match_boz_constant (result);
1294 m = match_real_constant (result, signflag);
1298 m = match_hollerith_constant (result);
1302 m = match_integer_constant (result, signflag);
1306 m = match_logical_constant (result);
1314 /* Match a single actual argument value. An actual argument is
1315 usually an expression, but can also be a procedure name. If the
1316 argument is a single name, it is not always possible to tell
1317 whether the name is a dummy procedure or not. We treat these cases
1318 by creating an argument that looks like a dummy procedure and
1319 fixing things later during resolution. */
1322 match_actual_arg (gfc_expr **result)
1324 char name[GFC_MAX_SYMBOL_LEN + 1];
1325 gfc_symtree *symtree;
1330 where = gfc_current_locus;
1332 switch (gfc_match_name (name))
1341 w = gfc_current_locus;
1342 gfc_gobble_whitespace ();
1343 c = gfc_next_char ();
1344 gfc_current_locus = w;
1346 if (c != ',' && c != ')')
1349 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1351 /* Handle error elsewhere. */
1353 /* Eliminate a couple of common cases where we know we don't
1354 have a function argument. */
1355 if (symtree == NULL)
1357 gfc_get_sym_tree (name, NULL, &symtree);
1358 gfc_set_sym_referenced (symtree->n.sym);
1364 sym = symtree->n.sym;
1365 gfc_set_sym_referenced (sym);
1366 if (sym->attr.flavor != FL_PROCEDURE
1367 && sym->attr.flavor != FL_UNKNOWN)
1370 /* If the symbol is a function with itself as the result and
1371 is being defined, then we have a variable. */
1372 if (sym->attr.function && sym->result == sym)
1374 if (gfc_current_ns->proc_name == sym
1375 || (gfc_current_ns->parent != NULL
1376 && gfc_current_ns->parent->proc_name == sym))
1380 && (sym->ns == gfc_current_ns
1381 || sym->ns == gfc_current_ns->parent))
1383 gfc_entry_list *el = NULL;
1385 for (el = sym->ns->entries; el; el = el->next)
1395 e = gfc_get_expr (); /* Leave it unknown for now */
1396 e->symtree = symtree;
1397 e->expr_type = EXPR_VARIABLE;
1398 e->ts.type = BT_PROCEDURE;
1405 gfc_current_locus = where;
1406 return gfc_match_expr (result);
1410 /* Match a keyword argument. */
1413 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1415 char name[GFC_MAX_SYMBOL_LEN + 1];
1416 gfc_actual_arglist *a;
1420 name_locus = gfc_current_locus;
1421 m = gfc_match_name (name);
1425 if (gfc_match_char ('=') != MATCH_YES)
1431 m = match_actual_arg (&actual->expr);
1435 /* Make sure this name has not appeared yet. */
1437 if (name[0] != '\0')
1439 for (a = base; a; a = a->next)
1440 if (a->name != NULL && strcmp (a->name, name) == 0)
1442 gfc_error ("Keyword '%s' at %C has already appeared in the "
1443 "current argument list", name);
1448 actual->name = gfc_get_string (name);
1452 gfc_current_locus = name_locus;
1457 /* Match an argument list function, such as %VAL. */
1460 match_arg_list_function (gfc_actual_arglist *result)
1462 char name[GFC_MAX_SYMBOL_LEN + 1];
1466 old_locus = gfc_current_locus;
1468 if (gfc_match_char ('%') != MATCH_YES)
1474 m = gfc_match ("%n (", name);
1478 if (name[0] != '\0')
1483 if (strncmp (name, "loc", 3) == 0)
1485 result->name = "%LOC";
1489 if (strncmp (name, "ref", 3) == 0)
1491 result->name = "%REF";
1495 if (strncmp (name, "val", 3) == 0)
1497 result->name = "%VAL";
1506 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1507 "function at %C") == FAILURE)
1513 m = match_actual_arg (&result->expr);
1517 if (gfc_match_char (')') != MATCH_YES)
1526 gfc_current_locus = old_locus;
1531 /* Matches an actual argument list of a function or subroutine, from
1532 the opening parenthesis to the closing parenthesis. The argument
1533 list is assumed to allow keyword arguments because we don't know if
1534 the symbol associated with the procedure has an implicit interface
1535 or not. We make sure keywords are unique. If sub_flag is set,
1536 we're matching the argument list of a subroutine. */
1539 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1541 gfc_actual_arglist *head, *tail;
1543 gfc_st_label *label;
1547 *argp = tail = NULL;
1548 old_loc = gfc_current_locus;
1552 if (gfc_match_char ('(') == MATCH_NO)
1553 return (sub_flag) ? MATCH_YES : MATCH_NO;
1555 if (gfc_match_char (')') == MATCH_YES)
1562 head = tail = gfc_get_actual_arglist ();
1565 tail->next = gfc_get_actual_arglist ();
1569 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1571 m = gfc_match_st_label (&label);
1573 gfc_error ("Expected alternate return label at %C");
1577 tail->label = label;
1581 /* After the first keyword argument is seen, the following
1582 arguments must also have keywords. */
1585 m = match_keyword_arg (tail, head);
1587 if (m == MATCH_ERROR)
1591 gfc_error ("Missing keyword name in actual argument list at %C");
1598 /* Try an argument list function, like %VAL. */
1599 m = match_arg_list_function (tail);
1600 if (m == MATCH_ERROR)
1603 /* See if we have the first keyword argument. */
1606 m = match_keyword_arg (tail, head);
1609 if (m == MATCH_ERROR)
1615 /* Try for a non-keyword argument. */
1616 m = match_actual_arg (&tail->expr);
1617 if (m == MATCH_ERROR)
1626 if (gfc_match_char (')') == MATCH_YES)
1628 if (gfc_match_char (',') != MATCH_YES)
1636 gfc_error ("Syntax error in argument list at %C");
1639 gfc_free_actual_arglist (head);
1640 gfc_current_locus = old_loc;
1646 /* Used by match_varspec() to extend the reference list by one
1650 extend_ref (gfc_expr *primary, gfc_ref *tail)
1652 if (primary->ref == NULL)
1653 primary->ref = tail = gfc_get_ref ();
1657 gfc_internal_error ("extend_ref(): Bad tail");
1658 tail->next = gfc_get_ref ();
1666 /* Match any additional specifications associated with the current
1667 variable like member references or substrings. If equiv_flag is
1668 set we only match stuff that is allowed inside an EQUIVALENCE
1672 match_varspec (gfc_expr *primary, int equiv_flag)
1674 char name[GFC_MAX_SYMBOL_LEN + 1];
1675 gfc_ref *substring, *tail;
1676 gfc_component *component;
1677 gfc_symbol *sym = primary->symtree->n.sym;
1683 gfc_gobble_whitespace ();
1684 if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
1686 /* In EQUIVALENCE, we don't know yet whether we are seeing
1687 an array, character variable or array of character
1688 variables. We'll leave the decision till resolve time. */
1689 tail = extend_ref (primary, tail);
1690 tail->type = REF_ARRAY;
1692 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1697 gfc_gobble_whitespace ();
1698 if (equiv_flag && gfc_peek_char () == '(')
1700 tail = extend_ref (primary, tail);
1701 tail->type = REF_ARRAY;
1703 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1709 primary->ts = sym->ts;
1714 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1715 goto check_substring;
1717 sym = sym->ts.derived;
1721 m = gfc_match_name (name);
1723 gfc_error ("Expected structure component name at %C");
1727 component = gfc_find_component (sym, name);
1728 if (component == NULL)
1731 tail = extend_ref (primary, tail);
1732 tail->type = REF_COMPONENT;
1734 tail->u.c.component = component;
1735 tail->u.c.sym = sym;
1737 primary->ts = component->ts;
1739 if (component->as != NULL)
1741 tail = extend_ref (primary, tail);
1742 tail->type = REF_ARRAY;
1744 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1749 if (component->ts.type != BT_DERIVED
1750 || gfc_match_char ('%') != MATCH_YES)
1753 sym = component->ts.derived;
1758 if (primary->ts.type == BT_UNKNOWN)
1760 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1762 gfc_set_default_type (sym, 0, sym->ns);
1763 primary->ts = sym->ts;
1768 if (primary->ts.type == BT_CHARACTER)
1770 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1774 primary->ref = substring;
1776 tail->next = substring;
1778 if (primary->expr_type == EXPR_CONSTANT)
1779 primary->expr_type = EXPR_SUBSTRING;
1782 primary->ts.cl = NULL;
1788 gfc_clear_ts (&primary->ts);
1800 /* Given an expression that is a variable, figure out what the
1801 ultimate variable's type and attribute is, traversing the reference
1802 structures if necessary.
1804 This subroutine is trickier than it looks. We start at the base
1805 symbol and store the attribute. Component references load a
1806 completely new attribute.
1808 A couple of rules come into play. Subobjects of targets are always
1809 targets themselves. If we see a component that goes through a
1810 pointer, then the expression must also be a target, since the
1811 pointer is associated with something (if it isn't core will soon be
1812 dumped). If we see a full part or section of an array, the
1813 expression is also an array.
1815 We can have at most one full array reference. */
1818 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1820 int dimension, pointer, allocatable, target;
1821 symbol_attribute attr;
1824 if (expr->expr_type != EXPR_VARIABLE)
1825 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1828 attr = expr->symtree->n.sym->attr;
1830 dimension = attr.dimension;
1831 pointer = attr.pointer;
1832 allocatable = attr.allocatable;
1834 target = attr.target;
1838 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1839 *ts = expr->symtree->n.sym->ts;
1841 for (; ref; ref = ref->next)
1846 switch (ref->u.ar.type)
1853 allocatable = pointer = 0;
1858 allocatable = pointer = 0;
1862 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1868 gfc_get_component_attr (&attr, ref->u.c.component);
1871 *ts = ref->u.c.component->ts;
1872 /* Don't set the string length if a substring reference
1874 if (ts->type == BT_CHARACTER
1875 && ref->next && ref->next->type == REF_SUBSTRING)
1879 pointer = ref->u.c.component->pointer;
1880 allocatable = ref->u.c.component->allocatable;
1887 allocatable = pointer = 0;
1891 attr.dimension = dimension;
1892 attr.pointer = pointer;
1893 attr.allocatable = allocatable;
1894 attr.target = target;
1900 /* Return the attribute from a general expression. */
1903 gfc_expr_attr (gfc_expr *e)
1905 symbol_attribute attr;
1907 switch (e->expr_type)
1910 attr = gfc_variable_attr (e, NULL);
1914 gfc_clear_attr (&attr);
1916 if (e->value.function.esym != NULL)
1917 attr = e->value.function.esym->result->attr;
1919 /* TODO: NULL() returns pointers. May have to take care of this
1925 gfc_clear_attr (&attr);
1933 /* Match a structure constructor. The initial symbol has already been
1937 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
1939 gfc_constructor *head, *tail;
1940 gfc_component *comp;
1944 bool private_comp = false;
1948 if (gfc_match_char ('(') != MATCH_YES)
1951 where = gfc_current_locus;
1953 gfc_find_component (sym, NULL);
1955 for (comp = sym->components; comp; comp = comp->next)
1957 if (comp->access == ACCESS_PRIVATE)
1959 private_comp = true;
1963 tail = head = gfc_get_constructor ();
1966 tail->next = gfc_get_constructor ();
1970 m = gfc_match_expr (&tail->expr);
1973 if (m == MATCH_ERROR)
1976 if (gfc_match_char (',') == MATCH_YES)
1978 if (comp->next == NULL)
1980 gfc_error ("Too many components in structure constructor at %C");
1990 if (sym->attr.use_assoc
1991 && (sym->component_access == ACCESS_PRIVATE || private_comp))
1993 gfc_error ("Structure constructor for '%s' at %C has PRIVATE "
1994 "components", sym->name);
1998 if (gfc_match_char (')') != MATCH_YES)
2001 if (comp && comp->next != NULL)
2003 gfc_error ("Too few components in structure constructor at %C");
2007 e = gfc_get_expr ();
2009 e->expr_type = EXPR_STRUCTURE;
2011 e->ts.type = BT_DERIVED;
2012 e->ts.derived = sym;
2015 e->value.constructor = head;
2021 gfc_error ("Syntax error in structure constructor at %C");
2024 gfc_free_constructor (head);
2029 /* If the symbol is an implicit do loop index and implicitly typed,
2030 it should not be host associated. Provide a symtree from the
2031 current namespace. */
2033 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2035 if ((*sym)->attr.flavor == FL_VARIABLE
2036 && (*sym)->ns != gfc_current_ns
2037 && (*sym)->attr.implied_index
2038 && (*sym)->attr.implicit_type
2039 && !(*sym)->attr.use_assoc)
2042 i = gfc_get_sym_tree ((*sym)->name, NULL, st);
2045 *sym = (*st)->n.sym;
2051 /* Matches a variable name followed by anything that might follow it--
2052 array reference, argument list of a function, etc. */
2055 gfc_match_rvalue (gfc_expr **result)
2057 gfc_actual_arglist *actual_arglist;
2058 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2061 gfc_symtree *symtree;
2062 locus where, old_loc;
2070 m = gfc_match_name (name);
2074 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2075 && !gfc_current_ns->has_import_set)
2076 i = gfc_get_sym_tree (name, NULL, &symtree);
2078 i = gfc_get_ha_sym_tree (name, &symtree);
2083 sym = symtree->n.sym;
2085 where = gfc_current_locus;
2087 /* If this is an implicit do loop index and implicitly typed,
2088 it should not be host associated. */
2089 m = check_for_implicit_index (&symtree, &sym);
2093 gfc_set_sym_referenced (sym);
2094 sym->attr.implied_index = 0;
2096 if (sym->attr.function && sym->result == sym)
2098 /* See if this is a directly recursive function call. */
2099 gfc_gobble_whitespace ();
2100 if (sym->attr.recursive
2101 && gfc_peek_char () == '('
2102 && gfc_current_ns->proc_name == sym
2103 && !sym->attr.dimension)
2105 gfc_error ("'%s' at %C is the name of a recursive function "
2106 "and so refers to the result variable. Use an "
2107 "explicit RESULT variable for direct recursion "
2108 "(12.5.2.1)", sym->name);
2112 if (gfc_current_ns->proc_name == sym
2113 || (gfc_current_ns->parent != NULL
2114 && gfc_current_ns->parent->proc_name == sym))
2118 && (sym->ns == gfc_current_ns
2119 || sym->ns == gfc_current_ns->parent))
2121 gfc_entry_list *el = NULL;
2123 for (el = sym->ns->entries; el; el = el->next)
2129 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2132 if (sym->attr.generic)
2133 goto generic_function;
2135 switch (sym->attr.flavor)
2139 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
2140 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2141 gfc_set_default_type (sym, 0, sym->ns);
2143 e = gfc_get_expr ();
2145 e->expr_type = EXPR_VARIABLE;
2146 e->symtree = symtree;
2148 m = match_varspec (e, 0);
2152 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2153 end up here. Unfortunately, sym->value->expr_type is set to
2154 EXPR_CONSTANT, and so the if () branch would be followed without
2155 the !sym->as check. */
2156 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2157 e = gfc_copy_expr (sym->value);
2160 e = gfc_get_expr ();
2161 e->expr_type = EXPR_VARIABLE;
2164 e->symtree = symtree;
2165 m = match_varspec (e, 0);
2167 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2170 /* Variable array references to derived type parameters cause
2171 all sorts of headaches in simplification. Treating such
2172 expressions as variable works just fine for all array
2174 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2176 for (ref = e->ref; ref; ref = ref->next)
2177 if (ref->type == REF_ARRAY)
2180 if (ref == NULL || ref->u.ar.type == AR_FULL)
2186 e = gfc_get_expr ();
2187 e->expr_type = EXPR_VARIABLE;
2188 e->symtree = symtree;
2195 sym = gfc_use_derived (sym);
2199 m = gfc_match_structure_constructor (sym, &e);
2202 /* If we're here, then the name is known to be the name of a
2203 procedure, yet it is not sure to be the name of a function. */
2205 if (sym->attr.subroutine)
2207 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2213 /* At this point, the name has to be a non-statement function.
2214 If the name is the same as the current function being
2215 compiled, then we have a variable reference (to the function
2216 result) if the name is non-recursive. */
2218 st = gfc_enclosing_unit (NULL);
2220 if (st != NULL && st->state == COMP_FUNCTION
2222 && !sym->attr.recursive)
2224 e = gfc_get_expr ();
2225 e->symtree = symtree;
2226 e->expr_type = EXPR_VARIABLE;
2228 m = match_varspec (e, 0);
2232 /* Match a function reference. */
2234 m = gfc_match_actual_arglist (0, &actual_arglist);
2237 if (sym->attr.proc == PROC_ST_FUNCTION)
2238 gfc_error ("Statement function '%s' requires argument list at %C",
2241 gfc_error ("Function '%s' requires an argument list at %C",
2254 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2255 sym = symtree->n.sym;
2257 e = gfc_get_expr ();
2258 e->symtree = symtree;
2259 e->expr_type = EXPR_FUNCTION;
2260 e->value.function.actual = actual_arglist;
2261 e->where = gfc_current_locus;
2263 if (sym->as != NULL)
2264 e->rank = sym->as->rank;
2266 if (!sym->attr.function
2267 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2273 /* Check here for the existence of at least one argument for the
2274 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2275 argument(s) given will be checked in gfc_iso_c_func_interface,
2276 during resolution of the function call. */
2277 if (sym->attr.is_iso_c == 1
2278 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2279 && (sym->intmod_sym_id == ISOCBINDING_LOC
2280 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2281 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2283 /* make sure we were given a param */
2284 if (actual_arglist == NULL)
2286 gfc_error ("Missing argument to '%s' at %C", sym->name);
2292 if (sym->result == NULL)
2300 /* Special case for derived type variables that get their types
2301 via an IMPLICIT statement. This can't wait for the
2302 resolution phase. */
2304 if (gfc_peek_char () == '%'
2305 && sym->ts.type == BT_UNKNOWN
2306 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2307 gfc_set_default_type (sym, 0, sym->ns);
2309 /* If the symbol has a dimension attribute, the expression is a
2312 if (sym->attr.dimension)
2314 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2315 sym->name, NULL) == FAILURE)
2321 e = gfc_get_expr ();
2322 e->symtree = symtree;
2323 e->expr_type = EXPR_VARIABLE;
2324 m = match_varspec (e, 0);
2328 /* Name is not an array, so we peek to see if a '(' implies a
2329 function call or a substring reference. Otherwise the
2330 variable is just a scalar. */
2332 gfc_gobble_whitespace ();
2333 if (gfc_peek_char () != '(')
2335 /* Assume a scalar variable */
2336 e = gfc_get_expr ();
2337 e->symtree = symtree;
2338 e->expr_type = EXPR_VARIABLE;
2340 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2341 sym->name, NULL) == FAILURE)
2347 /*FIXME:??? match_varspec does set this for us: */
2349 m = match_varspec (e, 0);
2353 /* See if this is a function reference with a keyword argument
2354 as first argument. We do this because otherwise a spurious
2355 symbol would end up in the symbol table. */
2357 old_loc = gfc_current_locus;
2358 m2 = gfc_match (" ( %n =", argname);
2359 gfc_current_locus = old_loc;
2361 e = gfc_get_expr ();
2362 e->symtree = symtree;
2364 if (m2 != MATCH_YES)
2366 /* Try to figure out whether we're dealing with a character type.
2367 We're peeking ahead here, because we don't want to call
2368 match_substring if we're dealing with an implicitly typed
2369 non-character variable. */
2370 implicit_char = false;
2371 if (sym->ts.type == BT_UNKNOWN)
2373 ts = gfc_get_default_type (sym,NULL);
2374 if (ts->type == BT_CHARACTER)
2375 implicit_char = true;
2378 /* See if this could possibly be a substring reference of a name
2379 that we're not sure is a variable yet. */
2381 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2382 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2385 e->expr_type = EXPR_VARIABLE;
2387 if (sym->attr.flavor != FL_VARIABLE
2388 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2389 sym->name, NULL) == FAILURE)
2395 if (sym->ts.type == BT_UNKNOWN
2396 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2410 /* Give up, assume we have a function. */
2412 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2413 sym = symtree->n.sym;
2414 e->expr_type = EXPR_FUNCTION;
2416 if (!sym->attr.function
2417 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2425 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2427 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2435 /* If our new function returns a character, array or structure
2436 type, it might have subsequent references. */
2438 m = match_varspec (e, 0);
2445 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2447 e = gfc_get_expr ();
2448 e->symtree = symtree;
2449 e->expr_type = EXPR_FUNCTION;
2451 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2455 gfc_error ("Symbol at %C is not appropriate for an expression");
2471 /* Match a variable, ie something that can be assigned to. This
2472 starts as a symbol, can be a structure component or an array
2473 reference. It can be a function if the function doesn't have a
2474 separate RESULT variable. If the symbol has not been previously
2475 seen, we assume it is a variable.
2477 This function is called by two interface functions:
2478 gfc_match_variable, which has host_flag = 1, and
2479 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2480 match of the symbol to the local scope. */
2483 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2491 /* Since nothing has any business being an lvalue in a module
2492 specification block, an interface block or a contains section,
2493 we force the changed_symbols mechanism to work by setting
2494 host_flag to 0. This prevents valid symbols that have the name
2495 of keywords, such as 'end', being turned into variables by
2496 failed matching to assignments for, eg., END INTERFACE. */
2497 if (gfc_current_state () == COMP_MODULE
2498 || gfc_current_state () == COMP_INTERFACE
2499 || gfc_current_state () == COMP_CONTAINS)
2502 m = gfc_match_sym_tree (&st, host_flag);
2505 where = gfc_current_locus;
2509 /* If this is an implicit do loop index and implicitly typed,
2510 it should not be host associated. */
2511 m = check_for_implicit_index (&st, &sym);
2515 sym->attr.implied_index = 0;
2517 gfc_set_sym_referenced (sym);
2518 switch (sym->attr.flavor)
2521 if (sym->attr.protected && sym->attr.use_assoc)
2523 gfc_error ("Assigning to PROTECTED variable at %C");
2530 sym_flavor flavor = FL_UNKNOWN;
2532 gfc_gobble_whitespace ();
2534 if (sym->attr.external || sym->attr.procedure
2535 || sym->attr.function || sym->attr.subroutine)
2536 flavor = FL_PROCEDURE;
2537 else if (gfc_peek_char () != '(' || sym->ts.type != BT_UNKNOWN
2538 || sym->attr.pointer || sym->as != NULL)
2539 flavor = FL_VARIABLE;
2541 if (flavor != FL_UNKNOWN
2542 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
2549 gfc_error ("Named constant at %C in an EQUIVALENCE");
2551 gfc_error ("Cannot assign to a named constant at %C");
2556 /* Check for a nonrecursive function result */
2557 if (sym->attr.function && sym->result == sym && !sym->attr.external)
2559 /* If a function result is a derived type, then the derived
2560 type may still have to be resolved. */
2562 if (sym->ts.type == BT_DERIVED
2563 && gfc_use_derived (sym->ts.derived) == NULL)
2568 /* Fall through to error */
2571 gfc_error ("'%s' at %C is not a variable", sym->name);
2575 /* Special case for derived type variables that get their types
2576 via an IMPLICIT statement. This can't wait for the
2577 resolution phase. */
2580 gfc_namespace * implicit_ns;
2582 if (gfc_current_ns->proc_name == sym)
2583 implicit_ns = gfc_current_ns;
2585 implicit_ns = sym->ns;
2587 if (gfc_peek_char () == '%'
2588 && sym->ts.type == BT_UNKNOWN
2589 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2590 gfc_set_default_type (sym, 0, implicit_ns);
2593 expr = gfc_get_expr ();
2595 expr->expr_type = EXPR_VARIABLE;
2598 expr->where = where;
2600 /* Now see if we have to do more. */
2601 m = match_varspec (expr, equiv_flag);
2604 gfc_free_expr (expr);
2614 gfc_match_variable (gfc_expr **result, int equiv_flag)
2616 return match_variable (result, equiv_flag, 1);
2621 gfc_match_equiv_variable (gfc_expr **result)
2623 return match_variable (result, 1, 0);