1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
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/>. */
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
);
64 gfc_set_sym_referenced (sym
);
73 /* Get a trailing kind-specification for non-character variables.
75 the integer kind value or:
76 -1 if an error was generated
77 -2 if no kind was found */
85 if (gfc_match_char ('_') != MATCH_YES
)
88 m
= match_kind_param (&kind
);
90 gfc_error ("Missing kind-parameter at %C");
92 return (m
== MATCH_YES
) ? kind
: -1;
96 /* Given a character and a radix, see if the character is a valid
97 digit in that radix. */
100 gfc_check_digit (char c
, int radix
)
107 r
= ('0' <= c
&& c
<= '1');
111 r
= ('0' <= c
&& c
<= '7');
115 r
= ('0' <= c
&& c
<= '9');
123 gfc_internal_error ("gfc_check_digit(): bad radix");
130 /* Match the digit string part of an integer if signflag is not set,
131 the signed digit string part if signflag is set. If the buffer
132 is NULL, we just count characters for the resolution pass. Returns
133 the number of characters matched, -1 for no match. */
136 match_digits (int signflag
, int radix
, char *buffer
)
143 c
= gfc_next_ascii_char ();
145 if (signflag
&& (c
== '+' || c
== '-'))
149 gfc_gobble_whitespace ();
150 c
= gfc_next_ascii_char ();
154 if (!gfc_check_digit (c
, radix
))
163 old_loc
= gfc_current_locus
;
164 c
= gfc_next_ascii_char ();
166 if (!gfc_check_digit (c
, radix
))
174 gfc_current_locus
= old_loc
;
180 /* Match an integer (digit string and optional kind).
181 A sign will be accepted if signflag is set. */
184 match_integer_constant (gfc_expr
**result
, int signflag
)
191 old_loc
= gfc_current_locus
;
192 gfc_gobble_whitespace ();
194 length
= match_digits (signflag
, 10, NULL
);
195 gfc_current_locus
= old_loc
;
199 buffer
= (char *) alloca (length
+ 1);
200 memset (buffer
, '\0', length
+ 1);
202 gfc_gobble_whitespace ();
204 match_digits (signflag
, 10, buffer
);
208 kind
= gfc_default_integer_kind
;
212 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
214 gfc_error ("Integer kind %d at %C not available", kind
);
218 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
220 if (gfc_range_check (e
) != ARITH_OK
)
222 gfc_error ("Integer too big for its kind at %C. This check can be "
223 "disabled with the option -fno-range-check");
234 /* Match a Hollerith constant. */
237 match_hollerith_constant (gfc_expr
**result
)
245 old_loc
= gfc_current_locus
;
246 gfc_gobble_whitespace ();
248 if (match_integer_constant (&e
, 0) == MATCH_YES
249 && gfc_match_char ('h') == MATCH_YES
)
251 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Hollerith constant "
255 msg
= gfc_extract_int (e
, &num
);
263 gfc_error ("Invalid Hollerith constant: %L must contain at least "
264 "one character", &old_loc
);
267 if (e
->ts
.kind
!= gfc_default_integer_kind
)
269 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
270 "should be default", &old_loc
);
276 e
= gfc_constant_result (BT_HOLLERITH
, gfc_default_character_kind
,
279 e
->representation
.string
= XCNEWVEC (char, num
+ 1);
281 for (i
= 0; i
< num
; i
++)
283 gfc_char_t c
= gfc_next_char_literal (1);
284 if (! gfc_wide_fits_in_byte (c
))
286 gfc_error ("Invalid Hollerith constant at %L contains a "
287 "wide character", &old_loc
);
291 e
->representation
.string
[i
] = (unsigned char) c
;
294 e
->representation
.string
[num
] = '\0';
295 e
->representation
.length
= num
;
303 gfc_current_locus
= old_loc
;
312 /* Match a binary, octal or hexadecimal constant that can be found in
313 a DATA statement. The standard permits b'010...', o'73...', and
314 z'a1...' where b, o, and z can be capital letters. This function
315 also accepts postfixed forms of the constants: '01...'b, '73...'o,
316 and 'a1...'z. An additional extension is the use of x for z. */
319 match_boz_constant (gfc_expr
**result
)
321 int radix
, length
, x_hex
, kind
;
322 locus old_loc
, start_loc
;
323 char *buffer
, post
, delim
;
326 start_loc
= old_loc
= gfc_current_locus
;
327 gfc_gobble_whitespace ();
330 switch (post
= gfc_next_ascii_char ())
352 radix
= 16; /* Set to accept any valid digit string. */
358 /* No whitespace allowed here. */
361 delim
= gfc_next_ascii_char ();
363 if (delim
!= '\'' && delim
!= '\"')
367 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
368 "constant at %C uses non-standard syntax")
372 old_loc
= gfc_current_locus
;
374 length
= match_digits (0, radix
, NULL
);
377 gfc_error ("Empty set of digits in BOZ constant at %C");
381 if (gfc_next_ascii_char () != delim
)
383 gfc_error ("Illegal character in BOZ constant at %C");
389 switch (gfc_next_ascii_char ())
406 if (gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ constant "
407 "at %C uses non-standard postfix syntax")
412 gfc_current_locus
= old_loc
;
414 buffer
= (char *) alloca (length
+ 1);
415 memset (buffer
, '\0', length
+ 1);
417 match_digits (0, radix
, buffer
);
418 gfc_next_ascii_char (); /* Eat delimiter. */
420 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
422 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
423 "If a data-stmt-constant is a boz-literal-constant, the corresponding
424 variable shall be of type integer. The boz-literal-constant is treated
425 as if it were an int-literal-constant with a kind-param that specifies
426 the representation method with the largest decimal exponent range
427 supported by the processor." */
429 kind
= gfc_max_integer_kind
;
430 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
432 /* Mark as boz variable. */
435 if (gfc_range_check (e
) != ARITH_OK
)
437 gfc_error ("Integer too big for integer kind %i at %C", kind
);
442 if (!gfc_in_match_data ()
443 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BOZ used outside a DATA "
452 gfc_current_locus
= start_loc
;
457 /* Match a real constant of some sort. Allow a signed constant if signflag
461 match_real_constant (gfc_expr
**result
, int signflag
)
463 int kind
, count
, seen_dp
, seen_digits
;
464 locus old_loc
, temp_loc
;
465 char *p
, *buffer
, c
, exp_char
;
469 old_loc
= gfc_current_locus
;
470 gfc_gobble_whitespace ();
480 c
= gfc_next_ascii_char ();
481 if (signflag
&& (c
== '+' || c
== '-'))
486 gfc_gobble_whitespace ();
487 c
= gfc_next_ascii_char ();
490 /* Scan significand. */
491 for (;; c
= gfc_next_ascii_char (), count
++)
498 /* Check to see if "." goes with a following operator like
500 temp_loc
= gfc_current_locus
;
501 c
= gfc_next_ascii_char ();
503 if (c
== 'e' || c
== 'd' || c
== 'q')
505 c
= gfc_next_ascii_char ();
507 goto done
; /* Operator named .e. or .d. */
511 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
513 gfc_current_locus
= temp_loc
;
527 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
532 c
= gfc_next_ascii_char ();
535 if (c
== '+' || c
== '-')
536 { /* optional sign */
537 c
= gfc_next_ascii_char ();
543 gfc_error ("Missing exponent in real number at %C");
549 c
= gfc_next_ascii_char ();
554 /* Check that we have a numeric constant. */
555 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
557 gfc_current_locus
= old_loc
;
561 /* Convert the number. */
562 gfc_current_locus
= old_loc
;
563 gfc_gobble_whitespace ();
565 buffer
= (char *) alloca (count
+ 1);
566 memset (buffer
, '\0', count
+ 1);
569 c
= gfc_next_ascii_char ();
570 if (c
== '+' || c
== '-')
572 gfc_gobble_whitespace ();
573 c
= gfc_next_ascii_char ();
576 /* Hack for mpfr_set_str(). */
579 if (c
== 'd' || c
== 'q')
587 c
= gfc_next_ascii_char ();
599 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
603 kind
= gfc_default_double_kind
;
608 kind
= gfc_default_real_kind
;
610 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
612 gfc_error ("Invalid real kind %d at %C", kind
);
617 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
619 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
621 switch (gfc_range_check (e
))
626 gfc_error ("Real constant overflows its kind at %C");
629 case ARITH_UNDERFLOW
:
630 if (gfc_option
.warn_underflow
)
631 gfc_warning ("Real constant underflows its kind at %C");
632 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
636 gfc_internal_error ("gfc_range_check() returned bad value");
648 /* Match a substring reference. */
651 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
653 gfc_expr
*start
, *end
;
661 old_loc
= gfc_current_locus
;
663 m
= gfc_match_char ('(');
667 if (gfc_match_char (':') != MATCH_YES
)
670 m
= gfc_match_init_expr (&start
);
672 m
= gfc_match_expr (&start
);
680 m
= gfc_match_char (':');
685 if (gfc_match_char (')') != MATCH_YES
)
688 m
= gfc_match_init_expr (&end
);
690 m
= gfc_match_expr (&end
);
694 if (m
== MATCH_ERROR
)
697 m
= gfc_match_char (')');
702 /* Optimize away the (:) reference. */
703 if (start
== NULL
&& end
== NULL
)
707 ref
= gfc_get_ref ();
709 ref
->type
= REF_SUBSTRING
;
711 start
= gfc_int_expr (1);
712 ref
->u
.ss
.start
= start
;
713 if (end
== NULL
&& cl
)
714 end
= gfc_copy_expr (cl
->length
);
716 ref
->u
.ss
.length
= cl
;
723 gfc_error ("Syntax error in SUBSTRING specification at %C");
727 gfc_free_expr (start
);
730 gfc_current_locus
= old_loc
;
735 /* Reads the next character of a string constant, taking care to
736 return doubled delimiters on the input as a single instance of
739 Special return values for "ret" argument are:
740 -1 End of the string, as determined by the delimiter
741 -2 Unterminated string detected
743 Backslash codes are also expanded at this time. */
746 next_string_char (gfc_char_t delimiter
, int *ret
)
751 c
= gfc_next_char_literal (1);
760 if (gfc_option
.flag_backslash
&& c
== '\\')
762 old_locus
= gfc_current_locus
;
764 if (gfc_match_special_char (&c
) == MATCH_NO
)
765 gfc_current_locus
= old_locus
;
767 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
768 gfc_warning ("Extension: backslash character at %C");
774 old_locus
= gfc_current_locus
;
775 c
= gfc_next_char_literal (0);
779 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_ascii_char ();
815 old_loc
= gfc_current_locus
;
816 c
= gfc_next_ascii_char ();
820 peek
= gfc_peek_ascii_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 name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
855 int i
, kind
, length
, warn_ampersand
, ret
;
856 locus old_locus
, start_locus
;
861 gfc_char_t c
, delimiter
, *p
;
863 old_locus
= gfc_current_locus
;
865 gfc_gobble_whitespace ();
867 start_locus
= gfc_current_locus
;
869 c
= gfc_next_char ();
870 if (c
== '\'' || c
== '"')
872 kind
= gfc_default_character_kind
;
876 if (gfc_wide_is_digit (c
))
880 while (gfc_wide_is_digit (c
))
882 kind
= kind
* 10 + c
- '0';
885 c
= gfc_next_char ();
891 gfc_current_locus
= old_locus
;
893 m
= match_charkind_name (name
);
897 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
899 || sym
->attr
.flavor
!= FL_PARAMETER
)
903 c
= gfc_next_char ();
908 gfc_gobble_whitespace ();
909 c
= gfc_next_char ();
915 gfc_gobble_whitespace ();
916 start_locus
= gfc_current_locus
;
918 c
= gfc_next_char ();
919 if (c
!= '\'' && c
!= '"')
924 q
= gfc_extract_int (sym
->value
, &kind
);
930 gfc_set_sym_referenced (sym
);
933 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
935 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
940 /* Scan the string into a block of memory by first figuring out how
941 long it is, allocating the structure, then re-reading it. This
942 isn't particularly efficient, but string constants aren't that
943 common in most code. TODO: Use obstacks? */
950 c
= next_string_char (delimiter
, &ret
);
955 gfc_current_locus
= start_locus
;
956 gfc_error ("Unterminated character constant beginning at %C");
963 /* Peek at the next character to see if it is a b, o, z, or x for the
964 postfixed BOZ literal constants. */
965 peek
= gfc_peek_ascii_char ();
966 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
972 e
->expr_type
= EXPR_CONSTANT
;
974 e
->ts
.type
= BT_CHARACTER
;
976 e
->ts
.is_c_interop
= 0;
978 e
->where
= start_locus
;
980 e
->value
.character
.string
= p
= gfc_get_wide_string (length
+ 1);
981 e
->value
.character
.length
= length
;
983 gfc_current_locus
= start_locus
;
984 gfc_next_char (); /* Skip delimiter */
986 /* We disable the warning for the following loop as the warning has already
987 been printed in the loop above. */
988 warn_ampersand
= gfc_option
.warn_ampersand
;
989 gfc_option
.warn_ampersand
= 0;
991 for (i
= 0; i
< length
; i
++)
993 c
= next_string_char (delimiter
, &ret
);
995 if (!gfc_check_character_range (c
, kind
))
997 gfc_error ("Character '%s' in string at %C is not representable "
998 "in character kind %d", gfc_print_wide_char (c
), kind
);
1005 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1006 gfc_option
.warn_ampersand
= warn_ampersand
;
1008 next_string_char (delimiter
, &ret
);
1010 gfc_internal_error ("match_string_constant(): Delimiter not found");
1012 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1013 e
->expr_type
= EXPR_SUBSTRING
;
1020 gfc_current_locus
= old_locus
;
1025 /* Match a .true. or .false. Returns 1 if a .true. was found,
1026 0 if a .false. was found, and -1 otherwise. */
1028 match_logical_constant_string (void)
1030 locus orig_loc
= gfc_current_locus
;
1032 gfc_gobble_whitespace ();
1033 if (gfc_next_ascii_char () == '.')
1035 char ch
= gfc_next_ascii_char ();
1038 if (gfc_next_ascii_char () == 'a'
1039 && gfc_next_ascii_char () == 'l'
1040 && gfc_next_ascii_char () == 's'
1041 && gfc_next_ascii_char () == 'e'
1042 && gfc_next_ascii_char () == '.')
1043 /* Matched ".false.". */
1048 if (gfc_next_ascii_char () == 'r'
1049 && gfc_next_ascii_char () == 'u'
1050 && gfc_next_ascii_char () == 'e'
1051 && gfc_next_ascii_char () == '.')
1052 /* Matched ".true.". */
1056 gfc_current_locus
= orig_loc
;
1060 /* Match a .true. or .false. */
1063 match_logical_constant (gfc_expr
**result
)
1068 i
= match_logical_constant_string ();
1076 kind
= gfc_default_logical_kind
;
1078 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1080 gfc_error ("Bad kind for logical constant at %C");
1084 e
= gfc_get_expr ();
1086 e
->expr_type
= EXPR_CONSTANT
;
1087 e
->value
.logical
= i
;
1088 e
->ts
.type
= BT_LOGICAL
;
1090 e
->ts
.is_c_interop
= 0;
1092 e
->where
= gfc_current_locus
;
1099 /* Match a real or imaginary part of a complex constant that is a
1100 symbolic constant. */
1103 match_sym_complex_part (gfc_expr
**result
)
1105 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1110 m
= gfc_match_name (name
);
1114 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1117 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1119 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1123 if (!gfc_numeric_ts (&sym
->value
->ts
))
1125 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1129 if (sym
->value
->rank
!= 0)
1131 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1135 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PARAMETER symbol in "
1136 "complex constant at %C") == FAILURE
)
1139 switch (sym
->value
->ts
.type
)
1142 e
= gfc_copy_expr (sym
->value
);
1146 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1152 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1158 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1161 *result
= e
; /* e is a scalar, real, constant expression. */
1165 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1170 /* Match a real or imaginary part of a complex number. */
1173 match_complex_part (gfc_expr
**result
)
1177 m
= match_sym_complex_part (result
);
1181 m
= match_real_constant (result
, 1);
1185 return match_integer_constant (result
, 1);
1189 /* Try to match a complex constant. */
1192 match_complex_constant (gfc_expr
**result
)
1194 gfc_expr
*e
, *real
, *imag
;
1195 gfc_error_buf old_error
;
1196 gfc_typespec target
;
1201 old_loc
= gfc_current_locus
;
1202 real
= imag
= e
= NULL
;
1204 m
= gfc_match_char ('(');
1208 gfc_push_error (&old_error
);
1210 m
= match_complex_part (&real
);
1213 gfc_free_error (&old_error
);
1217 if (gfc_match_char (',') == MATCH_NO
)
1219 gfc_pop_error (&old_error
);
1224 /* If m is error, then something was wrong with the real part and we
1225 assume we have a complex constant because we've seen the ','. An
1226 ambiguous case here is the start of an iterator list of some
1227 sort. These sort of lists are matched prior to coming here. */
1229 if (m
== MATCH_ERROR
)
1231 gfc_free_error (&old_error
);
1234 gfc_pop_error (&old_error
);
1236 m
= match_complex_part (&imag
);
1239 if (m
== MATCH_ERROR
)
1242 m
= gfc_match_char (')');
1245 /* Give the matcher for implied do-loops a chance to run. This
1246 yields a much saner error message for (/ (i, 4=i, 6) /). */
1247 if (gfc_peek_ascii_char () == '=')
1256 if (m
== MATCH_ERROR
)
1259 /* Decide on the kind of this complex number. */
1260 if (real
->ts
.type
== BT_REAL
)
1262 if (imag
->ts
.type
== BT_REAL
)
1263 kind
= gfc_kind_max (real
, imag
);
1265 kind
= real
->ts
.kind
;
1269 if (imag
->ts
.type
== BT_REAL
)
1270 kind
= imag
->ts
.kind
;
1272 kind
= gfc_default_real_kind
;
1274 target
.type
= BT_REAL
;
1276 target
.is_c_interop
= 0;
1277 target
.is_iso_c
= 0;
1279 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1280 gfc_convert_type (real
, &target
, 2);
1281 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1282 gfc_convert_type (imag
, &target
, 2);
1284 e
= gfc_convert_complex (real
, imag
, kind
);
1285 e
->where
= gfc_current_locus
;
1287 gfc_free_expr (real
);
1288 gfc_free_expr (imag
);
1294 gfc_error ("Syntax error in COMPLEX constant at %C");
1299 gfc_free_expr (real
);
1300 gfc_free_expr (imag
);
1301 gfc_current_locus
= old_loc
;
1307 /* Match constants in any of several forms. Returns nonzero for a
1308 match, zero for no match. */
1311 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1315 m
= match_complex_constant (result
);
1319 m
= match_string_constant (result
);
1323 m
= match_boz_constant (result
);
1327 m
= match_real_constant (result
, signflag
);
1331 m
= match_hollerith_constant (result
);
1335 m
= match_integer_constant (result
, signflag
);
1339 m
= match_logical_constant (result
);
1347 /* Match a single actual argument value. An actual argument is
1348 usually an expression, but can also be a procedure name. If the
1349 argument is a single name, it is not always possible to tell
1350 whether the name is a dummy procedure or not. We treat these cases
1351 by creating an argument that looks like a dummy procedure and
1352 fixing things later during resolution. */
1355 match_actual_arg (gfc_expr
**result
)
1357 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1358 gfc_symtree
*symtree
;
1363 gfc_gobble_whitespace ();
1364 where
= gfc_current_locus
;
1366 switch (gfc_match_name (name
))
1375 w
= gfc_current_locus
;
1376 gfc_gobble_whitespace ();
1377 c
= gfc_next_ascii_char ();
1378 gfc_current_locus
= w
;
1380 if (c
!= ',' && c
!= ')')
1383 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1385 /* Handle error elsewhere. */
1387 /* Eliminate a couple of common cases where we know we don't
1388 have a function argument. */
1389 if (symtree
== NULL
)
1391 gfc_get_sym_tree (name
, NULL
, &symtree
);
1392 gfc_set_sym_referenced (symtree
->n
.sym
);
1398 sym
= symtree
->n
.sym
;
1399 gfc_set_sym_referenced (sym
);
1400 if (sym
->attr
.flavor
!= FL_PROCEDURE
1401 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1404 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1406 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
,
1411 /* If the symbol is a function with itself as the result and
1412 is being defined, then we have a variable. */
1413 if (sym
->attr
.function
&& sym
->result
== sym
)
1415 if (gfc_current_ns
->proc_name
== sym
1416 || (gfc_current_ns
->parent
!= NULL
1417 && gfc_current_ns
->parent
->proc_name
== sym
))
1421 && (sym
->ns
== gfc_current_ns
1422 || sym
->ns
== gfc_current_ns
->parent
))
1424 gfc_entry_list
*el
= NULL
;
1426 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1436 e
= gfc_get_expr (); /* Leave it unknown for now */
1437 e
->symtree
= symtree
;
1438 e
->expr_type
= EXPR_VARIABLE
;
1439 e
->ts
.type
= BT_PROCEDURE
;
1446 gfc_current_locus
= where
;
1447 return gfc_match_expr (result
);
1451 /* Match a keyword argument. */
1454 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1456 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1457 gfc_actual_arglist
*a
;
1461 name_locus
= gfc_current_locus
;
1462 m
= gfc_match_name (name
);
1466 if (gfc_match_char ('=') != MATCH_YES
)
1472 m
= match_actual_arg (&actual
->expr
);
1476 /* Make sure this name has not appeared yet. */
1478 if (name
[0] != '\0')
1480 for (a
= base
; a
; a
= a
->next
)
1481 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1483 gfc_error ("Keyword '%s' at %C has already appeared in the "
1484 "current argument list", name
);
1489 actual
->name
= gfc_get_string (name
);
1493 gfc_current_locus
= name_locus
;
1498 /* Match an argument list function, such as %VAL. */
1501 match_arg_list_function (gfc_actual_arglist
*result
)
1503 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1507 old_locus
= gfc_current_locus
;
1509 if (gfc_match_char ('%') != MATCH_YES
)
1515 m
= gfc_match ("%n (", name
);
1519 if (name
[0] != '\0')
1524 if (strncmp (name
, "loc", 3) == 0)
1526 result
->name
= "%LOC";
1530 if (strncmp (name
, "ref", 3) == 0)
1532 result
->name
= "%REF";
1536 if (strncmp (name
, "val", 3) == 0)
1538 result
->name
= "%VAL";
1547 if (gfc_notify_std (GFC_STD_GNU
, "Extension: argument list "
1548 "function at %C") == FAILURE
)
1554 m
= match_actual_arg (&result
->expr
);
1558 if (gfc_match_char (')') != MATCH_YES
)
1567 gfc_current_locus
= old_locus
;
1572 /* Matches an actual argument list of a function or subroutine, from
1573 the opening parenthesis to the closing parenthesis. The argument
1574 list is assumed to allow keyword arguments because we don't know if
1575 the symbol associated with the procedure has an implicit interface
1576 or not. We make sure keywords are unique. If sub_flag is set,
1577 we're matching the argument list of a subroutine. */
1580 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1582 gfc_actual_arglist
*head
, *tail
;
1584 gfc_st_label
*label
;
1588 *argp
= tail
= NULL
;
1589 old_loc
= gfc_current_locus
;
1593 if (gfc_match_char ('(') == MATCH_NO
)
1594 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1596 if (gfc_match_char (')') == MATCH_YES
)
1603 head
= tail
= gfc_get_actual_arglist ();
1606 tail
->next
= gfc_get_actual_arglist ();
1610 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1612 m
= gfc_match_st_label (&label
);
1614 gfc_error ("Expected alternate return label at %C");
1618 tail
->label
= label
;
1622 /* After the first keyword argument is seen, the following
1623 arguments must also have keywords. */
1626 m
= match_keyword_arg (tail
, head
);
1628 if (m
== MATCH_ERROR
)
1632 gfc_error ("Missing keyword name in actual argument list at %C");
1639 /* Try an argument list function, like %VAL. */
1640 m
= match_arg_list_function (tail
);
1641 if (m
== MATCH_ERROR
)
1644 /* See if we have the first keyword argument. */
1647 m
= match_keyword_arg (tail
, head
);
1650 if (m
== MATCH_ERROR
)
1656 /* Try for a non-keyword argument. */
1657 m
= match_actual_arg (&tail
->expr
);
1658 if (m
== MATCH_ERROR
)
1667 if (gfc_match_char (')') == MATCH_YES
)
1669 if (gfc_match_char (',') != MATCH_YES
)
1677 gfc_error ("Syntax error in argument list at %C");
1680 gfc_free_actual_arglist (head
);
1681 gfc_current_locus
= old_loc
;
1687 /* Used by gfc_match_varspec() to extend the reference list by one
1691 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1693 if (primary
->ref
== NULL
)
1694 primary
->ref
= tail
= gfc_get_ref ();
1698 gfc_internal_error ("extend_ref(): Bad tail");
1699 tail
->next
= gfc_get_ref ();
1707 /* Match any additional specifications associated with the current
1708 variable like member references or substrings. If equiv_flag is
1709 set we only match stuff that is allowed inside an EQUIVALENCE
1710 statement. sub_flag tells whether we expect a type-bound procedure found
1711 to be a subroutine as part of CALL or a FUNCTION. */
1714 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
)
1716 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1717 gfc_ref
*substring
, *tail
;
1718 gfc_component
*component
;
1719 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1725 gfc_gobble_whitespace ();
1726 if ((equiv_flag
&& gfc_peek_ascii_char () == '(') || sym
->attr
.dimension
)
1728 /* In EQUIVALENCE, we don't know yet whether we are seeing
1729 an array, character variable or array of character
1730 variables. We'll leave the decision till resolve time. */
1731 tail
= extend_ref (primary
, tail
);
1732 tail
->type
= REF_ARRAY
;
1734 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1739 gfc_gobble_whitespace ();
1740 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1742 tail
= extend_ref (primary
, tail
);
1743 tail
->type
= REF_ARRAY
;
1745 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
);
1751 primary
->ts
= sym
->ts
;
1756 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1757 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1758 gfc_set_default_type (sym
, 0, sym
->ns
);
1760 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1761 goto check_substring
;
1763 sym
= sym
->ts
.derived
;
1770 m
= gfc_match_name (name
);
1772 gfc_error ("Expected structure component name at %C");
1776 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false);
1779 gfc_symbol
* tbp_sym
;
1784 gcc_assert (!tail
|| !tail
->next
);
1785 gcc_assert (primary
->expr_type
== EXPR_VARIABLE
);
1787 if (tbp
->n
.tb
->is_generic
)
1790 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1792 primary
->expr_type
= EXPR_COMPCALL
;
1793 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1794 primary
->value
.compcall
.name
= tbp
->name
;
1795 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1797 primary
->ts
= tbp_sym
->ts
;
1799 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1800 &primary
->value
.compcall
.actual
);
1801 if (m
== MATCH_ERROR
)
1806 primary
->value
.compcall
.actual
= NULL
;
1809 gfc_error ("Expected argument list at %C");
1817 component
= gfc_find_component (sym
, name
, false, false);
1818 if (component
== NULL
)
1821 tail
= extend_ref (primary
, tail
);
1822 tail
->type
= REF_COMPONENT
;
1824 tail
->u
.c
.component
= component
;
1825 tail
->u
.c
.sym
= sym
;
1827 primary
->ts
= component
->ts
;
1829 if (component
->as
!= NULL
)
1831 tail
= extend_ref (primary
, tail
);
1832 tail
->type
= REF_ARRAY
;
1834 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1839 if (component
->ts
.type
!= BT_DERIVED
1840 || gfc_match_char ('%') != MATCH_YES
)
1843 sym
= component
->ts
.derived
;
1848 if (primary
->ts
.type
== BT_UNKNOWN
)
1850 if (gfc_get_default_type (sym
, sym
->ns
)->type
== BT_CHARACTER
)
1852 gfc_set_default_type (sym
, 0, sym
->ns
);
1853 primary
->ts
= sym
->ts
;
1858 if (primary
->ts
.type
== BT_CHARACTER
)
1860 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1864 primary
->ref
= substring
;
1866 tail
->next
= substring
;
1868 if (primary
->expr_type
== EXPR_CONSTANT
)
1869 primary
->expr_type
= EXPR_SUBSTRING
;
1872 primary
->ts
.cl
= NULL
;
1879 gfc_clear_ts (&primary
->ts
);
1880 gfc_clear_ts (&sym
->ts
);
1893 /* Given an expression that is a variable, figure out what the
1894 ultimate variable's type and attribute is, traversing the reference
1895 structures if necessary.
1897 This subroutine is trickier than it looks. We start at the base
1898 symbol and store the attribute. Component references load a
1899 completely new attribute.
1901 A couple of rules come into play. Subobjects of targets are always
1902 targets themselves. If we see a component that goes through a
1903 pointer, then the expression must also be a target, since the
1904 pointer is associated with something (if it isn't core will soon be
1905 dumped). If we see a full part or section of an array, the
1906 expression is also an array.
1908 We can have at most one full array reference. */
1911 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
1913 int dimension
, pointer
, allocatable
, target
;
1914 symbol_attribute attr
;
1917 if (expr
->expr_type
!= EXPR_VARIABLE
)
1918 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1921 attr
= expr
->symtree
->n
.sym
->attr
;
1923 dimension
= attr
.dimension
;
1924 pointer
= attr
.pointer
;
1925 allocatable
= attr
.allocatable
;
1927 target
= attr
.target
;
1931 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1932 *ts
= expr
->symtree
->n
.sym
->ts
;
1934 for (; ref
; ref
= ref
->next
)
1939 switch (ref
->u
.ar
.type
)
1946 allocatable
= pointer
= 0;
1951 allocatable
= pointer
= 0;
1955 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1961 attr
= ref
->u
.c
.component
->attr
;
1964 *ts
= ref
->u
.c
.component
->ts
;
1965 /* Don't set the string length if a substring reference
1967 if (ts
->type
== BT_CHARACTER
1968 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
1972 pointer
= ref
->u
.c
.component
->attr
.pointer
;
1973 allocatable
= ref
->u
.c
.component
->attr
.allocatable
;
1980 allocatable
= pointer
= 0;
1984 attr
.dimension
= dimension
;
1985 attr
.pointer
= pointer
;
1986 attr
.allocatable
= allocatable
;
1987 attr
.target
= target
;
1993 /* Return the attribute from a general expression. */
1996 gfc_expr_attr (gfc_expr
*e
)
1998 symbol_attribute attr
;
2000 switch (e
->expr_type
)
2003 attr
= gfc_variable_attr (e
, NULL
);
2007 gfc_clear_attr (&attr
);
2009 if (e
->value
.function
.esym
!= NULL
)
2010 attr
= e
->value
.function
.esym
->result
->attr
;
2012 /* TODO: NULL() returns pointers. May have to take care of this
2018 gfc_clear_attr (&attr
);
2026 /* Match a structure constructor. The initial symbol has already been
2029 typedef struct gfc_structure_ctor_component
2034 struct gfc_structure_ctor_component
* next
;
2036 gfc_structure_ctor_component
;
2038 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2041 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2043 gfc_free (comp
->name
);
2044 gfc_free_expr (comp
->val
);
2048 /* Translate the component list into the actual constructor by sorting it in
2049 the order required; this also checks along the way that each and every
2050 component actually has an initializer and handles default initializers
2051 for components without explicit value given. */
2053 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2054 gfc_constructor
**ctor_head
, gfc_symbol
*sym
)
2056 gfc_structure_ctor_component
*comp_iter
;
2057 gfc_constructor
*ctor_tail
= NULL
;
2058 gfc_component
*comp
;
2060 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2062 gfc_structure_ctor_component
**next_ptr
;
2063 gfc_expr
*value
= NULL
;
2065 /* Try to find the initializer for the current component by name. */
2066 next_ptr
= comp_head
;
2067 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2069 if (!strcmp (comp_iter
->name
, comp
->name
))
2071 next_ptr
= &comp_iter
->next
;
2074 /* If an extension, try building the parent derived type by building
2075 a value expression for the parent derived type and calling self. */
2076 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2078 value
= gfc_get_expr ();
2079 value
->expr_type
= EXPR_STRUCTURE
;
2080 value
->value
.constructor
= NULL
;
2081 value
->ts
= comp
->ts
;
2082 value
->where
= gfc_current_locus
;
2084 if (build_actual_constructor (comp_head
, &value
->value
.constructor
,
2085 comp
->ts
.derived
) == FAILURE
)
2087 gfc_free_expr (value
);
2090 *ctor_head
= ctor_tail
= gfc_get_constructor ();
2091 ctor_tail
->expr
= value
;
2095 /* If it was not found, try the default initializer if there's any;
2096 otherwise, it's an error. */
2099 if (comp
->initializer
)
2101 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2102 " constructor with missing optional arguments"
2103 " at %C") == FAILURE
)
2105 value
= gfc_copy_expr (comp
->initializer
);
2109 gfc_error ("No initializer for component '%s' given in the"
2110 " structure constructor at %C!", comp
->name
);
2115 value
= comp_iter
->val
;
2117 /* Add the value to the constructor chain built. */
2120 ctor_tail
->next
= gfc_get_constructor ();
2121 ctor_tail
= ctor_tail
->next
;
2124 *ctor_head
= ctor_tail
= gfc_get_constructor ();
2126 ctor_tail
->expr
= value
;
2128 /* Remove the entry from the component list. We don't want the expression
2129 value to be free'd, so set it to NULL. */
2132 *next_ptr
= comp_iter
->next
;
2133 comp_iter
->val
= NULL
;
2134 gfc_free_structure_ctor_component (comp_iter
);
2141 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
,
2144 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2145 gfc_constructor
*ctor_head
, *ctor_tail
;
2146 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2150 const char* last_name
= NULL
;
2152 comp_tail
= comp_head
= NULL
;
2153 ctor_head
= ctor_tail
= NULL
;
2155 if (!parent
&& gfc_match_char ('(') != MATCH_YES
)
2158 where
= gfc_current_locus
;
2160 gfc_find_component (sym
, NULL
, false, true);
2162 /* Check that we're not about to construct an ABSTRACT type. */
2163 if (!parent
&& sym
->attr
.abstract
)
2165 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym
->name
);
2169 /* Match the component list and store it in a list together with the
2170 corresponding component names. Check for empty argument list first. */
2171 if (gfc_match_char (')') != MATCH_YES
)
2173 comp
= sym
->components
;
2176 gfc_component
*this_comp
= NULL
;
2179 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2182 comp_tail
->next
= gfc_get_structure_ctor_component ();
2183 comp_tail
= comp_tail
->next
;
2185 comp_tail
->name
= XCNEWVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
2186 comp_tail
->val
= NULL
;
2187 comp_tail
->where
= gfc_current_locus
;
2189 /* Try matching a component name. */
2190 if (gfc_match_name (comp_tail
->name
) == MATCH_YES
2191 && gfc_match_char ('=') == MATCH_YES
)
2193 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2194 " constructor with named arguments at %C")
2198 last_name
= comp_tail
->name
;
2203 /* Components without name are not allowed after the first named
2204 component initializer! */
2208 gfc_error ("Component initializer without name after"
2209 " component named %s at %C!", last_name
);
2211 gfc_error ("Too many components in structure constructor at"
2216 gfc_current_locus
= comp_tail
->where
;
2217 strncpy (comp_tail
->name
, comp
->name
, GFC_MAX_SYMBOL_LEN
+ 1);
2220 /* Find the current component in the structure definition and check
2221 its access is not private. */
2223 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2226 this_comp
= gfc_find_component (sym
,
2227 (const char *)comp_tail
->name
,
2229 comp
= NULL
; /* Reset needed! */
2232 /* Here we can check if a component name is given which does not
2233 correspond to any component of the defined structure. */
2237 /* Check if this component is already given a value. */
2238 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2239 comp_iter
= comp_iter
->next
)
2241 gcc_assert (comp_iter
);
2242 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2244 gfc_error ("Component '%s' is initialized twice in the"
2245 " structure constructor at %C!", comp_tail
->name
);
2250 /* Match the current initializer expression. */
2251 m
= gfc_match_expr (&comp_tail
->val
);
2254 if (m
== MATCH_ERROR
)
2257 /* If not explicitly a parent constructor, gather up the components
2259 if (comp
&& comp
== sym
->components
2260 && sym
->attr
.extension
2261 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2263 comp_tail
->val
->ts
.derived
!= this_comp
->ts
.derived
))
2265 gfc_current_locus
= where
;
2266 gfc_free_expr (comp_tail
->val
);
2267 comp_tail
->val
= NULL
;
2269 m
= gfc_match_structure_constructor (comp
->ts
.derived
,
2270 &comp_tail
->val
, true);
2273 if (m
== MATCH_ERROR
)
2280 if (parent
&& !comp
)
2284 while (gfc_match_char (',') == MATCH_YES
);
2286 if (!parent
&& gfc_match_char (')') != MATCH_YES
)
2290 if (build_actual_constructor (&comp_head
, &ctor_head
, sym
) == FAILURE
)
2293 /* No component should be left, as this should have caused an error in the
2294 loop constructing the component-list (name that does not correspond to any
2295 component in the structure definition). */
2296 if (comp_head
&& sym
->attr
.extension
)
2298 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2300 gfc_error ("component '%s' at %L has already been set by a "
2301 "parent derived type constructor", comp_iter
->name
,
2307 gcc_assert (!comp_head
);
2309 e
= gfc_get_expr ();
2311 e
->expr_type
= EXPR_STRUCTURE
;
2313 e
->ts
.type
= BT_DERIVED
;
2314 e
->ts
.derived
= sym
;
2317 e
->value
.constructor
= ctor_head
;
2323 gfc_error ("Syntax error in structure constructor at %C");
2326 for (comp_iter
= comp_head
; comp_iter
; )
2328 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2329 gfc_free_structure_ctor_component (comp_iter
);
2332 gfc_free_constructor (ctor_head
);
2337 /* If the symbol is an implicit do loop index and implicitly typed,
2338 it should not be host associated. Provide a symtree from the
2339 current namespace. */
2341 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2343 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2344 && (*sym
)->ns
!= gfc_current_ns
2345 && (*sym
)->attr
.implied_index
2346 && (*sym
)->attr
.implicit_type
2347 && !(*sym
)->attr
.use_assoc
)
2350 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
);
2353 *sym
= (*st
)->n
.sym
;
2359 /* Procedure pointer as function result: Replace the function symbol by the
2360 auto-generated hidden result variable named "ppr@". */
2363 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2365 /* Check for procedure pointer result variable. */
2366 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2367 && (*sym
)->result
&& (*sym
)->result
!= *sym
2368 && (*sym
)->result
->attr
.proc_pointer
2369 && (*sym
) == gfc_current_ns
->proc_name
2370 && (*sym
) == (*sym
)->result
->ns
->proc_name
2371 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2373 /* Automatic replacement with "hidden" result variable. */
2374 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2375 *sym
= (*sym
)->result
;
2376 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2383 /* Matches a variable name followed by anything that might follow it--
2384 array reference, argument list of a function, etc. */
2387 gfc_match_rvalue (gfc_expr
**result
)
2389 gfc_actual_arglist
*actual_arglist
;
2390 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2393 gfc_symtree
*symtree
;
2394 locus where
, old_loc
;
2402 m
= gfc_match_name (name
);
2406 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2407 && !gfc_current_ns
->has_import_set
)
2408 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
2410 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2415 sym
= symtree
->n
.sym
;
2417 where
= gfc_current_locus
;
2419 replace_hidden_procptr_result (&sym
, &symtree
);
2421 /* If this is an implicit do loop index and implicitly typed,
2422 it should not be host associated. */
2423 m
= check_for_implicit_index (&symtree
, &sym
);
2427 gfc_set_sym_referenced (sym
);
2428 sym
->attr
.implied_index
= 0;
2430 if (sym
->attr
.function
&& sym
->result
== sym
)
2432 /* See if this is a directly recursive function call. */
2433 gfc_gobble_whitespace ();
2434 if (sym
->attr
.recursive
2435 && gfc_peek_ascii_char () == '('
2436 && gfc_current_ns
->proc_name
== sym
2437 && !sym
->attr
.dimension
)
2439 gfc_error ("'%s' at %C is the name of a recursive function "
2440 "and so refers to the result variable. Use an "
2441 "explicit RESULT variable for direct recursion "
2442 "(12.5.2.1)", sym
->name
);
2446 if (gfc_current_ns
->proc_name
== sym
2447 || (gfc_current_ns
->parent
!= NULL
2448 && gfc_current_ns
->parent
->proc_name
== sym
))
2452 && (sym
->ns
== gfc_current_ns
2453 || sym
->ns
== gfc_current_ns
->parent
))
2455 gfc_entry_list
*el
= NULL
;
2457 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2463 if (gfc_matching_procptr_assignment
)
2466 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2469 if (sym
->attr
.generic
)
2470 goto generic_function
;
2472 switch (sym
->attr
.flavor
)
2476 e
= gfc_get_expr ();
2478 e
->expr_type
= EXPR_VARIABLE
;
2479 e
->symtree
= symtree
;
2481 m
= gfc_match_varspec (e
, 0, false);
2485 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2486 end up here. Unfortunately, sym->value->expr_type is set to
2487 EXPR_CONSTANT, and so the if () branch would be followed without
2488 the !sym->as check. */
2489 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2490 e
= gfc_copy_expr (sym
->value
);
2493 e
= gfc_get_expr ();
2494 e
->expr_type
= EXPR_VARIABLE
;
2497 e
->symtree
= symtree
;
2498 m
= gfc_match_varspec (e
, 0, false);
2500 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2503 /* Variable array references to derived type parameters cause
2504 all sorts of headaches in simplification. Treating such
2505 expressions as variable works just fine for all array
2507 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2509 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2510 if (ref
->type
== REF_ARRAY
)
2513 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2519 e
= gfc_get_expr ();
2520 e
->expr_type
= EXPR_VARIABLE
;
2521 e
->symtree
= symtree
;
2528 sym
= gfc_use_derived (sym
);
2532 m
= gfc_match_structure_constructor (sym
, &e
, false);
2535 /* If we're here, then the name is known to be the name of a
2536 procedure, yet it is not sure to be the name of a function. */
2539 /* Procedure Pointer Assignments. */
2541 if (gfc_matching_procptr_assignment
)
2543 gfc_gobble_whitespace ();
2544 if (gfc_peek_ascii_char () == '(')
2545 /* Parse functions returning a procptr. */
2548 if (gfc_is_intrinsic (sym
, 0, gfc_current_locus
)
2549 || gfc_is_intrinsic (sym
, 1, gfc_current_locus
))
2550 sym
->attr
.intrinsic
= 1;
2551 e
= gfc_get_expr ();
2552 e
->expr_type
= EXPR_VARIABLE
;
2553 e
->symtree
= symtree
;
2554 m
= gfc_match_varspec (e
, 0, false);
2558 if (sym
->attr
.subroutine
)
2560 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2566 /* At this point, the name has to be a non-statement function.
2567 If the name is the same as the current function being
2568 compiled, then we have a variable reference (to the function
2569 result) if the name is non-recursive. */
2571 st
= gfc_enclosing_unit (NULL
);
2573 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2575 && !sym
->attr
.recursive
)
2577 e
= gfc_get_expr ();
2578 e
->symtree
= symtree
;
2579 e
->expr_type
= EXPR_VARIABLE
;
2581 m
= gfc_match_varspec (e
, 0, false);
2585 /* Match a function reference. */
2587 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2590 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2591 gfc_error ("Statement function '%s' requires argument list at %C",
2594 gfc_error ("Function '%s' requires an argument list at %C",
2607 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2608 sym
= symtree
->n
.sym
;
2610 replace_hidden_procptr_result (&sym
, &symtree
);
2612 e
= gfc_get_expr ();
2613 e
->symtree
= symtree
;
2614 e
->expr_type
= EXPR_FUNCTION
;
2615 e
->value
.function
.actual
= actual_arglist
;
2616 e
->where
= gfc_current_locus
;
2618 if (sym
->as
!= NULL
)
2619 e
->rank
= sym
->as
->rank
;
2621 if (!sym
->attr
.function
2622 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2628 /* Check here for the existence of at least one argument for the
2629 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2630 argument(s) given will be checked in gfc_iso_c_func_interface,
2631 during resolution of the function call. */
2632 if (sym
->attr
.is_iso_c
== 1
2633 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2634 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2635 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2636 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2638 /* make sure we were given a param */
2639 if (actual_arglist
== NULL
)
2641 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2647 if (sym
->result
== NULL
)
2655 /* Special case for derived type variables that get their types
2656 via an IMPLICIT statement. This can't wait for the
2657 resolution phase. */
2659 if (gfc_peek_ascii_char () == '%'
2660 && sym
->ts
.type
== BT_UNKNOWN
2661 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2662 gfc_set_default_type (sym
, 0, sym
->ns
);
2664 /* If the symbol has a dimension attribute, the expression is a
2667 if (sym
->attr
.dimension
)
2669 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2670 sym
->name
, NULL
) == FAILURE
)
2676 e
= gfc_get_expr ();
2677 e
->symtree
= symtree
;
2678 e
->expr_type
= EXPR_VARIABLE
;
2679 m
= gfc_match_varspec (e
, 0, false);
2683 /* Name is not an array, so we peek to see if a '(' implies a
2684 function call or a substring reference. Otherwise the
2685 variable is just a scalar. */
2687 gfc_gobble_whitespace ();
2688 if (gfc_peek_ascii_char () != '(')
2690 /* Assume a scalar variable */
2691 e
= gfc_get_expr ();
2692 e
->symtree
= symtree
;
2693 e
->expr_type
= EXPR_VARIABLE
;
2695 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2696 sym
->name
, NULL
) == FAILURE
)
2702 /*FIXME:??? gfc_match_varspec does set this for us: */
2704 m
= gfc_match_varspec (e
, 0, false);
2708 /* See if this is a function reference with a keyword argument
2709 as first argument. We do this because otherwise a spurious
2710 symbol would end up in the symbol table. */
2712 old_loc
= gfc_current_locus
;
2713 m2
= gfc_match (" ( %n =", argname
);
2714 gfc_current_locus
= old_loc
;
2716 e
= gfc_get_expr ();
2717 e
->symtree
= symtree
;
2719 if (m2
!= MATCH_YES
)
2721 /* Try to figure out whether we're dealing with a character type.
2722 We're peeking ahead here, because we don't want to call
2723 match_substring if we're dealing with an implicitly typed
2724 non-character variable. */
2725 implicit_char
= false;
2726 if (sym
->ts
.type
== BT_UNKNOWN
)
2728 ts
= gfc_get_default_type (sym
,NULL
);
2729 if (ts
->type
== BT_CHARACTER
)
2730 implicit_char
= true;
2733 /* See if this could possibly be a substring reference of a name
2734 that we're not sure is a variable yet. */
2736 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
2737 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
2740 e
->expr_type
= EXPR_VARIABLE
;
2742 if (sym
->attr
.flavor
!= FL_VARIABLE
2743 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2744 sym
->name
, NULL
) == FAILURE
)
2750 if (sym
->ts
.type
== BT_UNKNOWN
2751 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2765 /* Give up, assume we have a function. */
2767 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2768 sym
= symtree
->n
.sym
;
2769 e
->expr_type
= EXPR_FUNCTION
;
2771 if (!sym
->attr
.function
2772 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2780 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2782 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2790 /* If our new function returns a character, array or structure
2791 type, it might have subsequent references. */
2793 m
= gfc_match_varspec (e
, 0, false);
2800 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2802 e
= gfc_get_expr ();
2803 e
->symtree
= symtree
;
2804 e
->expr_type
= EXPR_FUNCTION
;
2806 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2810 gfc_error ("Symbol at %C is not appropriate for an expression");
2826 /* Match a variable, i.e. something that can be assigned to. This
2827 starts as a symbol, can be a structure component or an array
2828 reference. It can be a function if the function doesn't have a
2829 separate RESULT variable. If the symbol has not been previously
2830 seen, we assume it is a variable.
2832 This function is called by two interface functions:
2833 gfc_match_variable, which has host_flag = 1, and
2834 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2835 match of the symbol to the local scope. */
2838 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
2846 /* Since nothing has any business being an lvalue in a module
2847 specification block, an interface block or a contains section,
2848 we force the changed_symbols mechanism to work by setting
2849 host_flag to 0. This prevents valid symbols that have the name
2850 of keywords, such as 'end', being turned into variables by
2851 failed matching to assignments for, e.g., END INTERFACE. */
2852 if (gfc_current_state () == COMP_MODULE
2853 || gfc_current_state () == COMP_INTERFACE
2854 || gfc_current_state () == COMP_CONTAINS
)
2857 where
= gfc_current_locus
;
2858 m
= gfc_match_sym_tree (&st
, host_flag
);
2864 /* If this is an implicit do loop index and implicitly typed,
2865 it should not be host associated. */
2866 m
= check_for_implicit_index (&st
, &sym
);
2870 sym
->attr
.implied_index
= 0;
2872 gfc_set_sym_referenced (sym
);
2873 switch (sym
->attr
.flavor
)
2876 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
)
2878 gfc_error ("Assigning to PROTECTED variable at %C");
2885 sym_flavor flavor
= FL_UNKNOWN
;
2887 gfc_gobble_whitespace ();
2889 if (sym
->attr
.external
|| sym
->attr
.procedure
2890 || sym
->attr
.function
|| sym
->attr
.subroutine
)
2891 flavor
= FL_PROCEDURE
;
2893 /* If it is not a procedure, is not typed and is host associated,
2894 we cannot give it a flavor yet. */
2895 else if (sym
->ns
== gfc_current_ns
->parent
2896 && sym
->ts
.type
== BT_UNKNOWN
)
2899 /* These are definitive indicators that this is a variable. */
2900 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
2901 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
2902 flavor
= FL_VARIABLE
;
2904 if (flavor
!= FL_UNKNOWN
2905 && gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
) == FAILURE
)
2912 gfc_error ("Named constant at %C in an EQUIVALENCE");
2914 gfc_error ("Cannot assign to a named constant at %C");
2919 /* Check for a nonrecursive function result variable. */
2920 if (sym
->attr
.function
2921 && !sym
->attr
.external
2922 && sym
->result
== sym
2923 && ((sym
== gfc_current_ns
->proc_name
2924 && sym
== gfc_current_ns
->proc_name
->result
)
2925 || (gfc_current_ns
->parent
2926 && sym
== gfc_current_ns
->parent
->proc_name
->result
)
2928 && sym
->ns
== gfc_current_ns
)
2930 && sym
->ns
== gfc_current_ns
->parent
)))
2932 /* If a function result is a derived type, then the derived
2933 type may still have to be resolved. */
2935 if (sym
->ts
.type
== BT_DERIVED
2936 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2941 if (sym
->attr
.proc_pointer
2942 || replace_hidden_procptr_result (&sym
, &st
) == SUCCESS
)
2945 /* Fall through to error */
2948 gfc_error ("'%s' at %C is not a variable", sym
->name
);
2952 /* Special case for derived type variables that get their types
2953 via an IMPLICIT statement. This can't wait for the
2954 resolution phase. */
2957 gfc_namespace
* implicit_ns
;
2959 if (gfc_current_ns
->proc_name
== sym
)
2960 implicit_ns
= gfc_current_ns
;
2962 implicit_ns
= sym
->ns
;
2964 if (gfc_peek_ascii_char () == '%'
2965 && sym
->ts
.type
== BT_UNKNOWN
2966 && gfc_get_default_type (sym
, implicit_ns
)->type
== BT_DERIVED
)
2967 gfc_set_default_type (sym
, 0, implicit_ns
);
2970 expr
= gfc_get_expr ();
2972 expr
->expr_type
= EXPR_VARIABLE
;
2975 expr
->where
= where
;
2977 /* Now see if we have to do more. */
2978 m
= gfc_match_varspec (expr
, equiv_flag
, false);
2981 gfc_free_expr (expr
);
2991 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
2993 return match_variable (result
, equiv_flag
, 1);
2998 gfc_match_equiv_variable (gfc_expr
**result
)
3000 return match_variable (result
, 1, 0);