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
;
768 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
769 gfc_warning ("Extension: backslash character at %C");
775 old_locus
= gfc_current_locus
;
776 c
= gfc_next_char_literal (0);
780 gfc_current_locus
= old_locus
;
786 /* Special case of gfc_match_name() that matches a parameter kind name
787 before a string constant. This takes case of the weird but legal
792 where kind____ is a parameter. gfc_match_name() will happily slurp
793 up all the underscores, which leads to problems. If we return
794 MATCH_YES, the parse pointer points to the final underscore, which
795 is not part of the name. We never return MATCH_ERROR-- errors in
796 the name will be detected later. */
799 match_charkind_name (char *name
)
805 gfc_gobble_whitespace ();
806 c
= gfc_next_char ();
815 old_loc
= gfc_current_locus
;
816 c
= gfc_next_char ();
820 peek
= gfc_peek_char ();
822 if (peek
== '\'' || peek
== '\"')
824 gfc_current_locus
= old_loc
;
832 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
836 if (++len
> GFC_MAX_SYMBOL_LEN
)
844 /* See if the current input matches a character constant. Lots of
845 contortions have to be done to match the kind parameter which comes
846 before the actual string. The main consideration is that we don't
847 want to error out too quickly. For example, we don't actually do
848 any validation of the kinds until we have actually seen a legal
849 delimiter. Using match_kind_param() generates errors too quickly. */
852 match_string_constant (gfc_expr
**result
)
854 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
855 int i
, c
, kind
, length
, delimiter
, warn_ampersand
;
856 locus old_locus
, start_locus
;
862 old_locus
= gfc_current_locus
;
864 gfc_gobble_whitespace ();
866 start_locus
= gfc_current_locus
;
868 c
= gfc_next_char ();
869 if (c
== '\'' || c
== '"')
871 kind
= gfc_default_character_kind
;
881 kind
= kind
* 10 + c
- '0';
884 c
= gfc_next_char ();
890 gfc_current_locus
= old_locus
;
892 m
= match_charkind_name (name
);
896 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
898 || sym
->attr
.flavor
!= FL_PARAMETER
)
902 c
= gfc_next_char ();
907 gfc_gobble_whitespace ();
908 c
= gfc_next_char ();
914 gfc_gobble_whitespace ();
915 start_locus
= gfc_current_locus
;
917 c
= gfc_next_char ();
918 if (c
!= '\'' && c
!= '"')
923 q
= gfc_extract_int (sym
->value
, &kind
);
931 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
933 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
938 /* Scan the string into a block of memory by first figuring out how
939 long it is, allocating the structure, then re-reading it. This
940 isn't particularly efficient, but string constants aren't that
941 common in most code. TODO: Use obstacks? */
948 c
= next_string_char (delimiter
);
953 gfc_current_locus
= start_locus
;
954 gfc_error ("Unterminated character constant beginning at %C");
961 /* Peek at the next character to see if it is a b, o, z, or x for the
962 postfixed BOZ literal constants. */
963 c
= gfc_peek_char ();
964 if (c
== 'b' || c
== 'o' || c
=='z' || c
== 'x')
970 e
->expr_type
= EXPR_CONSTANT
;
972 e
->ts
.type
= BT_CHARACTER
;
974 e
->where
= start_locus
;
976 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
977 e
->value
.character
.length
= length
;
979 gfc_current_locus
= start_locus
;
980 gfc_next_char (); /* Skip delimiter */
982 /* We disable the warning for the following loop as the warning has already
983 been printed in the loop above. */
984 warn_ampersand
= gfc_option
.warn_ampersand
;
985 gfc_option
.warn_ampersand
= 0;
987 for (i
= 0; i
< length
; i
++)
988 *p
++ = next_string_char (delimiter
);
990 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
991 gfc_option
.warn_ampersand
= warn_ampersand
;
993 if (next_string_char (delimiter
) != -1)
994 gfc_internal_error ("match_string_constant(): Delimiter not found");
996 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
997 e
->expr_type
= EXPR_SUBSTRING
;
1004 gfc_current_locus
= old_locus
;
1009 /* Match a .true. or .false. */
1012 match_logical_constant (gfc_expr
**result
)
1014 static mstring logical_ops
[] = {
1015 minit (".false.", 0),
1016 minit (".true.", 1),
1023 i
= gfc_match_strings (logical_ops
);
1031 kind
= gfc_default_logical_kind
;
1033 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1035 gfc_error ("Bad kind for logical constant at %C");
1039 e
= gfc_get_expr ();
1041 e
->expr_type
= EXPR_CONSTANT
;
1042 e
->value
.logical
= i
;
1043 e
->ts
.type
= BT_LOGICAL
;
1045 e
->where
= gfc_current_locus
;
1052 /* Match a real or imaginary part of a complex constant that is a
1053 symbolic constant. */
1056 match_sym_complex_part (gfc_expr
**result
)
1058 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1063 m
= gfc_match_name (name
);
1067 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1070 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1072 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1076 if (!gfc_numeric_ts (&sym
->value
->ts
))
1078 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1082 if (sym
->value
->rank
!= 0)
1084 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1088 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PARAMETER symbol in "
1089 "complex constant at %C") == FAILURE
)
1092 switch (sym
->value
->ts
.type
)
1095 e
= gfc_copy_expr (sym
->value
);
1099 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1105 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1111 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1114 *result
= e
; /* e is a scalar, real, constant expression. */
1118 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1123 /* Match a real or imaginary part of a complex number. */
1126 match_complex_part (gfc_expr
**result
)
1130 m
= match_sym_complex_part (result
);
1134 m
= match_real_constant (result
, 1);
1138 return match_integer_constant (result
, 1);
1142 /* Try to match a complex constant. */
1145 match_complex_constant (gfc_expr
**result
)
1147 gfc_expr
*e
, *real
, *imag
;
1148 gfc_error_buf old_error
;
1149 gfc_typespec target
;
1154 old_loc
= gfc_current_locus
;
1155 real
= imag
= e
= NULL
;
1157 m
= gfc_match_char ('(');
1161 gfc_push_error (&old_error
);
1163 m
= match_complex_part (&real
);
1166 gfc_free_error (&old_error
);
1170 if (gfc_match_char (',') == MATCH_NO
)
1172 gfc_pop_error (&old_error
);
1177 /* If m is error, then something was wrong with the real part and we
1178 assume we have a complex constant because we've seen the ','. An
1179 ambiguous case here is the start of an iterator list of some
1180 sort. These sort of lists are matched prior to coming here. */
1182 if (m
== MATCH_ERROR
)
1184 gfc_free_error (&old_error
);
1187 gfc_pop_error (&old_error
);
1189 m
= match_complex_part (&imag
);
1192 if (m
== MATCH_ERROR
)
1195 m
= gfc_match_char (')');
1198 /* Give the matcher for implied do-loops a chance to run. This
1199 yields a much saner error message for (/ (i, 4=i, 6) /). */
1200 if (gfc_peek_char () == '=')
1209 if (m
== MATCH_ERROR
)
1212 /* Decide on the kind of this complex number. */
1213 if (real
->ts
.type
== BT_REAL
)
1215 if (imag
->ts
.type
== BT_REAL
)
1216 kind
= gfc_kind_max (real
, imag
);
1218 kind
= real
->ts
.kind
;
1222 if (imag
->ts
.type
== BT_REAL
)
1223 kind
= imag
->ts
.kind
;
1225 kind
= gfc_default_real_kind
;
1227 target
.type
= BT_REAL
;
1230 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1231 gfc_convert_type (real
, &target
, 2);
1232 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1233 gfc_convert_type (imag
, &target
, 2);
1235 e
= gfc_convert_complex (real
, imag
, kind
);
1236 e
->where
= gfc_current_locus
;
1238 gfc_free_expr (real
);
1239 gfc_free_expr (imag
);
1245 gfc_error ("Syntax error in COMPLEX constant at %C");
1250 gfc_free_expr (real
);
1251 gfc_free_expr (imag
);
1252 gfc_current_locus
= old_loc
;
1258 /* Match constants in any of several forms. Returns nonzero for a
1259 match, zero for no match. */
1262 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1266 m
= match_complex_constant (result
);
1270 m
= match_string_constant (result
);
1274 m
= match_boz_constant (result
);
1278 m
= match_real_constant (result
, signflag
);
1282 m
= match_hollerith_constant (result
);
1286 m
= match_integer_constant (result
, signflag
);
1290 m
= match_logical_constant (result
);
1298 /* Match a single actual argument value. An actual argument is
1299 usually an expression, but can also be a procedure name. If the
1300 argument is a single name, it is not always possible to tell
1301 whether the name is a dummy procedure or not. We treat these cases
1302 by creating an argument that looks like a dummy procedure and
1303 fixing things later during resolution. */
1306 match_actual_arg (gfc_expr
**result
)
1308 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1309 gfc_symtree
*symtree
;
1314 where
= gfc_current_locus
;
1316 switch (gfc_match_name (name
))
1325 w
= gfc_current_locus
;
1326 gfc_gobble_whitespace ();
1327 c
= gfc_next_char ();
1328 gfc_current_locus
= w
;
1330 if (c
!= ',' && c
!= ')')
1333 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1335 /* Handle error elsewhere. */
1337 /* Eliminate a couple of common cases where we know we don't
1338 have a function argument. */
1339 if (symtree
== NULL
)
1341 gfc_get_sym_tree (name
, NULL
, &symtree
);
1342 gfc_set_sym_referenced (symtree
->n
.sym
);
1348 sym
= symtree
->n
.sym
;
1349 gfc_set_sym_referenced (sym
);
1350 if (sym
->attr
.flavor
!= FL_PROCEDURE
1351 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1354 /* If the symbol is a function with itself as the result and
1355 is being defined, then we have a variable. */
1356 if (sym
->attr
.function
&& sym
->result
== sym
)
1358 if (gfc_current_ns
->proc_name
== sym
1359 || (gfc_current_ns
->parent
!= NULL
1360 && gfc_current_ns
->parent
->proc_name
== sym
))
1364 && (sym
->ns
== gfc_current_ns
1365 || sym
->ns
== gfc_current_ns
->parent
))
1367 gfc_entry_list
*el
= NULL
;
1369 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1379 e
= gfc_get_expr (); /* Leave it unknown for now */
1380 e
->symtree
= symtree
;
1381 e
->expr_type
= EXPR_VARIABLE
;
1382 e
->ts
.type
= BT_PROCEDURE
;
1389 gfc_current_locus
= where
;
1390 return gfc_match_expr (result
);
1394 /* Match a keyword argument. */
1397 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1399 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1400 gfc_actual_arglist
*a
;
1404 name_locus
= gfc_current_locus
;
1405 m
= gfc_match_name (name
);
1409 if (gfc_match_char ('=') != MATCH_YES
)
1415 m
= match_actual_arg (&actual
->expr
);
1419 /* Make sure this name has not appeared yet. */
1421 if (name
[0] != '\0')
1423 for (a
= base
; a
; a
= a
->next
)
1424 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1426 gfc_error ("Keyword '%s' at %C has already appeared in the "
1427 "current argument list", name
);
1432 actual
->name
= gfc_get_string (name
);
1436 gfc_current_locus
= name_locus
;
1441 /* Match an argument list function, such as %VAL. */
1444 match_arg_list_function (gfc_actual_arglist
*result
)
1446 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1450 old_locus
= gfc_current_locus
;
1452 if (gfc_match_char ('%') != MATCH_YES
)
1458 m
= gfc_match ("%n (", name
);
1462 if (name
[0] != '\0')
1467 if (strncmp (name
, "loc", 3) == 0)
1469 result
->name
= "%LOC";
1473 if (strncmp (name
, "ref", 3) == 0)
1475 result
->name
= "%REF";
1479 if (strncmp (name
, "val", 3) == 0)
1481 result
->name
= "%VAL";
1490 if (gfc_notify_std (GFC_STD_GNU
, "Extension: argument list "
1491 "function at %C") == FAILURE
)
1497 m
= match_actual_arg (&result
->expr
);
1501 if (gfc_match_char (')') != MATCH_YES
)
1510 gfc_current_locus
= old_locus
;
1515 /* Matches an actual argument list of a function or subroutine, from
1516 the opening parenthesis to the closing parenthesis. The argument
1517 list is assumed to allow keyword arguments because we don't know if
1518 the symbol associated with the procedure has an implicit interface
1519 or not. We make sure keywords are unique. If SUB_FLAG is set,
1520 we're matching the argument list of a subroutine. */
1523 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1525 gfc_actual_arglist
*head
, *tail
;
1527 gfc_st_label
*label
;
1531 *argp
= tail
= NULL
;
1532 old_loc
= gfc_current_locus
;
1536 if (gfc_match_char ('(') == MATCH_NO
)
1537 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1539 if (gfc_match_char (')') == MATCH_YES
)
1546 head
= tail
= gfc_get_actual_arglist ();
1549 tail
->next
= gfc_get_actual_arglist ();
1553 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1555 m
= gfc_match_st_label (&label
);
1557 gfc_error ("Expected alternate return label at %C");
1561 tail
->label
= label
;
1565 /* After the first keyword argument is seen, the following
1566 arguments must also have keywords. */
1569 m
= match_keyword_arg (tail
, head
);
1571 if (m
== MATCH_ERROR
)
1575 gfc_error ("Missing keyword name in actual argument list at %C");
1582 /* Try an argument list function, like %VAL. */
1583 m
= match_arg_list_function (tail
);
1584 if (m
== MATCH_ERROR
)
1587 /* See if we have the first keyword argument. */
1590 m
= match_keyword_arg (tail
, head
);
1593 if (m
== MATCH_ERROR
)
1599 /* Try for a non-keyword argument. */
1600 m
= match_actual_arg (&tail
->expr
);
1601 if (m
== MATCH_ERROR
)
1610 if (gfc_match_char (')') == MATCH_YES
)
1612 if (gfc_match_char (',') != MATCH_YES
)
1620 gfc_error ("Syntax error in argument list at %C");
1623 gfc_free_actual_arglist (head
);
1624 gfc_current_locus
= old_loc
;
1630 /* Used by match_varspec() to extend the reference list by one
1634 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1636 if (primary
->ref
== NULL
)
1637 primary
->ref
= tail
= gfc_get_ref ();
1641 gfc_internal_error ("extend_ref(): Bad tail");
1642 tail
->next
= gfc_get_ref ();
1650 /* Match any additional specifications associated with the current
1651 variable like member references or substrings. If equiv_flag is
1652 set we only match stuff that is allowed inside an EQUIVALENCE
1656 match_varspec (gfc_expr
*primary
, int equiv_flag
)
1658 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1659 gfc_ref
*substring
, *tail
;
1660 gfc_component
*component
;
1661 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1666 if ((equiv_flag
&& gfc_peek_char () == '(') || sym
->attr
.dimension
)
1668 /* In EQUIVALENCE, we don't know yet whether we are seeing
1669 an array, character variable or array of character
1670 variables. We'll leave the decision till resolve time. */
1671 tail
= extend_ref (primary
, tail
);
1672 tail
->type
= REF_ARRAY
;
1674 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1679 if (equiv_flag
&& gfc_peek_char () == '(')
1681 tail
= extend_ref (primary
, tail
);
1682 tail
->type
= REF_ARRAY
;
1684 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
);
1690 primary
->ts
= sym
->ts
;
1695 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1696 goto check_substring
;
1698 sym
= sym
->ts
.derived
;
1702 m
= gfc_match_name (name
);
1704 gfc_error ("Expected structure component name at %C");
1708 component
= gfc_find_component (sym
, name
);
1709 if (component
== NULL
)
1712 tail
= extend_ref (primary
, tail
);
1713 tail
->type
= REF_COMPONENT
;
1715 tail
->u
.c
.component
= component
;
1716 tail
->u
.c
.sym
= sym
;
1718 primary
->ts
= component
->ts
;
1720 if (component
->as
!= NULL
)
1722 tail
= extend_ref (primary
, tail
);
1723 tail
->type
= REF_ARRAY
;
1725 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1730 if (component
->ts
.type
!= BT_DERIVED
1731 || gfc_match_char ('%') != MATCH_YES
)
1734 sym
= component
->ts
.derived
;
1738 if (primary
->ts
.type
== BT_UNKNOWN
)
1740 if (gfc_get_default_type (sym
, sym
->ns
)->type
== BT_CHARACTER
)
1742 gfc_set_default_type (sym
, 0, sym
->ns
);
1743 primary
->ts
= sym
->ts
;
1747 if (primary
->ts
.type
== BT_CHARACTER
)
1749 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1753 primary
->ref
= substring
;
1755 tail
->next
= substring
;
1757 if (primary
->expr_type
== EXPR_CONSTANT
)
1758 primary
->expr_type
= EXPR_SUBSTRING
;
1761 primary
->ts
.cl
= NULL
;
1777 /* Given an expression that is a variable, figure out what the
1778 ultimate variable's type and attribute is, traversing the reference
1779 structures if necessary.
1781 This subroutine is trickier than it looks. We start at the base
1782 symbol and store the attribute. Component references load a
1783 completely new attribute.
1785 A couple of rules come into play. Subobjects of targets are always
1786 targets themselves. If we see a component that goes through a
1787 pointer, then the expression must also be a target, since the
1788 pointer is associated with something (if it isn't core will soon be
1789 dumped). If we see a full part or section of an array, the
1790 expression is also an array.
1792 We can have at most one full array reference. */
1795 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
1797 int dimension
, pointer
, allocatable
, target
;
1798 symbol_attribute attr
;
1801 if (expr
->expr_type
!= EXPR_VARIABLE
)
1802 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1805 attr
= expr
->symtree
->n
.sym
->attr
;
1807 dimension
= attr
.dimension
;
1808 pointer
= attr
.pointer
;
1809 allocatable
= attr
.allocatable
;
1811 target
= attr
.target
;
1815 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1816 *ts
= expr
->symtree
->n
.sym
->ts
;
1818 for (; ref
; ref
= ref
->next
)
1823 switch (ref
->u
.ar
.type
)
1830 allocatable
= pointer
= 0;
1835 allocatable
= pointer
= 0;
1839 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1845 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1847 *ts
= ref
->u
.c
.component
->ts
;
1849 pointer
= ref
->u
.c
.component
->pointer
;
1850 allocatable
= ref
->u
.c
.component
->allocatable
;
1857 allocatable
= pointer
= 0;
1861 attr
.dimension
= dimension
;
1862 attr
.pointer
= pointer
;
1863 attr
.allocatable
= allocatable
;
1864 attr
.target
= target
;
1870 /* Return the attribute from a general expression. */
1873 gfc_expr_attr (gfc_expr
*e
)
1875 symbol_attribute attr
;
1877 switch (e
->expr_type
)
1880 attr
= gfc_variable_attr (e
, NULL
);
1884 gfc_clear_attr (&attr
);
1886 if (e
->value
.function
.esym
!= NULL
)
1887 attr
= e
->value
.function
.esym
->result
->attr
;
1889 /* TODO: NULL() returns pointers. May have to take care of this
1895 gfc_clear_attr (&attr
);
1903 /* Match a structure constructor. The initial symbol has already been
1907 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
1909 gfc_constructor
*head
, *tail
;
1910 gfc_component
*comp
;
1917 if (gfc_match_char ('(') != MATCH_YES
)
1920 where
= gfc_current_locus
;
1922 gfc_find_component (sym
, NULL
);
1924 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1927 tail
= head
= gfc_get_constructor ();
1930 tail
->next
= gfc_get_constructor ();
1934 m
= gfc_match_expr (&tail
->expr
);
1937 if (m
== MATCH_ERROR
)
1940 if (gfc_match_char (',') == MATCH_YES
)
1942 if (comp
->next
== NULL
)
1944 gfc_error ("Too many components in structure constructor at %C");
1954 if (gfc_match_char (')') != MATCH_YES
)
1957 if (comp
->next
!= NULL
)
1959 gfc_error ("Too few components in structure constructor at %C");
1963 e
= gfc_get_expr ();
1965 e
->expr_type
= EXPR_STRUCTURE
;
1967 e
->ts
.type
= BT_DERIVED
;
1968 e
->ts
.derived
= sym
;
1971 e
->value
.constructor
= head
;
1977 gfc_error ("Syntax error in structure constructor at %C");
1980 gfc_free_constructor (head
);
1985 /* Matches a variable name followed by anything that might follow it--
1986 array reference, argument list of a function, etc. */
1989 gfc_match_rvalue (gfc_expr
**result
)
1991 gfc_actual_arglist
*actual_arglist
;
1992 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
1995 gfc_symtree
*symtree
;
1996 locus where
, old_loc
;
2003 m
= gfc_match_name (name
);
2007 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2008 && !gfc_current_ns
->has_import_set
)
2009 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
2011 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2016 sym
= symtree
->n
.sym
;
2018 where
= gfc_current_locus
;
2020 gfc_set_sym_referenced (sym
);
2022 if (sym
->attr
.function
&& sym
->result
== sym
)
2024 /* See if this is a directly recursive function call. */
2025 gfc_gobble_whitespace ();
2026 if (sym
->attr
.recursive
2027 && gfc_peek_char () == '('
2028 && gfc_current_ns
->proc_name
== sym
)
2030 if (!sym
->attr
.dimension
)
2033 gfc_error ("'%s' is array valued and directly recursive "
2034 "at %C , so the keyword RESULT must be specified "
2035 "in the FUNCTION statement", sym
->name
);
2039 if (gfc_current_ns
->proc_name
== sym
2040 || (gfc_current_ns
->parent
!= NULL
2041 && gfc_current_ns
->parent
->proc_name
== sym
))
2045 && (sym
->ns
== gfc_current_ns
2046 || sym
->ns
== gfc_current_ns
->parent
))
2048 gfc_entry_list
*el
= NULL
;
2050 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2056 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2059 if (sym
->attr
.generic
)
2060 goto generic_function
;
2062 switch (sym
->attr
.flavor
)
2066 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
2067 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2068 gfc_set_default_type (sym
, 0, sym
->ns
);
2070 e
= gfc_get_expr ();
2072 e
->expr_type
= EXPR_VARIABLE
;
2073 e
->symtree
= symtree
;
2075 m
= match_varspec (e
, 0);
2079 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2080 end up here. Unfortunately, sym->value->expr_type is set to
2081 EXPR_CONSTANT, and so the if () branch would be followed without
2082 the !sym->as check. */
2083 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2084 e
= gfc_copy_expr (sym
->value
);
2087 e
= gfc_get_expr ();
2088 e
->expr_type
= EXPR_VARIABLE
;
2091 e
->symtree
= symtree
;
2092 m
= match_varspec (e
, 0);
2096 sym
= gfc_use_derived (sym
);
2100 m
= gfc_match_structure_constructor (sym
, &e
);
2103 /* If we're here, then the name is known to be the name of a
2104 procedure, yet it is not sure to be the name of a function. */
2106 if (sym
->attr
.subroutine
)
2108 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2114 /* At this point, the name has to be a non-statement function.
2115 If the name is the same as the current function being
2116 compiled, then we have a variable reference (to the function
2117 result) if the name is non-recursive. */
2119 st
= gfc_enclosing_unit (NULL
);
2121 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2123 && !sym
->attr
.recursive
)
2125 e
= gfc_get_expr ();
2126 e
->symtree
= symtree
;
2127 e
->expr_type
= EXPR_VARIABLE
;
2129 m
= match_varspec (e
, 0);
2133 /* Match a function reference. */
2135 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2138 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2139 gfc_error ("Statement function '%s' requires argument list at %C",
2142 gfc_error ("Function '%s' requires an argument list at %C",
2155 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2156 sym
= symtree
->n
.sym
;
2158 e
= gfc_get_expr ();
2159 e
->symtree
= symtree
;
2160 e
->expr_type
= EXPR_FUNCTION
;
2161 e
->value
.function
.actual
= actual_arglist
;
2162 e
->where
= gfc_current_locus
;
2164 if (sym
->as
!= NULL
)
2165 e
->rank
= sym
->as
->rank
;
2167 if (!sym
->attr
.function
2168 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2174 if (sym
->result
== NULL
)
2182 /* Special case for derived type variables that get their types
2183 via an IMPLICIT statement. This can't wait for the
2184 resolution phase. */
2186 if (gfc_peek_char () == '%'
2187 && sym
->ts
.type
== BT_UNKNOWN
2188 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2189 gfc_set_default_type (sym
, 0, sym
->ns
);
2191 /* If the symbol has a dimension attribute, the expression is a
2194 if (sym
->attr
.dimension
)
2196 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2197 sym
->name
, NULL
) == FAILURE
)
2203 e
= gfc_get_expr ();
2204 e
->symtree
= symtree
;
2205 e
->expr_type
= EXPR_VARIABLE
;
2206 m
= match_varspec (e
, 0);
2210 /* Name is not an array, so we peek to see if a '(' implies a
2211 function call or a substring reference. Otherwise the
2212 variable is just a scalar. */
2214 gfc_gobble_whitespace ();
2215 if (gfc_peek_char () != '(')
2217 /* Assume a scalar variable */
2218 e
= gfc_get_expr ();
2219 e
->symtree
= symtree
;
2220 e
->expr_type
= EXPR_VARIABLE
;
2222 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2223 sym
->name
, NULL
) == FAILURE
)
2230 m
= match_varspec (e
, 0);
2234 /* See if this is a function reference with a keyword argument
2235 as first argument. We do this because otherwise a spurious
2236 symbol would end up in the symbol table. */
2238 old_loc
= gfc_current_locus
;
2239 m2
= gfc_match (" ( %n =", argname
);
2240 gfc_current_locus
= old_loc
;
2242 e
= gfc_get_expr ();
2243 e
->symtree
= symtree
;
2245 if (m2
!= MATCH_YES
)
2247 /* Try to figure out whether we're dealing with a character type.
2248 We're peeking ahead here, because we don't want to call
2249 match_substring if we're dealing with an implicitly typed
2250 non-character variable. */
2251 implicit_char
= false;
2252 if (sym
->ts
.type
== BT_UNKNOWN
)
2254 ts
= gfc_get_default_type (sym
,NULL
);
2255 if (ts
->type
== BT_CHARACTER
)
2256 implicit_char
= true;
2259 /* See if this could possibly be a substring reference of a name
2260 that we're not sure is a variable yet. */
2262 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
2263 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
2266 e
->expr_type
= EXPR_VARIABLE
;
2268 if (sym
->attr
.flavor
!= FL_VARIABLE
2269 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2270 sym
->name
, NULL
) == FAILURE
)
2276 if (sym
->ts
.type
== BT_UNKNOWN
2277 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2291 /* Give up, assume we have a function. */
2293 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2294 sym
= symtree
->n
.sym
;
2295 e
->expr_type
= EXPR_FUNCTION
;
2297 if (!sym
->attr
.function
2298 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2306 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2308 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2316 /* If our new function returns a character, array or structure
2317 type, it might have subsequent references. */
2319 m
= match_varspec (e
, 0);
2326 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2328 e
= gfc_get_expr ();
2329 e
->symtree
= symtree
;
2330 e
->expr_type
= EXPR_FUNCTION
;
2332 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2336 gfc_error ("Symbol at %C is not appropriate for an expression");
2352 /* Match a variable, ie something that can be assigned to. This
2353 starts as a symbol, can be a structure component or an array
2354 reference. It can be a function if the function doesn't have a
2355 separate RESULT variable. If the symbol has not been previously
2356 seen, we assume it is a variable.
2358 This function is called by two interface functions:
2359 gfc_match_variable, which has host_flag = 1, and
2360 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2361 match of the symbol to the local scope. */
2364 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
2372 /* Since nothing has any business being an lvalue in a module
2373 specification block, an interface block or a contains section,
2374 we force the changed_symbols mechanism to work by setting
2375 host_flag to 0. This prevents valid symbols that have the name
2376 of keywords, such as 'end', being turned into variables by
2377 failed matching to assignments for, eg., END INTERFACE. */
2378 if (gfc_current_state () == COMP_MODULE
2379 || gfc_current_state () == COMP_INTERFACE
2380 || gfc_current_state () == COMP_CONTAINS
)
2383 m
= gfc_match_sym_tree (&st
, host_flag
);
2386 where
= gfc_current_locus
;
2389 gfc_set_sym_referenced (sym
);
2390 switch (sym
->attr
.flavor
)
2393 if (sym
->attr
.protected && sym
->attr
.use_assoc
)
2395 gfc_error ("Assigning to PROTECTED variable at %C");
2401 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2402 sym
->name
, NULL
) == FAILURE
)
2408 gfc_error ("Named constant at %C in an EQUIVALENCE");
2410 gfc_error ("Cannot assign to a named constant at %C");
2415 /* Check for a nonrecursive function result */
2416 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
))
2418 /* If a function result is a derived type, then the derived
2419 type may still have to be resolved. */
2421 if (sym
->ts
.type
== BT_DERIVED
2422 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2427 /* Fall through to error */
2430 gfc_error ("Expected VARIABLE at %C");
2434 /* Special case for derived type variables that get their types
2435 via an IMPLICIT statement. This can't wait for the
2436 resolution phase. */
2439 gfc_namespace
* implicit_ns
;
2441 if (gfc_current_ns
->proc_name
== sym
)
2442 implicit_ns
= gfc_current_ns
;
2444 implicit_ns
= sym
->ns
;
2446 if (gfc_peek_char () == '%'
2447 && sym
->ts
.type
== BT_UNKNOWN
2448 && gfc_get_default_type (sym
, implicit_ns
)->type
== BT_DERIVED
)
2449 gfc_set_default_type (sym
, 0, implicit_ns
);
2452 expr
= gfc_get_expr ();
2454 expr
->expr_type
= EXPR_VARIABLE
;
2457 expr
->where
= where
;
2459 /* Now see if we have to do more. */
2460 m
= match_varspec (expr
, equiv_flag
);
2463 gfc_free_expr (expr
);
2473 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
2475 return match_variable (result
, equiv_flag
, 1);
2480 gfc_match_equiv_variable (gfc_expr
**result
)
2482 return match_variable (result
, 1, 0);