1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
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/>. */
29 #include "constructor.h"
31 int matching_actual_arglist
= 0;
33 /* Matches a kind-parameter expression, which is either a named
34 symbolic constant or a nonnegative integer constant. If
35 successful, sets the kind value to the correct integer. */
38 match_kind_param (int *kind
)
40 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
45 m
= gfc_match_small_literal_int (kind
, NULL
);
49 m
= gfc_match_name (name
);
53 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
59 if (sym
->attr
.flavor
!= FL_PARAMETER
)
62 if (sym
->value
== NULL
)
65 p
= gfc_extract_int (sym
->value
, kind
);
69 gfc_set_sym_referenced (sym
);
78 /* Get a trailing kind-specification for non-character variables.
80 the integer kind value or:
81 -1 if an error was generated
82 -2 if no kind was found */
90 if (gfc_match_char ('_') != MATCH_YES
)
93 m
= match_kind_param (&kind
);
95 gfc_error ("Missing kind-parameter at %C");
97 return (m
== MATCH_YES
) ? kind
: -1;
101 /* Given a character and a radix, see if the character is a valid
102 digit in that radix. */
105 gfc_check_digit (char c
, int radix
)
112 r
= ('0' <= c
&& c
<= '1');
116 r
= ('0' <= c
&& c
<= '7');
120 r
= ('0' <= c
&& c
<= '9');
128 gfc_internal_error ("gfc_check_digit(): bad radix");
135 /* Match the digit string part of an integer if signflag is not set,
136 the signed digit string part if signflag is set. If the buffer
137 is NULL, we just count characters for the resolution pass. Returns
138 the number of characters matched, -1 for no match. */
141 match_digits (int signflag
, int radix
, char *buffer
)
148 c
= gfc_next_ascii_char ();
150 if (signflag
&& (c
== '+' || c
== '-'))
154 gfc_gobble_whitespace ();
155 c
= gfc_next_ascii_char ();
159 if (!gfc_check_digit (c
, radix
))
168 old_loc
= gfc_current_locus
;
169 c
= gfc_next_ascii_char ();
171 if (!gfc_check_digit (c
, radix
))
179 gfc_current_locus
= old_loc
;
185 /* Match an integer (digit string and optional kind).
186 A sign will be accepted if signflag is set. */
189 match_integer_constant (gfc_expr
**result
, int signflag
)
196 old_loc
= gfc_current_locus
;
197 gfc_gobble_whitespace ();
199 length
= match_digits (signflag
, 10, NULL
);
200 gfc_current_locus
= old_loc
;
204 buffer
= (char *) alloca (length
+ 1);
205 memset (buffer
, '\0', length
+ 1);
207 gfc_gobble_whitespace ();
209 match_digits (signflag
, 10, buffer
);
213 kind
= gfc_default_integer_kind
;
217 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
219 gfc_error ("Integer kind %d at %C not available", kind
);
223 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
225 if (gfc_range_check (e
) != ARITH_OK
)
227 gfc_error ("Integer too big for its kind at %C. This check can be "
228 "disabled with the option -fno-range-check");
239 /* Match a Hollerith constant. */
242 match_hollerith_constant (gfc_expr
**result
)
250 old_loc
= gfc_current_locus
;
251 gfc_gobble_whitespace ();
253 if (match_integer_constant (&e
, 0) == MATCH_YES
254 && gfc_match_char ('h') == MATCH_YES
)
256 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Hollerith constant "
260 msg
= gfc_extract_int (e
, &num
);
268 gfc_error ("Invalid Hollerith constant: %L must contain at least "
269 "one character", &old_loc
);
272 if (e
->ts
.kind
!= gfc_default_integer_kind
)
274 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
275 "should be default", &old_loc
);
281 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
284 /* Calculate padding needed to fit default integer memory. */
285 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
287 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
289 for (i
= 0; i
< num
; i
++)
291 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
292 if (! gfc_wide_fits_in_byte (c
))
294 gfc_error ("Invalid Hollerith constant at %L contains a "
295 "wide character", &old_loc
);
299 e
->representation
.string
[i
] = (unsigned char) c
;
302 /* Now pad with blanks and end with a null char. */
303 for (i
= 0; i
< pad
; i
++)
304 e
->representation
.string
[num
+ i
] = ' ';
306 e
->representation
.string
[num
+ i
] = '\0';
307 e
->representation
.length
= num
+ pad
;
316 gfc_current_locus
= old_loc
;
325 /* Match a binary, octal or hexadecimal constant that can be found in
326 a DATA statement. The standard permits b'010...', o'73...', and
327 z'a1...' where b, o, and z can be capital letters. This function
328 also accepts postfixed forms of the constants: '01...'b, '73...'o,
329 and 'a1...'z. An additional extension is the use of x for z. */
332 match_boz_constant (gfc_expr
**result
)
334 int radix
, length
, x_hex
, kind
;
335 locus old_loc
, start_loc
;
336 char *buffer
, post
, delim
;
339 start_loc
= old_loc
= gfc_current_locus
;
340 gfc_gobble_whitespace ();
343 switch (post
= gfc_next_ascii_char ())
365 radix
= 16; /* Set to accept any valid digit string. */
371 /* No whitespace allowed here. */
374 delim
= gfc_next_ascii_char ();
376 if (delim
!= '\'' && delim
!= '\"')
380 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
381 "constant at %C uses non-standard syntax")
385 old_loc
= gfc_current_locus
;
387 length
= match_digits (0, radix
, NULL
);
390 gfc_error ("Empty set of digits in BOZ constant at %C");
394 if (gfc_next_ascii_char () != delim
)
396 gfc_error ("Illegal character in BOZ constant at %C");
402 switch (gfc_next_ascii_char ())
419 if (gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ constant "
420 "at %C uses non-standard postfix syntax")
425 gfc_current_locus
= old_loc
;
427 buffer
= (char *) alloca (length
+ 1);
428 memset (buffer
, '\0', length
+ 1);
430 match_digits (0, radix
, buffer
);
431 gfc_next_ascii_char (); /* Eat delimiter. */
433 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
435 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
436 "If a data-stmt-constant is a boz-literal-constant, the corresponding
437 variable shall be of type integer. The boz-literal-constant is treated
438 as if it were an int-literal-constant with a kind-param that specifies
439 the representation method with the largest decimal exponent range
440 supported by the processor." */
442 kind
= gfc_max_integer_kind
;
443 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
445 /* Mark as boz variable. */
448 if (gfc_range_check (e
) != ARITH_OK
)
450 gfc_error ("Integer too big for integer kind %i at %C", kind
);
455 if (!gfc_in_match_data ()
456 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BOZ used outside a DATA "
465 gfc_current_locus
= start_loc
;
470 /* Match a real constant of some sort. Allow a signed constant if signflag
474 match_real_constant (gfc_expr
**result
, int signflag
)
476 int kind
, count
, seen_dp
, seen_digits
;
477 locus old_loc
, temp_loc
;
478 char *p
, *buffer
, c
, exp_char
;
482 old_loc
= gfc_current_locus
;
483 gfc_gobble_whitespace ();
493 c
= gfc_next_ascii_char ();
494 if (signflag
&& (c
== '+' || c
== '-'))
499 gfc_gobble_whitespace ();
500 c
= gfc_next_ascii_char ();
503 /* Scan significand. */
504 for (;; c
= gfc_next_ascii_char (), count
++)
511 /* Check to see if "." goes with a following operator like
513 temp_loc
= gfc_current_locus
;
514 c
= gfc_next_ascii_char ();
516 if (c
== 'e' || c
== 'd' || c
== 'q')
518 c
= gfc_next_ascii_char ();
520 goto done
; /* Operator named .e. or .d. */
524 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
526 gfc_current_locus
= temp_loc
;
540 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
545 c
= gfc_next_ascii_char ();
548 if (c
== '+' || c
== '-')
549 { /* optional sign */
550 c
= gfc_next_ascii_char ();
556 gfc_error ("Missing exponent in real number at %C");
562 c
= gfc_next_ascii_char ();
567 /* Check that we have a numeric constant. */
568 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
570 gfc_current_locus
= old_loc
;
574 /* Convert the number. */
575 gfc_current_locus
= old_loc
;
576 gfc_gobble_whitespace ();
578 buffer
= (char *) alloca (count
+ 1);
579 memset (buffer
, '\0', count
+ 1);
582 c
= gfc_next_ascii_char ();
583 if (c
== '+' || c
== '-')
585 gfc_gobble_whitespace ();
586 c
= gfc_next_ascii_char ();
589 /* Hack for mpfr_set_str(). */
592 if (c
== 'd' || c
== 'q')
600 c
= gfc_next_ascii_char ();
612 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
616 kind
= gfc_default_double_kind
;
621 kind
= gfc_default_real_kind
;
623 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
625 gfc_error ("Invalid real kind %d at %C", kind
);
630 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
632 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
634 switch (gfc_range_check (e
))
639 gfc_error ("Real constant overflows its kind at %C");
642 case ARITH_UNDERFLOW
:
643 if (gfc_option
.warn_underflow
)
644 gfc_warning ("Real constant underflows its kind at %C");
645 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
649 gfc_internal_error ("gfc_range_check() returned bad value");
661 /* Match a substring reference. */
664 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
666 gfc_expr
*start
, *end
;
674 old_loc
= gfc_current_locus
;
676 m
= gfc_match_char ('(');
680 if (gfc_match_char (':') != MATCH_YES
)
683 m
= gfc_match_init_expr (&start
);
685 m
= gfc_match_expr (&start
);
693 m
= gfc_match_char (':');
698 if (gfc_match_char (')') != MATCH_YES
)
701 m
= gfc_match_init_expr (&end
);
703 m
= gfc_match_expr (&end
);
707 if (m
== MATCH_ERROR
)
710 m
= gfc_match_char (')');
715 /* Optimize away the (:) reference. */
716 if (start
== NULL
&& end
== NULL
)
720 ref
= gfc_get_ref ();
722 ref
->type
= REF_SUBSTRING
;
724 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
725 ref
->u
.ss
.start
= start
;
726 if (end
== NULL
&& cl
)
727 end
= gfc_copy_expr (cl
->length
);
729 ref
->u
.ss
.length
= cl
;
736 gfc_error ("Syntax error in SUBSTRING specification at %C");
740 gfc_free_expr (start
);
743 gfc_current_locus
= old_loc
;
748 /* Reads the next character of a string constant, taking care to
749 return doubled delimiters on the input as a single instance of
752 Special return values for "ret" argument are:
753 -1 End of the string, as determined by the delimiter
754 -2 Unterminated string detected
756 Backslash codes are also expanded at this time. */
759 next_string_char (gfc_char_t delimiter
, int *ret
)
764 c
= gfc_next_char_literal (INSTRING_WARN
);
773 if (gfc_option
.flag_backslash
&& c
== '\\')
775 old_locus
= gfc_current_locus
;
777 if (gfc_match_special_char (&c
) == MATCH_NO
)
778 gfc_current_locus
= old_locus
;
780 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
781 gfc_warning ("Extension: backslash character at %C");
787 old_locus
= gfc_current_locus
;
788 c
= gfc_next_char_literal (NONSTRING
);
792 gfc_current_locus
= old_locus
;
799 /* Special case of gfc_match_name() that matches a parameter kind name
800 before a string constant. This takes case of the weird but legal
805 where kind____ is a parameter. gfc_match_name() will happily slurp
806 up all the underscores, which leads to problems. If we return
807 MATCH_YES, the parse pointer points to the final underscore, which
808 is not part of the name. We never return MATCH_ERROR-- errors in
809 the name will be detected later. */
812 match_charkind_name (char *name
)
818 gfc_gobble_whitespace ();
819 c
= gfc_next_ascii_char ();
828 old_loc
= gfc_current_locus
;
829 c
= gfc_next_ascii_char ();
833 peek
= gfc_peek_ascii_char ();
835 if (peek
== '\'' || peek
== '\"')
837 gfc_current_locus
= old_loc
;
845 && (c
!= '$' || !gfc_option
.flag_dollar_ok
))
849 if (++len
> GFC_MAX_SYMBOL_LEN
)
857 /* See if the current input matches a character constant. Lots of
858 contortions have to be done to match the kind parameter which comes
859 before the actual string. The main consideration is that we don't
860 want to error out too quickly. For example, we don't actually do
861 any validation of the kinds until we have actually seen a legal
862 delimiter. Using match_kind_param() generates errors too quickly. */
865 match_string_constant (gfc_expr
**result
)
867 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
868 int i
, kind
, length
, warn_ampersand
, ret
;
869 locus old_locus
, start_locus
;
874 gfc_char_t c
, delimiter
, *p
;
876 old_locus
= gfc_current_locus
;
878 gfc_gobble_whitespace ();
880 c
= gfc_next_char ();
881 if (c
== '\'' || c
== '"')
883 kind
= gfc_default_character_kind
;
884 start_locus
= gfc_current_locus
;
888 if (gfc_wide_is_digit (c
))
892 while (gfc_wide_is_digit (c
))
894 kind
= kind
* 10 + c
- '0';
897 c
= gfc_next_char ();
903 gfc_current_locus
= old_locus
;
905 m
= match_charkind_name (name
);
909 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
911 || sym
->attr
.flavor
!= FL_PARAMETER
)
915 c
= gfc_next_char ();
920 gfc_gobble_whitespace ();
921 c
= gfc_next_char ();
927 gfc_gobble_whitespace ();
929 c
= gfc_next_char ();
930 if (c
!= '\'' && c
!= '"')
933 start_locus
= gfc_current_locus
;
937 q
= gfc_extract_int (sym
->value
, &kind
);
943 gfc_set_sym_referenced (sym
);
946 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
948 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
953 /* Scan the string into a block of memory by first figuring out how
954 long it is, allocating the structure, then re-reading it. This
955 isn't particularly efficient, but string constants aren't that
956 common in most code. TODO: Use obstacks? */
963 c
= next_string_char (delimiter
, &ret
);
968 gfc_current_locus
= start_locus
;
969 gfc_error ("Unterminated character constant beginning at %C");
976 /* Peek at the next character to see if it is a b, o, z, or x for the
977 postfixed BOZ literal constants. */
978 peek
= gfc_peek_ascii_char ();
979 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
982 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
984 e
->ts
.is_c_interop
= 0;
987 gfc_current_locus
= start_locus
;
989 /* We disable the warning for the following loop as the warning has already
990 been printed in the loop above. */
991 warn_ampersand
= gfc_option
.warn_ampersand
;
992 gfc_option
.warn_ampersand
= 0;
994 p
= e
->value
.character
.string
;
995 for (i
= 0; i
< length
; i
++)
997 c
= next_string_char (delimiter
, &ret
);
999 if (!gfc_check_character_range (c
, kind
))
1001 gfc_error ("Character '%s' in string at %C is not representable "
1002 "in character kind %d", gfc_print_wide_char (c
), kind
);
1009 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1010 gfc_option
.warn_ampersand
= warn_ampersand
;
1012 next_string_char (delimiter
, &ret
);
1014 gfc_internal_error ("match_string_constant(): Delimiter not found");
1016 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1017 e
->expr_type
= EXPR_SUBSTRING
;
1024 gfc_current_locus
= old_locus
;
1029 /* Match a .true. or .false. Returns 1 if a .true. was found,
1030 0 if a .false. was found, and -1 otherwise. */
1032 match_logical_constant_string (void)
1034 locus orig_loc
= gfc_current_locus
;
1036 gfc_gobble_whitespace ();
1037 if (gfc_next_ascii_char () == '.')
1039 char ch
= gfc_next_ascii_char ();
1042 if (gfc_next_ascii_char () == 'a'
1043 && gfc_next_ascii_char () == 'l'
1044 && gfc_next_ascii_char () == 's'
1045 && gfc_next_ascii_char () == 'e'
1046 && gfc_next_ascii_char () == '.')
1047 /* Matched ".false.". */
1052 if (gfc_next_ascii_char () == 'r'
1053 && gfc_next_ascii_char () == 'u'
1054 && gfc_next_ascii_char () == 'e'
1055 && gfc_next_ascii_char () == '.')
1056 /* Matched ".true.". */
1060 gfc_current_locus
= orig_loc
;
1064 /* Match a .true. or .false. */
1067 match_logical_constant (gfc_expr
**result
)
1072 i
= match_logical_constant_string ();
1080 kind
= gfc_default_logical_kind
;
1082 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1084 gfc_error ("Bad kind for logical constant at %C");
1088 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1089 e
->ts
.is_c_interop
= 0;
1097 /* Match a real or imaginary part of a complex constant that is a
1098 symbolic constant. */
1101 match_sym_complex_part (gfc_expr
**result
)
1103 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1108 m
= gfc_match_name (name
);
1112 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1115 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1117 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1121 if (!gfc_numeric_ts (&sym
->value
->ts
))
1123 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1127 if (sym
->value
->rank
!= 0)
1129 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1133 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PARAMETER symbol in "
1134 "complex constant at %C") == FAILURE
)
1137 switch (sym
->value
->ts
.type
)
1140 e
= gfc_copy_expr (sym
->value
);
1144 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1150 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1156 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1159 *result
= e
; /* e is a scalar, real, constant expression. */
1163 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1168 /* Match a real or imaginary part of a complex number. */
1171 match_complex_part (gfc_expr
**result
)
1175 m
= match_sym_complex_part (result
);
1179 m
= match_real_constant (result
, 1);
1183 return match_integer_constant (result
, 1);
1187 /* Try to match a complex constant. */
1190 match_complex_constant (gfc_expr
**result
)
1192 gfc_expr
*e
, *real
, *imag
;
1193 gfc_error_buf old_error
;
1194 gfc_typespec target
;
1199 old_loc
= gfc_current_locus
;
1200 real
= imag
= e
= NULL
;
1202 m
= gfc_match_char ('(');
1206 gfc_push_error (&old_error
);
1208 m
= match_complex_part (&real
);
1211 gfc_free_error (&old_error
);
1215 if (gfc_match_char (',') == MATCH_NO
)
1217 gfc_pop_error (&old_error
);
1222 /* If m is error, then something was wrong with the real part and we
1223 assume we have a complex constant because we've seen the ','. An
1224 ambiguous case here is the start of an iterator list of some
1225 sort. These sort of lists are matched prior to coming here. */
1227 if (m
== MATCH_ERROR
)
1229 gfc_free_error (&old_error
);
1232 gfc_pop_error (&old_error
);
1234 m
= match_complex_part (&imag
);
1237 if (m
== MATCH_ERROR
)
1240 m
= gfc_match_char (')');
1243 /* Give the matcher for implied do-loops a chance to run. This
1244 yields a much saner error message for (/ (i, 4=i, 6) /). */
1245 if (gfc_peek_ascii_char () == '=')
1254 if (m
== MATCH_ERROR
)
1257 /* Decide on the kind of this complex number. */
1258 if (real
->ts
.type
== BT_REAL
)
1260 if (imag
->ts
.type
== BT_REAL
)
1261 kind
= gfc_kind_max (real
, imag
);
1263 kind
= real
->ts
.kind
;
1267 if (imag
->ts
.type
== BT_REAL
)
1268 kind
= imag
->ts
.kind
;
1270 kind
= gfc_default_real_kind
;
1272 target
.type
= BT_REAL
;
1274 target
.is_c_interop
= 0;
1275 target
.is_iso_c
= 0;
1277 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1278 gfc_convert_type (real
, &target
, 2);
1279 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1280 gfc_convert_type (imag
, &target
, 2);
1282 e
= gfc_convert_complex (real
, imag
, kind
);
1283 e
->where
= gfc_current_locus
;
1285 gfc_free_expr (real
);
1286 gfc_free_expr (imag
);
1292 gfc_error ("Syntax error in COMPLEX constant at %C");
1297 gfc_free_expr (real
);
1298 gfc_free_expr (imag
);
1299 gfc_current_locus
= old_loc
;
1305 /* Match constants in any of several forms. Returns nonzero for a
1306 match, zero for no match. */
1309 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1313 m
= match_complex_constant (result
);
1317 m
= match_string_constant (result
);
1321 m
= match_boz_constant (result
);
1325 m
= match_real_constant (result
, signflag
);
1329 m
= match_hollerith_constant (result
);
1333 m
= match_integer_constant (result
, signflag
);
1337 m
= match_logical_constant (result
);
1345 /* This checks if a symbol is the return value of an encompassing function.
1346 Function nesting can be maximally two levels deep, but we may have
1347 additional local namespaces like BLOCK etc. */
1350 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1352 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1356 if (ns
->proc_name
== sym
)
1364 /* Match a single actual argument value. An actual argument is
1365 usually an expression, but can also be a procedure name. If the
1366 argument is a single name, it is not always possible to tell
1367 whether the name is a dummy procedure or not. We treat these cases
1368 by creating an argument that looks like a dummy procedure and
1369 fixing things later during resolution. */
1372 match_actual_arg (gfc_expr
**result
)
1374 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1375 gfc_symtree
*symtree
;
1380 gfc_gobble_whitespace ();
1381 where
= gfc_current_locus
;
1383 switch (gfc_match_name (name
))
1392 w
= gfc_current_locus
;
1393 gfc_gobble_whitespace ();
1394 c
= gfc_next_ascii_char ();
1395 gfc_current_locus
= w
;
1397 if (c
!= ',' && c
!= ')')
1400 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1402 /* Handle error elsewhere. */
1404 /* Eliminate a couple of common cases where we know we don't
1405 have a function argument. */
1406 if (symtree
== NULL
)
1408 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1409 gfc_set_sym_referenced (symtree
->n
.sym
);
1415 sym
= symtree
->n
.sym
;
1416 gfc_set_sym_referenced (sym
);
1417 if (sym
->attr
.flavor
!= FL_PROCEDURE
1418 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1421 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1423 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
,
1428 /* If the symbol is a function with itself as the result and
1429 is being defined, then we have a variable. */
1430 if (sym
->attr
.function
&& sym
->result
== sym
)
1432 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1436 && (sym
->ns
== gfc_current_ns
1437 || sym
->ns
== gfc_current_ns
->parent
))
1439 gfc_entry_list
*el
= NULL
;
1441 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1451 e
= gfc_get_expr (); /* Leave it unknown for now */
1452 e
->symtree
= symtree
;
1453 e
->expr_type
= EXPR_VARIABLE
;
1454 e
->ts
.type
= BT_PROCEDURE
;
1461 gfc_current_locus
= where
;
1462 return gfc_match_expr (result
);
1466 /* Match a keyword argument. */
1469 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1471 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1472 gfc_actual_arglist
*a
;
1476 name_locus
= gfc_current_locus
;
1477 m
= gfc_match_name (name
);
1481 if (gfc_match_char ('=') != MATCH_YES
)
1487 m
= match_actual_arg (&actual
->expr
);
1491 /* Make sure this name has not appeared yet. */
1493 if (name
[0] != '\0')
1495 for (a
= base
; a
; a
= a
->next
)
1496 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1498 gfc_error ("Keyword '%s' at %C has already appeared in the "
1499 "current argument list", name
);
1504 actual
->name
= gfc_get_string (name
);
1508 gfc_current_locus
= name_locus
;
1513 /* Match an argument list function, such as %VAL. */
1516 match_arg_list_function (gfc_actual_arglist
*result
)
1518 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1522 old_locus
= gfc_current_locus
;
1524 if (gfc_match_char ('%') != MATCH_YES
)
1530 m
= gfc_match ("%n (", name
);
1534 if (name
[0] != '\0')
1539 if (strncmp (name
, "loc", 3) == 0)
1541 result
->name
= "%LOC";
1545 if (strncmp (name
, "ref", 3) == 0)
1547 result
->name
= "%REF";
1551 if (strncmp (name
, "val", 3) == 0)
1553 result
->name
= "%VAL";
1562 if (gfc_notify_std (GFC_STD_GNU
, "Extension: argument list "
1563 "function at %C") == FAILURE
)
1569 m
= match_actual_arg (&result
->expr
);
1573 if (gfc_match_char (')') != MATCH_YES
)
1582 gfc_current_locus
= old_locus
;
1587 /* Matches an actual argument list of a function or subroutine, from
1588 the opening parenthesis to the closing parenthesis. The argument
1589 list is assumed to allow keyword arguments because we don't know if
1590 the symbol associated with the procedure has an implicit interface
1591 or not. We make sure keywords are unique. If sub_flag is set,
1592 we're matching the argument list of a subroutine. */
1595 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1597 gfc_actual_arglist
*head
, *tail
;
1599 gfc_st_label
*label
;
1603 *argp
= tail
= NULL
;
1604 old_loc
= gfc_current_locus
;
1608 if (gfc_match_char ('(') == MATCH_NO
)
1609 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1611 if (gfc_match_char (')') == MATCH_YES
)
1615 matching_actual_arglist
++;
1620 head
= tail
= gfc_get_actual_arglist ();
1623 tail
->next
= gfc_get_actual_arglist ();
1627 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1629 m
= gfc_match_st_label (&label
);
1631 gfc_error ("Expected alternate return label at %C");
1635 tail
->label
= label
;
1639 /* After the first keyword argument is seen, the following
1640 arguments must also have keywords. */
1643 m
= match_keyword_arg (tail
, head
);
1645 if (m
== MATCH_ERROR
)
1649 gfc_error ("Missing keyword name in actual argument list at %C");
1656 /* Try an argument list function, like %VAL. */
1657 m
= match_arg_list_function (tail
);
1658 if (m
== MATCH_ERROR
)
1661 /* See if we have the first keyword argument. */
1664 m
= match_keyword_arg (tail
, head
);
1667 if (m
== MATCH_ERROR
)
1673 /* Try for a non-keyword argument. */
1674 m
= match_actual_arg (&tail
->expr
);
1675 if (m
== MATCH_ERROR
)
1684 if (gfc_match_char (')') == MATCH_YES
)
1686 if (gfc_match_char (',') != MATCH_YES
)
1691 matching_actual_arglist
--;
1695 gfc_error ("Syntax error in argument list at %C");
1698 gfc_free_actual_arglist (head
);
1699 gfc_current_locus
= old_loc
;
1700 matching_actual_arglist
--;
1705 /* Used by gfc_match_varspec() to extend the reference list by one
1709 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1711 if (primary
->ref
== NULL
)
1712 primary
->ref
= tail
= gfc_get_ref ();
1716 gfc_internal_error ("extend_ref(): Bad tail");
1717 tail
->next
= gfc_get_ref ();
1725 /* Match any additional specifications associated with the current
1726 variable like member references or substrings. If equiv_flag is
1727 set we only match stuff that is allowed inside an EQUIVALENCE
1728 statement. sub_flag tells whether we expect a type-bound procedure found
1729 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1730 components, 'ppc_arg' determines whether the PPC may be called (with an
1731 argument list), or whether it may just be referred to as a pointer. */
1734 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1737 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1738 gfc_ref
*substring
, *tail
;
1739 gfc_component
*component
;
1740 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1746 gfc_gobble_whitespace ();
1748 if (gfc_peek_ascii_char () == '[')
1750 if (sym
->attr
.dimension
)
1752 gfc_error ("Array section designator, e.g. '(:)', is required "
1753 "besides the coarray designator '[...]' at %C");
1756 if (!sym
->attr
.codimension
)
1758 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1764 /* For associate names, we may not yet know whether they are arrays or not.
1765 Thus if we have one and parentheses follow, we have to assume that it
1766 actually is one for now. The final decision will be made at
1767 resolution time, of course. */
1768 if (sym
->assoc
&& gfc_peek_ascii_char () == '(')
1769 sym
->attr
.dimension
= 1;
1771 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1772 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1773 || (sym
->attr
.dimension
&& !sym
->attr
.proc_pointer
1774 && !gfc_is_proc_ptr_comp (primary
, NULL
)
1775 && !(gfc_matching_procptr_assignment
1776 && sym
->attr
.flavor
== FL_PROCEDURE
))
1777 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1778 && CLASS_DATA (sym
)->attr
.dimension
))
1780 /* In EQUIVALENCE, we don't know yet whether we are seeing
1781 an array, character variable or array of character
1782 variables. We'll leave the decision till resolve time. */
1783 tail
= extend_ref (primary
, tail
);
1784 tail
->type
= REF_ARRAY
;
1786 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1788 sym
->ts
.type
== BT_CLASS
1789 ? (CLASS_DATA (sym
)->as
1790 ? CLASS_DATA (sym
)->as
->corank
: 0)
1791 : (sym
->as
? sym
->as
->corank
: 0));
1795 gfc_gobble_whitespace ();
1796 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1798 tail
= extend_ref (primary
, tail
);
1799 tail
->type
= REF_ARRAY
;
1801 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1807 primary
->ts
= sym
->ts
;
1812 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1813 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1814 gfc_set_default_type (sym
, 0, sym
->ns
);
1816 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1817 || gfc_match_char ('%') != MATCH_YES
)
1818 goto check_substring
;
1820 sym
= sym
->ts
.u
.derived
;
1827 m
= gfc_match_name (name
);
1829 gfc_error ("Expected structure component name at %C");
1833 if (sym
->f2k_derived
)
1834 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1840 gfc_symbol
* tbp_sym
;
1845 gcc_assert (!tail
|| !tail
->next
);
1846 gcc_assert (primary
->expr_type
== EXPR_VARIABLE
);
1848 if (tbp
->n
.tb
->is_generic
)
1851 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1853 primary
->expr_type
= EXPR_COMPCALL
;
1854 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1855 primary
->value
.compcall
.name
= tbp
->name
;
1856 primary
->value
.compcall
.ignore_pass
= 0;
1857 primary
->value
.compcall
.assign
= 0;
1858 primary
->value
.compcall
.base_object
= NULL
;
1859 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1861 primary
->ts
= tbp_sym
->ts
;
1863 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1864 &primary
->value
.compcall
.actual
);
1865 if (m
== MATCH_ERROR
)
1870 primary
->value
.compcall
.actual
= NULL
;
1873 gfc_error ("Expected argument list at %C");
1881 component
= gfc_find_component (sym
, name
, false, false);
1882 if (component
== NULL
)
1885 tail
= extend_ref (primary
, tail
);
1886 tail
->type
= REF_COMPONENT
;
1888 tail
->u
.c
.component
= component
;
1889 tail
->u
.c
.sym
= sym
;
1891 primary
->ts
= component
->ts
;
1893 if (component
->attr
.proc_pointer
&& ppc_arg
1894 && !gfc_matching_procptr_assignment
)
1896 /* Procedure pointer component call: Look for argument list. */
1897 m
= gfc_match_actual_arglist (sub_flag
,
1898 &primary
->value
.compcall
.actual
);
1899 if (m
== MATCH_ERROR
)
1902 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
1903 && !matching_actual_arglist
)
1905 gfc_error ("Procedure pointer component '%s' requires an "
1906 "argument list at %C", component
->name
);
1911 primary
->expr_type
= EXPR_PPC
;
1916 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
1918 tail
= extend_ref (primary
, tail
);
1919 tail
->type
= REF_ARRAY
;
1921 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
1922 component
->as
->corank
);
1926 else if (component
->ts
.type
== BT_CLASS
1927 && CLASS_DATA (component
)->as
!= NULL
1928 && !component
->attr
.proc_pointer
)
1930 tail
= extend_ref (primary
, tail
);
1931 tail
->type
= REF_ARRAY
;
1933 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
1935 CLASS_DATA (component
)->as
->corank
);
1940 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
1941 || gfc_match_char ('%') != MATCH_YES
)
1944 sym
= component
->ts
.u
.derived
;
1949 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
1951 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
1953 gfc_set_default_type (sym
, 0, sym
->ns
);
1954 primary
->ts
= sym
->ts
;
1959 if (primary
->ts
.type
== BT_CHARACTER
)
1961 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
1965 primary
->ref
= substring
;
1967 tail
->next
= substring
;
1969 if (primary
->expr_type
== EXPR_CONSTANT
)
1970 primary
->expr_type
= EXPR_SUBSTRING
;
1973 primary
->ts
.u
.cl
= NULL
;
1980 gfc_clear_ts (&primary
->ts
);
1981 gfc_clear_ts (&sym
->ts
);
1991 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
1993 gfc_error ("Coindexed procedure-pointer component at %C");
2001 /* Given an expression that is a variable, figure out what the
2002 ultimate variable's type and attribute is, traversing the reference
2003 structures if necessary.
2005 This subroutine is trickier than it looks. We start at the base
2006 symbol and store the attribute. Component references load a
2007 completely new attribute.
2009 A couple of rules come into play. Subobjects of targets are always
2010 targets themselves. If we see a component that goes through a
2011 pointer, then the expression must also be a target, since the
2012 pointer is associated with something (if it isn't core will soon be
2013 dumped). If we see a full part or section of an array, the
2014 expression is also an array.
2016 We can have at most one full array reference. */
2019 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2021 int dimension
, pointer
, allocatable
, target
;
2022 symbol_attribute attr
;
2025 gfc_component
*comp
;
2027 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2028 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2030 sym
= expr
->symtree
->n
.sym
;
2033 if (sym
->ts
.type
== BT_CLASS
)
2035 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2036 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2037 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2041 dimension
= attr
.dimension
;
2042 pointer
= attr
.pointer
;
2043 allocatable
= attr
.allocatable
;
2046 target
= attr
.target
;
2047 if (pointer
|| attr
.proc_pointer
)
2050 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2053 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2058 switch (ref
->u
.ar
.type
)
2065 allocatable
= pointer
= 0;
2070 /* Handle coarrays. */
2071 if (ref
->u
.ar
.dimen
> 0)
2072 allocatable
= pointer
= 0;
2076 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2082 comp
= ref
->u
.c
.component
;
2087 /* Don't set the string length if a substring reference
2089 if (ts
->type
== BT_CHARACTER
2090 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2094 if (comp
->ts
.type
== BT_CLASS
)
2096 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2097 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2101 pointer
= comp
->attr
.pointer
;
2102 allocatable
= comp
->attr
.allocatable
;
2104 if (pointer
|| attr
.proc_pointer
)
2110 allocatable
= pointer
= 0;
2114 attr
.dimension
= dimension
;
2115 attr
.pointer
= pointer
;
2116 attr
.allocatable
= allocatable
;
2117 attr
.target
= target
;
2118 attr
.save
= sym
->attr
.save
;
2124 /* Return the attribute from a general expression. */
2127 gfc_expr_attr (gfc_expr
*e
)
2129 symbol_attribute attr
;
2131 switch (e
->expr_type
)
2134 attr
= gfc_variable_attr (e
, NULL
);
2138 gfc_clear_attr (&attr
);
2140 if (e
->value
.function
.esym
!= NULL
)
2142 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2144 if (sym
->ts
.type
== BT_CLASS
)
2146 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2147 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2148 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2152 attr
= gfc_variable_attr (e
, NULL
);
2154 /* TODO: NULL() returns pointers. May have to take care of this
2160 gfc_clear_attr (&attr
);
2168 /* Match a structure constructor. The initial symbol has already been
2171 typedef struct gfc_structure_ctor_component
2176 struct gfc_structure_ctor_component
* next
;
2178 gfc_structure_ctor_component
;
2180 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2183 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2185 gfc_free (comp
->name
);
2186 gfc_free_expr (comp
->val
);
2191 /* Translate the component list into the actual constructor by sorting it in
2192 the order required; this also checks along the way that each and every
2193 component actually has an initializer and handles default initializers
2194 for components without explicit value given. */
2196 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2197 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2199 gfc_structure_ctor_component
*comp_iter
;
2200 gfc_component
*comp
;
2202 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2204 gfc_structure_ctor_component
**next_ptr
;
2205 gfc_expr
*value
= NULL
;
2207 /* Try to find the initializer for the current component by name. */
2208 next_ptr
= comp_head
;
2209 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2211 if (!strcmp (comp_iter
->name
, comp
->name
))
2213 next_ptr
= &comp_iter
->next
;
2216 /* If an extension, try building the parent derived type by building
2217 a value expression for the parent derived type and calling self. */
2218 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2220 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2222 &gfc_current_locus
);
2223 value
->ts
= comp
->ts
;
2225 if (build_actual_constructor (comp_head
, &value
->value
.constructor
,
2226 comp
->ts
.u
.derived
) == FAILURE
)
2228 gfc_free_expr (value
);
2232 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2236 /* If it was not found, try the default initializer if there's any;
2237 otherwise, it's an error. */
2240 if (comp
->initializer
)
2242 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2243 " constructor with missing optional arguments"
2244 " at %C") == FAILURE
)
2246 value
= gfc_copy_expr (comp
->initializer
);
2250 gfc_error ("No initializer for component '%s' given in the"
2251 " structure constructor at %C!", comp
->name
);
2256 value
= comp_iter
->val
;
2258 /* Add the value to the constructor chain built. */
2259 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2261 /* Remove the entry from the component list. We don't want the expression
2262 value to be free'd, so set it to NULL. */
2265 *next_ptr
= comp_iter
->next
;
2266 comp_iter
->val
= NULL
;
2267 gfc_free_structure_ctor_component (comp_iter
);
2274 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
,
2277 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2278 gfc_constructor_base ctor_head
= NULL
;
2279 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2283 const char* last_name
= NULL
;
2285 comp_tail
= comp_head
= NULL
;
2287 if (!parent
&& gfc_match_char ('(') != MATCH_YES
)
2290 where
= gfc_current_locus
;
2292 gfc_find_component (sym
, NULL
, false, true);
2294 /* Check that we're not about to construct an ABSTRACT type. */
2295 if (!parent
&& sym
->attr
.abstract
)
2297 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym
->name
);
2301 /* Match the component list and store it in a list together with the
2302 corresponding component names. Check for empty argument list first. */
2303 if (gfc_match_char (')') != MATCH_YES
)
2305 comp
= sym
->components
;
2308 gfc_component
*this_comp
= NULL
;
2311 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2314 comp_tail
->next
= gfc_get_structure_ctor_component ();
2315 comp_tail
= comp_tail
->next
;
2317 comp_tail
->name
= XCNEWVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
2318 comp_tail
->val
= NULL
;
2319 comp_tail
->where
= gfc_current_locus
;
2321 /* Try matching a component name. */
2322 if (gfc_match_name (comp_tail
->name
) == MATCH_YES
2323 && gfc_match_char ('=') == MATCH_YES
)
2325 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2326 " constructor with named arguments at %C")
2330 last_name
= comp_tail
->name
;
2335 /* Components without name are not allowed after the first named
2336 component initializer! */
2340 gfc_error ("Component initializer without name after"
2341 " component named %s at %C!", last_name
);
2343 gfc_error ("Too many components in structure constructor at"
2348 gfc_current_locus
= comp_tail
->where
;
2349 strncpy (comp_tail
->name
, comp
->name
, GFC_MAX_SYMBOL_LEN
+ 1);
2352 /* Find the current component in the structure definition and check
2353 its access is not private. */
2355 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2358 this_comp
= gfc_find_component (sym
,
2359 (const char *)comp_tail
->name
,
2361 comp
= NULL
; /* Reset needed! */
2364 /* Here we can check if a component name is given which does not
2365 correspond to any component of the defined structure. */
2369 /* Check if this component is already given a value. */
2370 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2371 comp_iter
= comp_iter
->next
)
2373 gcc_assert (comp_iter
);
2374 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2376 gfc_error ("Component '%s' is initialized twice in the"
2377 " structure constructor at %C!", comp_tail
->name
);
2382 /* Match the current initializer expression. */
2383 m
= gfc_match_expr (&comp_tail
->val
);
2386 if (m
== MATCH_ERROR
)
2389 /* F2008, R457/C725, for PURE C1283. */
2390 if (this_comp
->attr
.pointer
&& gfc_is_coindexed (comp_tail
->val
))
2392 gfc_error ("Coindexed expression to pointer component '%s' in "
2393 "structure constructor at %C!", comp_tail
->name
);
2398 /* If not explicitly a parent constructor, gather up the components
2400 if (comp
&& comp
== sym
->components
2401 && sym
->attr
.extension
2402 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2404 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2406 gfc_current_locus
= where
;
2407 gfc_free_expr (comp_tail
->val
);
2408 comp_tail
->val
= NULL
;
2410 m
= gfc_match_structure_constructor (comp
->ts
.u
.derived
,
2411 &comp_tail
->val
, true);
2414 if (m
== MATCH_ERROR
)
2421 if (parent
&& !comp
)
2425 while (gfc_match_char (',') == MATCH_YES
);
2427 if (!parent
&& gfc_match_char (')') != MATCH_YES
)
2431 if (build_actual_constructor (&comp_head
, &ctor_head
, sym
) == FAILURE
)
2434 /* No component should be left, as this should have caused an error in the
2435 loop constructing the component-list (name that does not correspond to any
2436 component in the structure definition). */
2439 gcc_assert (sym
->attr
.extension
);
2440 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2442 gfc_error ("component '%s' at %L has already been set by a "
2443 "parent derived type constructor", comp_iter
->name
,
2449 e
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &where
);
2450 e
->ts
.u
.derived
= sym
;
2451 e
->value
.constructor
= ctor_head
;
2457 gfc_error ("Syntax error in structure constructor at %C");
2460 for (comp_iter
= comp_head
; comp_iter
; )
2462 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2463 gfc_free_structure_ctor_component (comp_iter
);
2466 gfc_constructor_free (ctor_head
);
2471 /* If the symbol is an implicit do loop index and implicitly typed,
2472 it should not be host associated. Provide a symtree from the
2473 current namespace. */
2475 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2477 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2478 && (*sym
)->ns
!= gfc_current_ns
2479 && (*sym
)->attr
.implied_index
2480 && (*sym
)->attr
.implicit_type
2481 && !(*sym
)->attr
.use_assoc
)
2484 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2487 *sym
= (*st
)->n
.sym
;
2493 /* Procedure pointer as function result: Replace the function symbol by the
2494 auto-generated hidden result variable named "ppr@". */
2497 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2499 /* Check for procedure pointer result variable. */
2500 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2501 && (*sym
)->result
&& (*sym
)->result
!= *sym
2502 && (*sym
)->result
->attr
.proc_pointer
2503 && (*sym
) == gfc_current_ns
->proc_name
2504 && (*sym
) == (*sym
)->result
->ns
->proc_name
2505 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2507 /* Automatic replacement with "hidden" result variable. */
2508 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2509 *sym
= (*sym
)->result
;
2510 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2517 /* Matches a variable name followed by anything that might follow it--
2518 array reference, argument list of a function, etc. */
2521 gfc_match_rvalue (gfc_expr
**result
)
2523 gfc_actual_arglist
*actual_arglist
;
2524 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2527 gfc_symtree
*symtree
;
2528 locus where
, old_loc
;
2536 m
= gfc_match_name (name
);
2540 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2541 && !gfc_current_ns
->has_import_set
)
2542 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2544 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2549 sym
= symtree
->n
.sym
;
2551 where
= gfc_current_locus
;
2553 replace_hidden_procptr_result (&sym
, &symtree
);
2555 /* If this is an implicit do loop index and implicitly typed,
2556 it should not be host associated. */
2557 m
= check_for_implicit_index (&symtree
, &sym
);
2561 gfc_set_sym_referenced (sym
);
2562 sym
->attr
.implied_index
= 0;
2564 if (sym
->attr
.function
&& sym
->result
== sym
)
2566 /* See if this is a directly recursive function call. */
2567 gfc_gobble_whitespace ();
2568 if (sym
->attr
.recursive
2569 && gfc_peek_ascii_char () == '('
2570 && gfc_current_ns
->proc_name
== sym
2571 && !sym
->attr
.dimension
)
2573 gfc_error ("'%s' at %C is the name of a recursive function "
2574 "and so refers to the result variable. Use an "
2575 "explicit RESULT variable for direct recursion "
2576 "(12.5.2.1)", sym
->name
);
2580 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2584 && (sym
->ns
== gfc_current_ns
2585 || sym
->ns
== gfc_current_ns
->parent
))
2587 gfc_entry_list
*el
= NULL
;
2589 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2595 if (gfc_matching_procptr_assignment
)
2598 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2601 if (sym
->attr
.generic
)
2602 goto generic_function
;
2604 switch (sym
->attr
.flavor
)
2608 e
= gfc_get_expr ();
2610 e
->expr_type
= EXPR_VARIABLE
;
2611 e
->symtree
= symtree
;
2613 m
= gfc_match_varspec (e
, 0, false, true);
2617 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2618 end up here. Unfortunately, sym->value->expr_type is set to
2619 EXPR_CONSTANT, and so the if () branch would be followed without
2620 the !sym->as check. */
2621 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2622 e
= gfc_copy_expr (sym
->value
);
2625 e
= gfc_get_expr ();
2626 e
->expr_type
= EXPR_VARIABLE
;
2629 e
->symtree
= symtree
;
2630 m
= gfc_match_varspec (e
, 0, false, true);
2632 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2635 /* Variable array references to derived type parameters cause
2636 all sorts of headaches in simplification. Treating such
2637 expressions as variable works just fine for all array
2639 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2641 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2642 if (ref
->type
== REF_ARRAY
)
2645 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2651 e
= gfc_get_expr ();
2652 e
->expr_type
= EXPR_VARIABLE
;
2653 e
->symtree
= symtree
;
2660 sym
= gfc_use_derived (sym
);
2664 m
= gfc_match_structure_constructor (sym
, &e
, false);
2667 /* If we're here, then the name is known to be the name of a
2668 procedure, yet it is not sure to be the name of a function. */
2671 /* Procedure Pointer Assignments. */
2673 if (gfc_matching_procptr_assignment
)
2675 gfc_gobble_whitespace ();
2676 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2677 /* Parse functions returning a procptr. */
2680 if (gfc_is_intrinsic (sym
, 0, gfc_current_locus
)
2681 || gfc_is_intrinsic (sym
, 1, gfc_current_locus
))
2682 sym
->attr
.intrinsic
= 1;
2683 e
= gfc_get_expr ();
2684 e
->expr_type
= EXPR_VARIABLE
;
2685 e
->symtree
= symtree
;
2686 m
= gfc_match_varspec (e
, 0, false, true);
2690 if (sym
->attr
.subroutine
)
2692 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2698 /* At this point, the name has to be a non-statement function.
2699 If the name is the same as the current function being
2700 compiled, then we have a variable reference (to the function
2701 result) if the name is non-recursive. */
2703 st
= gfc_enclosing_unit (NULL
);
2705 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2707 && !sym
->attr
.recursive
)
2709 e
= gfc_get_expr ();
2710 e
->symtree
= symtree
;
2711 e
->expr_type
= EXPR_VARIABLE
;
2713 m
= gfc_match_varspec (e
, 0, false, true);
2717 /* Match a function reference. */
2719 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2722 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2723 gfc_error ("Statement function '%s' requires argument list at %C",
2726 gfc_error ("Function '%s' requires an argument list at %C",
2739 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2740 sym
= symtree
->n
.sym
;
2742 replace_hidden_procptr_result (&sym
, &symtree
);
2744 e
= gfc_get_expr ();
2745 e
->symtree
= symtree
;
2746 e
->expr_type
= EXPR_FUNCTION
;
2747 e
->value
.function
.actual
= actual_arglist
;
2748 e
->where
= gfc_current_locus
;
2750 if (sym
->as
!= NULL
)
2751 e
->rank
= sym
->as
->rank
;
2753 if (!sym
->attr
.function
2754 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2760 /* Check here for the existence of at least one argument for the
2761 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2762 argument(s) given will be checked in gfc_iso_c_func_interface,
2763 during resolution of the function call. */
2764 if (sym
->attr
.is_iso_c
== 1
2765 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2766 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2767 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2768 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2770 /* make sure we were given a param */
2771 if (actual_arglist
== NULL
)
2773 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2779 if (sym
->result
== NULL
)
2787 /* Special case for derived type variables that get their types
2788 via an IMPLICIT statement. This can't wait for the
2789 resolution phase. */
2791 if (gfc_peek_ascii_char () == '%'
2792 && sym
->ts
.type
== BT_UNKNOWN
2793 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2794 gfc_set_default_type (sym
, 0, sym
->ns
);
2796 /* If the symbol has a dimension attribute, the expression is a
2799 if (sym
->attr
.dimension
)
2801 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2802 sym
->name
, NULL
) == FAILURE
)
2808 e
= gfc_get_expr ();
2809 e
->symtree
= symtree
;
2810 e
->expr_type
= EXPR_VARIABLE
;
2811 m
= gfc_match_varspec (e
, 0, false, true);
2815 /* Name is not an array, so we peek to see if a '(' implies a
2816 function call or a substring reference. Otherwise the
2817 variable is just a scalar. */
2819 gfc_gobble_whitespace ();
2820 if (gfc_peek_ascii_char () != '(')
2822 /* Assume a scalar variable */
2823 e
= gfc_get_expr ();
2824 e
->symtree
= symtree
;
2825 e
->expr_type
= EXPR_VARIABLE
;
2827 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2828 sym
->name
, NULL
) == FAILURE
)
2834 /*FIXME:??? gfc_match_varspec does set this for us: */
2836 m
= gfc_match_varspec (e
, 0, false, true);
2840 /* See if this is a function reference with a keyword argument
2841 as first argument. We do this because otherwise a spurious
2842 symbol would end up in the symbol table. */
2844 old_loc
= gfc_current_locus
;
2845 m2
= gfc_match (" ( %n =", argname
);
2846 gfc_current_locus
= old_loc
;
2848 e
= gfc_get_expr ();
2849 e
->symtree
= symtree
;
2851 if (m2
!= MATCH_YES
)
2853 /* Try to figure out whether we're dealing with a character type.
2854 We're peeking ahead here, because we don't want to call
2855 match_substring if we're dealing with an implicitly typed
2856 non-character variable. */
2857 implicit_char
= false;
2858 if (sym
->ts
.type
== BT_UNKNOWN
)
2860 ts
= gfc_get_default_type (sym
->name
, NULL
);
2861 if (ts
->type
== BT_CHARACTER
)
2862 implicit_char
= true;
2865 /* See if this could possibly be a substring reference of a name
2866 that we're not sure is a variable yet. */
2868 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
2869 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
2872 e
->expr_type
= EXPR_VARIABLE
;
2874 if (sym
->attr
.flavor
!= FL_VARIABLE
2875 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2876 sym
->name
, NULL
) == FAILURE
)
2882 if (sym
->ts
.type
== BT_UNKNOWN
2883 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2897 /* Give up, assume we have a function. */
2899 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
2900 sym
= symtree
->n
.sym
;
2901 e
->expr_type
= EXPR_FUNCTION
;
2903 if (!sym
->attr
.function
2904 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2912 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2914 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2922 /* If our new function returns a character, array or structure
2923 type, it might have subsequent references. */
2925 m
= gfc_match_varspec (e
, 0, false, true);
2932 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
2934 e
= gfc_get_expr ();
2935 e
->symtree
= symtree
;
2936 e
->expr_type
= EXPR_FUNCTION
;
2938 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2942 gfc_error ("Symbol at %C is not appropriate for an expression");
2958 /* Match a variable, i.e. something that can be assigned to. This
2959 starts as a symbol, can be a structure component or an array
2960 reference. It can be a function if the function doesn't have a
2961 separate RESULT variable. If the symbol has not been previously
2962 seen, we assume it is a variable.
2964 This function is called by two interface functions:
2965 gfc_match_variable, which has host_flag = 1, and
2966 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2967 match of the symbol to the local scope. */
2970 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
2978 /* Since nothing has any business being an lvalue in a module
2979 specification block, an interface block or a contains section,
2980 we force the changed_symbols mechanism to work by setting
2981 host_flag to 0. This prevents valid symbols that have the name
2982 of keywords, such as 'end', being turned into variables by
2983 failed matching to assignments for, e.g., END INTERFACE. */
2984 if (gfc_current_state () == COMP_MODULE
2985 || gfc_current_state () == COMP_INTERFACE
2986 || gfc_current_state () == COMP_CONTAINS
)
2989 where
= gfc_current_locus
;
2990 m
= gfc_match_sym_tree (&st
, host_flag
);
2996 /* If this is an implicit do loop index and implicitly typed,
2997 it should not be host associated. */
2998 m
= check_for_implicit_index (&st
, &sym
);
3002 sym
->attr
.implied_index
= 0;
3004 gfc_set_sym_referenced (sym
);
3005 switch (sym
->attr
.flavor
)
3008 /* Everything is alright. */
3013 sym_flavor flavor
= FL_UNKNOWN
;
3015 gfc_gobble_whitespace ();
3017 if (sym
->attr
.external
|| sym
->attr
.procedure
3018 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3019 flavor
= FL_PROCEDURE
;
3021 /* If it is not a procedure, is not typed and is host associated,
3022 we cannot give it a flavor yet. */
3023 else if (sym
->ns
== gfc_current_ns
->parent
3024 && sym
->ts
.type
== BT_UNKNOWN
)
3027 /* These are definitive indicators that this is a variable. */
3028 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3029 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3030 flavor
= FL_VARIABLE
;
3032 if (flavor
!= FL_UNKNOWN
3033 && gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
) == FAILURE
)
3041 gfc_error ("Named constant at %C in an EQUIVALENCE");
3044 /* Otherwise this is checked for and an error given in the
3045 variable definition context checks. */
3049 /* Check for a nonrecursive function result variable. */
3050 if (sym
->attr
.function
3051 && !sym
->attr
.external
3052 && sym
->result
== sym
3053 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3055 && sym
->ns
== gfc_current_ns
)
3057 && sym
->ns
== gfc_current_ns
->parent
)))
3059 /* If a function result is a derived type, then the derived
3060 type may still have to be resolved. */
3062 if (sym
->ts
.type
== BT_DERIVED
3063 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3068 if (sym
->attr
.proc_pointer
3069 || replace_hidden_procptr_result (&sym
, &st
) == SUCCESS
)
3072 /* Fall through to error */
3075 gfc_error ("'%s' at %C is not a variable", sym
->name
);
3079 /* Special case for derived type variables that get their types
3080 via an IMPLICIT statement. This can't wait for the
3081 resolution phase. */
3084 gfc_namespace
* implicit_ns
;
3086 if (gfc_current_ns
->proc_name
== sym
)
3087 implicit_ns
= gfc_current_ns
;
3089 implicit_ns
= sym
->ns
;
3091 if (gfc_peek_ascii_char () == '%'
3092 && sym
->ts
.type
== BT_UNKNOWN
3093 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3094 gfc_set_default_type (sym
, 0, implicit_ns
);
3097 expr
= gfc_get_expr ();
3099 expr
->expr_type
= EXPR_VARIABLE
;
3102 expr
->where
= where
;
3104 /* Now see if we have to do more. */
3105 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3108 gfc_free_expr (expr
);
3118 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3120 return match_variable (result
, equiv_flag
, 1);
3125 gfc_match_equiv_variable (gfc_expr
**result
)
3127 return match_variable (result
, 1, 0);