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/>. */
30 #include "constructor.h"
32 /* Matches a kind-parameter expression, which is either a named
33 symbolic constant or a nonnegative integer constant. If
34 successful, sets the kind value to the correct integer. */
37 match_kind_param (int *kind
)
39 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
44 m
= gfc_match_small_literal_int (kind
, NULL
);
48 m
= gfc_match_name (name
);
52 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
58 if (sym
->attr
.flavor
!= FL_PARAMETER
)
61 if (sym
->value
== NULL
)
64 p
= gfc_extract_int (sym
->value
, kind
);
68 gfc_set_sym_referenced (sym
);
77 /* Get a trailing kind-specification for non-character variables.
79 the integer kind value or:
80 -1 if an error was generated
81 -2 if no kind was found */
89 if (gfc_match_char ('_') != MATCH_YES
)
92 m
= match_kind_param (&kind
);
94 gfc_error ("Missing kind-parameter at %C");
96 return (m
== MATCH_YES
) ? kind
: -1;
100 /* Given a character and a radix, see if the character is a valid
101 digit in that radix. */
104 gfc_check_digit (char c
, int radix
)
111 r
= ('0' <= c
&& c
<= '1');
115 r
= ('0' <= c
&& c
<= '7');
119 r
= ('0' <= c
&& c
<= '9');
127 gfc_internal_error ("gfc_check_digit(): bad radix");
134 /* Match the digit string part of an integer if signflag is not set,
135 the signed digit string part if signflag is set. If the buffer
136 is NULL, we just count characters for the resolution pass. Returns
137 the number of characters matched, -1 for no match. */
140 match_digits (int signflag
, int radix
, char *buffer
)
147 c
= gfc_next_ascii_char ();
149 if (signflag
&& (c
== '+' || c
== '-'))
153 gfc_gobble_whitespace ();
154 c
= gfc_next_ascii_char ();
158 if (!gfc_check_digit (c
, radix
))
167 old_loc
= gfc_current_locus
;
168 c
= gfc_next_ascii_char ();
170 if (!gfc_check_digit (c
, radix
))
178 gfc_current_locus
= old_loc
;
184 /* Match an integer (digit string and optional kind).
185 A sign will be accepted if signflag is set. */
188 match_integer_constant (gfc_expr
**result
, int signflag
)
195 old_loc
= gfc_current_locus
;
196 gfc_gobble_whitespace ();
198 length
= match_digits (signflag
, 10, NULL
);
199 gfc_current_locus
= old_loc
;
203 buffer
= (char *) alloca (length
+ 1);
204 memset (buffer
, '\0', length
+ 1);
206 gfc_gobble_whitespace ();
208 match_digits (signflag
, 10, buffer
);
212 kind
= gfc_default_integer_kind
;
216 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
218 gfc_error ("Integer kind %d at %C not available", kind
);
222 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
224 if (gfc_range_check (e
) != ARITH_OK
)
226 gfc_error ("Integer too big for its kind at %C. This check can be "
227 "disabled with the option -fno-range-check");
238 /* Match a Hollerith constant. */
241 match_hollerith_constant (gfc_expr
**result
)
249 old_loc
= gfc_current_locus
;
250 gfc_gobble_whitespace ();
252 if (match_integer_constant (&e
, 0) == MATCH_YES
253 && gfc_match_char ('h') == MATCH_YES
)
255 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Hollerith constant "
259 msg
= gfc_extract_int (e
, &num
);
267 gfc_error ("Invalid Hollerith constant: %L must contain at least "
268 "one character", &old_loc
);
271 if (e
->ts
.kind
!= gfc_default_integer_kind
)
273 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
274 "should be default", &old_loc
);
280 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
283 e
->representation
.string
= XCNEWVEC (char, num
+ 1);
285 for (i
= 0; i
< num
; i
++)
287 gfc_char_t c
= gfc_next_char_literal (1);
288 if (! gfc_wide_fits_in_byte (c
))
290 gfc_error ("Invalid Hollerith constant at %L contains a "
291 "wide character", &old_loc
);
295 e
->representation
.string
[i
] = (unsigned char) c
;
298 e
->representation
.string
[num
] = '\0';
299 e
->representation
.length
= num
;
307 gfc_current_locus
= old_loc
;
316 /* Match a binary, octal or hexadecimal constant that can be found in
317 a DATA statement. The standard permits b'010...', o'73...', and
318 z'a1...' where b, o, and z can be capital letters. This function
319 also accepts postfixed forms of the constants: '01...'b, '73...'o,
320 and 'a1...'z. An additional extension is the use of x for z. */
323 match_boz_constant (gfc_expr
**result
)
325 int radix
, length
, x_hex
, kind
;
326 locus old_loc
, start_loc
;
327 char *buffer
, post
, delim
;
330 start_loc
= old_loc
= gfc_current_locus
;
331 gfc_gobble_whitespace ();
334 switch (post
= gfc_next_ascii_char ())
356 radix
= 16; /* Set to accept any valid digit string. */
362 /* No whitespace allowed here. */
365 delim
= gfc_next_ascii_char ();
367 if (delim
!= '\'' && delim
!= '\"')
371 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
372 "constant at %C uses non-standard syntax")
376 old_loc
= gfc_current_locus
;
378 length
= match_digits (0, radix
, NULL
);
381 gfc_error ("Empty set of digits in BOZ constant at %C");
385 if (gfc_next_ascii_char () != delim
)
387 gfc_error ("Illegal character in BOZ constant at %C");
393 switch (gfc_next_ascii_char ())
410 if (gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ constant "
411 "at %C uses non-standard postfix syntax")
416 gfc_current_locus
= old_loc
;
418 buffer
= (char *) alloca (length
+ 1);
419 memset (buffer
, '\0', length
+ 1);
421 match_digits (0, radix
, buffer
);
422 gfc_next_ascii_char (); /* Eat delimiter. */
424 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
426 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
427 "If a data-stmt-constant is a boz-literal-constant, the corresponding
428 variable shall be of type integer. The boz-literal-constant is treated
429 as if it were an int-literal-constant with a kind-param that specifies
430 the representation method with the largest decimal exponent range
431 supported by the processor." */
433 kind
= gfc_max_integer_kind
;
434 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
436 /* Mark as boz variable. */
439 if (gfc_range_check (e
) != ARITH_OK
)
441 gfc_error ("Integer too big for integer kind %i at %C", kind
);
446 if (!gfc_in_match_data ()
447 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BOZ used outside a DATA "
456 gfc_current_locus
= start_loc
;
461 /* Match a real constant of some sort. Allow a signed constant if signflag
465 match_real_constant (gfc_expr
**result
, int signflag
)
467 int kind
, count
, seen_dp
, seen_digits
;
468 locus old_loc
, temp_loc
;
469 char *p
, *buffer
, c
, exp_char
;
473 old_loc
= gfc_current_locus
;
474 gfc_gobble_whitespace ();
484 c
= gfc_next_ascii_char ();
485 if (signflag
&& (c
== '+' || c
== '-'))
490 gfc_gobble_whitespace ();
491 c
= gfc_next_ascii_char ();
494 /* Scan significand. */
495 for (;; c
= gfc_next_ascii_char (), count
++)
502 /* Check to see if "." goes with a following operator like
504 temp_loc
= gfc_current_locus
;
505 c
= gfc_next_ascii_char ();
507 if (c
== 'e' || c
== 'd' || c
== 'q')
509 c
= gfc_next_ascii_char ();
511 goto done
; /* Operator named .e. or .d. */
515 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
517 gfc_current_locus
= temp_loc
;
531 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
536 c
= gfc_next_ascii_char ();
539 if (c
== '+' || c
== '-')
540 { /* optional sign */
541 c
= gfc_next_ascii_char ();
547 gfc_error ("Missing exponent in real number at %C");
553 c
= gfc_next_ascii_char ();
558 /* Check that we have a numeric constant. */
559 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
561 gfc_current_locus
= old_loc
;
565 /* Convert the number. */
566 gfc_current_locus
= old_loc
;
567 gfc_gobble_whitespace ();
569 buffer
= (char *) alloca (count
+ 1);
570 memset (buffer
, '\0', count
+ 1);
573 c
= gfc_next_ascii_char ();
574 if (c
== '+' || c
== '-')
576 gfc_gobble_whitespace ();
577 c
= gfc_next_ascii_char ();
580 /* Hack for mpfr_set_str(). */
583 if (c
== 'd' || c
== 'q')
591 c
= gfc_next_ascii_char ();
603 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
607 kind
= gfc_default_double_kind
;
612 kind
= gfc_default_real_kind
;
614 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
616 gfc_error ("Invalid real kind %d at %C", kind
);
621 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
623 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
625 switch (gfc_range_check (e
))
630 gfc_error ("Real constant overflows its kind at %C");
633 case ARITH_UNDERFLOW
:
634 if (gfc_option
.warn_underflow
)
635 gfc_warning ("Real constant underflows its kind at %C");
636 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
640 gfc_internal_error ("gfc_range_check() returned bad value");
652 /* Match a substring reference. */
655 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
657 gfc_expr
*start
, *end
;
665 old_loc
= gfc_current_locus
;
667 m
= gfc_match_char ('(');
671 if (gfc_match_char (':') != MATCH_YES
)
674 m
= gfc_match_init_expr (&start
);
676 m
= gfc_match_expr (&start
);
684 m
= gfc_match_char (':');
689 if (gfc_match_char (')') != MATCH_YES
)
692 m
= gfc_match_init_expr (&end
);
694 m
= gfc_match_expr (&end
);
698 if (m
== MATCH_ERROR
)
701 m
= gfc_match_char (')');
706 /* Optimize away the (:) reference. */
707 if (start
== NULL
&& end
== NULL
)
711 ref
= gfc_get_ref ();
713 ref
->type
= REF_SUBSTRING
;
715 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
716 ref
->u
.ss
.start
= start
;
717 if (end
== NULL
&& cl
)
718 end
= gfc_copy_expr (cl
->length
);
720 ref
->u
.ss
.length
= cl
;
727 gfc_error ("Syntax error in SUBSTRING specification at %C");
731 gfc_free_expr (start
);
734 gfc_current_locus
= old_loc
;
739 /* Reads the next character of a string constant, taking care to
740 return doubled delimiters on the input as a single instance of
743 Special return values for "ret" argument are:
744 -1 End of the string, as determined by the delimiter
745 -2 Unterminated string detected
747 Backslash codes are also expanded at this time. */
750 next_string_char (gfc_char_t delimiter
, int *ret
)
755 c
= gfc_next_char_literal (1);
764 if (gfc_option
.flag_backslash
&& c
== '\\')
766 old_locus
= gfc_current_locus
;
768 if (gfc_match_special_char (&c
) == MATCH_NO
)
769 gfc_current_locus
= old_locus
;
771 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
772 gfc_warning ("Extension: backslash character at %C");
778 old_locus
= gfc_current_locus
;
779 c
= gfc_next_char_literal (0);
783 gfc_current_locus
= old_locus
;
790 /* Special case of gfc_match_name() that matches a parameter kind name
791 before a string constant. This takes case of the weird but legal
796 where kind____ is a parameter. gfc_match_name() will happily slurp
797 up all the underscores, which leads to problems. If we return
798 MATCH_YES, the parse pointer points to the final underscore, which
799 is not part of the name. We never return MATCH_ERROR-- errors in
800 the name will be detected later. */
803 match_charkind_name (char *name
)
809 gfc_gobble_whitespace ();
810 c
= gfc_next_ascii_char ();
819 old_loc
= gfc_current_locus
;
820 c
= gfc_next_ascii_char ();
824 peek
= gfc_peek_ascii_char ();
826 if (peek
== '\'' || peek
== '\"')
828 gfc_current_locus
= old_loc
;
836 && (c
!= '$' || !gfc_option
.flag_dollar_ok
))
840 if (++len
> GFC_MAX_SYMBOL_LEN
)
848 /* See if the current input matches a character constant. Lots of
849 contortions have to be done to match the kind parameter which comes
850 before the actual string. The main consideration is that we don't
851 want to error out too quickly. For example, we don't actually do
852 any validation of the kinds until we have actually seen a legal
853 delimiter. Using match_kind_param() generates errors too quickly. */
856 match_string_constant (gfc_expr
**result
)
858 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
859 int i
, kind
, length
, warn_ampersand
, ret
;
860 locus old_locus
, start_locus
;
865 gfc_char_t c
, delimiter
, *p
;
867 old_locus
= gfc_current_locus
;
869 gfc_gobble_whitespace ();
871 start_locus
= gfc_current_locus
;
873 c
= gfc_next_char ();
874 if (c
== '\'' || c
== '"')
876 kind
= gfc_default_character_kind
;
880 if (gfc_wide_is_digit (c
))
884 while (gfc_wide_is_digit (c
))
886 kind
= kind
* 10 + c
- '0';
889 c
= gfc_next_char ();
895 gfc_current_locus
= old_locus
;
897 m
= match_charkind_name (name
);
901 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
903 || sym
->attr
.flavor
!= FL_PARAMETER
)
907 c
= gfc_next_char ();
912 gfc_gobble_whitespace ();
913 c
= gfc_next_char ();
919 gfc_gobble_whitespace ();
920 start_locus
= gfc_current_locus
;
922 c
= gfc_next_char ();
923 if (c
!= '\'' && c
!= '"')
928 q
= gfc_extract_int (sym
->value
, &kind
);
934 gfc_set_sym_referenced (sym
);
937 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
939 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
944 /* Scan the string into a block of memory by first figuring out how
945 long it is, allocating the structure, then re-reading it. This
946 isn't particularly efficient, but string constants aren't that
947 common in most code. TODO: Use obstacks? */
954 c
= next_string_char (delimiter
, &ret
);
959 gfc_current_locus
= start_locus
;
960 gfc_error ("Unterminated character constant beginning at %C");
967 /* Peek at the next character to see if it is a b, o, z, or x for the
968 postfixed BOZ literal constants. */
969 peek
= gfc_peek_ascii_char ();
970 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
973 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
975 e
->ts
.is_c_interop
= 0;
978 gfc_current_locus
= start_locus
;
979 gfc_next_char (); /* Skip delimiter */
981 /* We disable the warning for the following loop as the warning has already
982 been printed in the loop above. */
983 warn_ampersand
= gfc_option
.warn_ampersand
;
984 gfc_option
.warn_ampersand
= 0;
986 p
= e
->value
.character
.string
;
987 for (i
= 0; i
< length
; i
++)
989 c
= next_string_char (delimiter
, &ret
);
991 if (!gfc_check_character_range (c
, kind
))
993 gfc_error ("Character '%s' in string at %C is not representable "
994 "in character kind %d", gfc_print_wide_char (c
), kind
);
1001 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1002 gfc_option
.warn_ampersand
= warn_ampersand
;
1004 next_string_char (delimiter
, &ret
);
1006 gfc_internal_error ("match_string_constant(): Delimiter not found");
1008 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1009 e
->expr_type
= EXPR_SUBSTRING
;
1016 gfc_current_locus
= old_locus
;
1021 /* Match a .true. or .false. Returns 1 if a .true. was found,
1022 0 if a .false. was found, and -1 otherwise. */
1024 match_logical_constant_string (void)
1026 locus orig_loc
= gfc_current_locus
;
1028 gfc_gobble_whitespace ();
1029 if (gfc_next_ascii_char () == '.')
1031 char ch
= gfc_next_ascii_char ();
1034 if (gfc_next_ascii_char () == 'a'
1035 && gfc_next_ascii_char () == 'l'
1036 && gfc_next_ascii_char () == 's'
1037 && gfc_next_ascii_char () == 'e'
1038 && gfc_next_ascii_char () == '.')
1039 /* Matched ".false.". */
1044 if (gfc_next_ascii_char () == 'r'
1045 && gfc_next_ascii_char () == 'u'
1046 && gfc_next_ascii_char () == 'e'
1047 && gfc_next_ascii_char () == '.')
1048 /* Matched ".true.". */
1052 gfc_current_locus
= orig_loc
;
1056 /* Match a .true. or .false. */
1059 match_logical_constant (gfc_expr
**result
)
1064 i
= match_logical_constant_string ();
1072 kind
= gfc_default_logical_kind
;
1074 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1076 gfc_error ("Bad kind for logical constant at %C");
1080 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1081 e
->ts
.is_c_interop
= 0;
1089 /* Match a real or imaginary part of a complex constant that is a
1090 symbolic constant. */
1093 match_sym_complex_part (gfc_expr
**result
)
1095 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1100 m
= gfc_match_name (name
);
1104 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1107 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1109 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1113 if (!gfc_numeric_ts (&sym
->value
->ts
))
1115 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1119 if (sym
->value
->rank
!= 0)
1121 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1125 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PARAMETER symbol in "
1126 "complex constant at %C") == FAILURE
)
1129 switch (sym
->value
->ts
.type
)
1132 e
= gfc_copy_expr (sym
->value
);
1136 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1142 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1148 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1151 *result
= e
; /* e is a scalar, real, constant expression. */
1155 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1160 /* Match a real or imaginary part of a complex number. */
1163 match_complex_part (gfc_expr
**result
)
1167 m
= match_sym_complex_part (result
);
1171 m
= match_real_constant (result
, 1);
1175 return match_integer_constant (result
, 1);
1179 /* Try to match a complex constant. */
1182 match_complex_constant (gfc_expr
**result
)
1184 gfc_expr
*e
, *real
, *imag
;
1185 gfc_error_buf old_error
;
1186 gfc_typespec target
;
1191 old_loc
= gfc_current_locus
;
1192 real
= imag
= e
= NULL
;
1194 m
= gfc_match_char ('(');
1198 gfc_push_error (&old_error
);
1200 m
= match_complex_part (&real
);
1203 gfc_free_error (&old_error
);
1207 if (gfc_match_char (',') == MATCH_NO
)
1209 gfc_pop_error (&old_error
);
1214 /* If m is error, then something was wrong with the real part and we
1215 assume we have a complex constant because we've seen the ','. An
1216 ambiguous case here is the start of an iterator list of some
1217 sort. These sort of lists are matched prior to coming here. */
1219 if (m
== MATCH_ERROR
)
1221 gfc_free_error (&old_error
);
1224 gfc_pop_error (&old_error
);
1226 m
= match_complex_part (&imag
);
1229 if (m
== MATCH_ERROR
)
1232 m
= gfc_match_char (')');
1235 /* Give the matcher for implied do-loops a chance to run. This
1236 yields a much saner error message for (/ (i, 4=i, 6) /). */
1237 if (gfc_peek_ascii_char () == '=')
1246 if (m
== MATCH_ERROR
)
1249 /* Decide on the kind of this complex number. */
1250 if (real
->ts
.type
== BT_REAL
)
1252 if (imag
->ts
.type
== BT_REAL
)
1253 kind
= gfc_kind_max (real
, imag
);
1255 kind
= real
->ts
.kind
;
1259 if (imag
->ts
.type
== BT_REAL
)
1260 kind
= imag
->ts
.kind
;
1262 kind
= gfc_default_real_kind
;
1264 target
.type
= BT_REAL
;
1266 target
.is_c_interop
= 0;
1267 target
.is_iso_c
= 0;
1269 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1270 gfc_convert_type (real
, &target
, 2);
1271 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1272 gfc_convert_type (imag
, &target
, 2);
1274 e
= gfc_convert_complex (real
, imag
, kind
);
1275 e
->where
= gfc_current_locus
;
1277 gfc_free_expr (real
);
1278 gfc_free_expr (imag
);
1284 gfc_error ("Syntax error in COMPLEX constant at %C");
1289 gfc_free_expr (real
);
1290 gfc_free_expr (imag
);
1291 gfc_current_locus
= old_loc
;
1297 /* Match constants in any of several forms. Returns nonzero for a
1298 match, zero for no match. */
1301 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1305 m
= match_complex_constant (result
);
1309 m
= match_string_constant (result
);
1313 m
= match_boz_constant (result
);
1317 m
= match_real_constant (result
, signflag
);
1321 m
= match_hollerith_constant (result
);
1325 m
= match_integer_constant (result
, signflag
);
1329 m
= match_logical_constant (result
);
1337 /* This checks if a symbol is the return value of an encompassing function.
1338 Function nesting can be maximally two levels deep, but we may have
1339 additional local namespaces like BLOCK etc. */
1342 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1344 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1348 if (ns
->proc_name
== sym
)
1356 /* Match a single actual argument value. An actual argument is
1357 usually an expression, but can also be a procedure name. If the
1358 argument is a single name, it is not always possible to tell
1359 whether the name is a dummy procedure or not. We treat these cases
1360 by creating an argument that looks like a dummy procedure and
1361 fixing things later during resolution. */
1364 match_actual_arg (gfc_expr
**result
)
1366 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1367 gfc_symtree
*symtree
;
1372 gfc_gobble_whitespace ();
1373 where
= gfc_current_locus
;
1375 switch (gfc_match_name (name
))
1384 w
= gfc_current_locus
;
1385 gfc_gobble_whitespace ();
1386 c
= gfc_next_ascii_char ();
1387 gfc_current_locus
= w
;
1389 if (c
!= ',' && c
!= ')')
1392 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1394 /* Handle error elsewhere. */
1396 /* Eliminate a couple of common cases where we know we don't
1397 have a function argument. */
1398 if (symtree
== NULL
)
1400 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1401 gfc_set_sym_referenced (symtree
->n
.sym
);
1407 sym
= symtree
->n
.sym
;
1408 gfc_set_sym_referenced (sym
);
1409 if (sym
->attr
.flavor
!= FL_PROCEDURE
1410 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1413 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1415 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
,
1420 /* If the symbol is a function with itself as the result and
1421 is being defined, then we have a variable. */
1422 if (sym
->attr
.function
&& sym
->result
== sym
)
1424 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1428 && (sym
->ns
== gfc_current_ns
1429 || sym
->ns
== gfc_current_ns
->parent
))
1431 gfc_entry_list
*el
= NULL
;
1433 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1443 e
= gfc_get_expr (); /* Leave it unknown for now */
1444 e
->symtree
= symtree
;
1445 e
->expr_type
= EXPR_VARIABLE
;
1446 e
->ts
.type
= BT_PROCEDURE
;
1453 gfc_current_locus
= where
;
1454 return gfc_match_expr (result
);
1458 /* Match a keyword argument. */
1461 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1463 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1464 gfc_actual_arglist
*a
;
1468 name_locus
= gfc_current_locus
;
1469 m
= gfc_match_name (name
);
1473 if (gfc_match_char ('=') != MATCH_YES
)
1479 m
= match_actual_arg (&actual
->expr
);
1483 /* Make sure this name has not appeared yet. */
1485 if (name
[0] != '\0')
1487 for (a
= base
; a
; a
= a
->next
)
1488 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1490 gfc_error ("Keyword '%s' at %C has already appeared in the "
1491 "current argument list", name
);
1496 actual
->name
= gfc_get_string (name
);
1500 gfc_current_locus
= name_locus
;
1505 /* Match an argument list function, such as %VAL. */
1508 match_arg_list_function (gfc_actual_arglist
*result
)
1510 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1514 old_locus
= gfc_current_locus
;
1516 if (gfc_match_char ('%') != MATCH_YES
)
1522 m
= gfc_match ("%n (", name
);
1526 if (name
[0] != '\0')
1531 if (strncmp (name
, "loc", 3) == 0)
1533 result
->name
= "%LOC";
1537 if (strncmp (name
, "ref", 3) == 0)
1539 result
->name
= "%REF";
1543 if (strncmp (name
, "val", 3) == 0)
1545 result
->name
= "%VAL";
1554 if (gfc_notify_std (GFC_STD_GNU
, "Extension: argument list "
1555 "function at %C") == FAILURE
)
1561 m
= match_actual_arg (&result
->expr
);
1565 if (gfc_match_char (')') != MATCH_YES
)
1574 gfc_current_locus
= old_locus
;
1579 /* Matches an actual argument list of a function or subroutine, from
1580 the opening parenthesis to the closing parenthesis. The argument
1581 list is assumed to allow keyword arguments because we don't know if
1582 the symbol associated with the procedure has an implicit interface
1583 or not. We make sure keywords are unique. If sub_flag is set,
1584 we're matching the argument list of a subroutine. */
1587 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1589 gfc_actual_arglist
*head
, *tail
;
1591 gfc_st_label
*label
;
1595 *argp
= tail
= NULL
;
1596 old_loc
= gfc_current_locus
;
1600 if (gfc_match_char ('(') == MATCH_NO
)
1601 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1603 if (gfc_match_char (')') == MATCH_YES
)
1610 head
= tail
= gfc_get_actual_arglist ();
1613 tail
->next
= gfc_get_actual_arglist ();
1617 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1619 m
= gfc_match_st_label (&label
);
1621 gfc_error ("Expected alternate return label at %C");
1625 tail
->label
= label
;
1629 /* After the first keyword argument is seen, the following
1630 arguments must also have keywords. */
1633 m
= match_keyword_arg (tail
, head
);
1635 if (m
== MATCH_ERROR
)
1639 gfc_error ("Missing keyword name in actual argument list at %C");
1646 /* Try an argument list function, like %VAL. */
1647 m
= match_arg_list_function (tail
);
1648 if (m
== MATCH_ERROR
)
1651 /* See if we have the first keyword argument. */
1654 m
= match_keyword_arg (tail
, head
);
1657 if (m
== MATCH_ERROR
)
1663 /* Try for a non-keyword argument. */
1664 m
= match_actual_arg (&tail
->expr
);
1665 if (m
== MATCH_ERROR
)
1674 if (gfc_match_char (')') == MATCH_YES
)
1676 if (gfc_match_char (',') != MATCH_YES
)
1684 gfc_error ("Syntax error in argument list at %C");
1687 gfc_free_actual_arglist (head
);
1688 gfc_current_locus
= old_loc
;
1694 /* Used by gfc_match_varspec() to extend the reference list by one
1698 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1700 if (primary
->ref
== NULL
)
1701 primary
->ref
= tail
= gfc_get_ref ();
1705 gfc_internal_error ("extend_ref(): Bad tail");
1706 tail
->next
= gfc_get_ref ();
1714 /* Match any additional specifications associated with the current
1715 variable like member references or substrings. If equiv_flag is
1716 set we only match stuff that is allowed inside an EQUIVALENCE
1717 statement. sub_flag tells whether we expect a type-bound procedure found
1718 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1719 components, 'ppc_arg' determines whether the PPC may be called (with an
1720 argument list), or whether it may just be referred to as a pointer. */
1723 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1726 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1727 gfc_ref
*substring
, *tail
;
1728 gfc_component
*component
;
1729 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1735 gfc_gobble_whitespace ();
1737 if (gfc_peek_ascii_char () == '[')
1739 if (sym
->attr
.dimension
)
1741 gfc_error ("Array section designator, e.g. '(:)', is required "
1742 "besides the coarray designator '[...]' at %C");
1745 if (!sym
->attr
.codimension
)
1747 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1753 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1754 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1755 || (sym
->attr
.dimension
&& !sym
->attr
.proc_pointer
1756 && !gfc_is_proc_ptr_comp (primary
, NULL
)
1757 && !(gfc_matching_procptr_assignment
1758 && sym
->attr
.flavor
== FL_PROCEDURE
))
1759 || (sym
->ts
.type
== BT_CLASS
1760 && sym
->ts
.u
.derived
->components
->attr
.dimension
))
1762 /* In EQUIVALENCE, we don't know yet whether we are seeing
1763 an array, character variable or array of character
1764 variables. We'll leave the decision till resolve time. */
1765 tail
= extend_ref (primary
, tail
);
1766 tail
->type
= REF_ARRAY
;
1768 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1769 equiv_flag
, sym
->as
? sym
->as
->corank
: 0);
1773 gfc_gobble_whitespace ();
1774 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1776 tail
= extend_ref (primary
, tail
);
1777 tail
->type
= REF_ARRAY
;
1779 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1785 primary
->ts
= sym
->ts
;
1790 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1791 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1792 gfc_set_default_type (sym
, 0, sym
->ns
);
1794 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1795 || gfc_match_char ('%') != MATCH_YES
)
1796 goto check_substring
;
1798 sym
= sym
->ts
.u
.derived
;
1805 m
= gfc_match_name (name
);
1807 gfc_error ("Expected structure component name at %C");
1811 if (sym
->f2k_derived
)
1812 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1818 gfc_symbol
* tbp_sym
;
1823 gcc_assert (!tail
|| !tail
->next
);
1824 gcc_assert (primary
->expr_type
== EXPR_VARIABLE
);
1826 if (tbp
->n
.tb
->is_generic
)
1829 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1831 primary
->expr_type
= EXPR_COMPCALL
;
1832 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1833 primary
->value
.compcall
.name
= tbp
->name
;
1834 primary
->value
.compcall
.ignore_pass
= 0;
1835 primary
->value
.compcall
.assign
= 0;
1836 primary
->value
.compcall
.base_object
= NULL
;
1837 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1839 primary
->ts
= tbp_sym
->ts
;
1841 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1842 &primary
->value
.compcall
.actual
);
1843 if (m
== MATCH_ERROR
)
1848 primary
->value
.compcall
.actual
= NULL
;
1851 gfc_error ("Expected argument list at %C");
1859 component
= gfc_find_component (sym
, name
, false, false);
1860 if (component
== NULL
)
1863 tail
= extend_ref (primary
, tail
);
1864 tail
->type
= REF_COMPONENT
;
1866 tail
->u
.c
.component
= component
;
1867 tail
->u
.c
.sym
= sym
;
1869 primary
->ts
= component
->ts
;
1871 if (component
->attr
.proc_pointer
&& ppc_arg
1872 && !gfc_matching_procptr_assignment
)
1874 m
= gfc_match_actual_arglist (sub_flag
,
1875 &primary
->value
.compcall
.actual
);
1876 if (m
== MATCH_ERROR
)
1879 primary
->expr_type
= EXPR_PPC
;
1884 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
1886 tail
= extend_ref (primary
, tail
);
1887 tail
->type
= REF_ARRAY
;
1889 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
1890 component
->as
->corank
);
1894 else if (component
->ts
.type
== BT_CLASS
1895 && component
->ts
.u
.derived
->components
->as
!= NULL
1896 && !component
->attr
.proc_pointer
)
1898 tail
= extend_ref (primary
, tail
);
1899 tail
->type
= REF_ARRAY
;
1901 m
= gfc_match_array_ref (&tail
->u
.ar
,
1902 component
->ts
.u
.derived
->components
->as
,
1904 component
->ts
.u
.derived
->components
->as
->corank
);
1909 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
1910 || gfc_match_char ('%') != MATCH_YES
)
1913 sym
= component
->ts
.u
.derived
;
1918 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
1920 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
1922 gfc_set_default_type (sym
, 0, sym
->ns
);
1923 primary
->ts
= sym
->ts
;
1928 if (primary
->ts
.type
== BT_CHARACTER
)
1930 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
1934 primary
->ref
= substring
;
1936 tail
->next
= substring
;
1938 if (primary
->expr_type
== EXPR_CONSTANT
)
1939 primary
->expr_type
= EXPR_SUBSTRING
;
1942 primary
->ts
.u
.cl
= NULL
;
1949 gfc_clear_ts (&primary
->ts
);
1950 gfc_clear_ts (&sym
->ts
);
1960 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
1962 gfc_error ("Coindexed procedure-pointer component at %C");
1970 /* Given an expression that is a variable, figure out what the
1971 ultimate variable's type and attribute is, traversing the reference
1972 structures if necessary.
1974 This subroutine is trickier than it looks. We start at the base
1975 symbol and store the attribute. Component references load a
1976 completely new attribute.
1978 A couple of rules come into play. Subobjects of targets are always
1979 targets themselves. If we see a component that goes through a
1980 pointer, then the expression must also be a target, since the
1981 pointer is associated with something (if it isn't core will soon be
1982 dumped). If we see a full part or section of an array, the
1983 expression is also an array.
1985 We can have at most one full array reference. */
1988 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
1990 int dimension
, pointer
, allocatable
, target
;
1991 symbol_attribute attr
;
1994 gfc_component
*comp
;
1996 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
1997 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2000 sym
= expr
->symtree
->n
.sym
;
2003 if (sym
->ts
.type
== BT_CLASS
)
2005 dimension
= sym
->ts
.u
.derived
->components
->attr
.dimension
;
2006 pointer
= sym
->ts
.u
.derived
->components
->attr
.pointer
;
2007 allocatable
= sym
->ts
.u
.derived
->components
->attr
.allocatable
;
2011 dimension
= attr
.dimension
;
2012 pointer
= attr
.pointer
;
2013 allocatable
= attr
.allocatable
;
2016 target
= attr
.target
;
2017 if (pointer
|| attr
.proc_pointer
)
2020 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2023 for (; ref
; ref
= ref
->next
)
2028 switch (ref
->u
.ar
.type
)
2035 allocatable
= pointer
= 0;
2040 /* Handle coarrays. */
2041 if (ref
->u
.ar
.dimen
> 0)
2042 allocatable
= pointer
= 0;
2046 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2052 comp
= ref
->u
.c
.component
;
2057 /* Don't set the string length if a substring reference
2059 if (ts
->type
== BT_CHARACTER
2060 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2064 if (comp
->ts
.type
== BT_CLASS
)
2066 pointer
= comp
->ts
.u
.derived
->components
->attr
.pointer
;
2067 allocatable
= comp
->ts
.u
.derived
->components
->attr
.allocatable
;
2071 pointer
= comp
->attr
.pointer
;
2072 allocatable
= comp
->attr
.allocatable
;
2074 if (pointer
|| attr
.proc_pointer
)
2080 allocatable
= pointer
= 0;
2084 attr
.dimension
= dimension
;
2085 attr
.pointer
= pointer
;
2086 attr
.allocatable
= allocatable
;
2087 attr
.target
= target
;
2093 /* Return the attribute from a general expression. */
2096 gfc_expr_attr (gfc_expr
*e
)
2098 symbol_attribute attr
;
2100 switch (e
->expr_type
)
2103 attr
= gfc_variable_attr (e
, NULL
);
2107 gfc_clear_attr (&attr
);
2109 if (e
->value
.function
.esym
!= NULL
)
2111 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2113 if (sym
->ts
.type
== BT_CLASS
)
2115 attr
.dimension
= sym
->ts
.u
.derived
->components
->attr
.dimension
;
2116 attr
.pointer
= sym
->ts
.u
.derived
->components
->attr
.pointer
;
2117 attr
.allocatable
= sym
->ts
.u
.derived
->components
->attr
.allocatable
;
2121 attr
= gfc_variable_attr (e
, NULL
);
2123 /* TODO: NULL() returns pointers. May have to take care of this
2129 gfc_clear_attr (&attr
);
2137 /* Match a structure constructor. The initial symbol has already been
2140 typedef struct gfc_structure_ctor_component
2145 struct gfc_structure_ctor_component
* next
;
2147 gfc_structure_ctor_component
;
2149 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2152 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2154 gfc_free (comp
->name
);
2155 gfc_free_expr (comp
->val
);
2159 /* Translate the component list into the actual constructor by sorting it in
2160 the order required; this also checks along the way that each and every
2161 component actually has an initializer and handles default initializers
2162 for components without explicit value given. */
2164 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2165 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2167 gfc_structure_ctor_component
*comp_iter
;
2168 gfc_component
*comp
;
2170 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2172 gfc_structure_ctor_component
**next_ptr
;
2173 gfc_expr
*value
= NULL
;
2175 /* Try to find the initializer for the current component by name. */
2176 next_ptr
= comp_head
;
2177 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2179 if (!strcmp (comp_iter
->name
, comp
->name
))
2181 next_ptr
= &comp_iter
->next
;
2184 /* If an extension, try building the parent derived type by building
2185 a value expression for the parent derived type and calling self. */
2186 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2188 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2190 &gfc_current_locus
);
2191 value
->ts
= comp
->ts
;
2193 if (build_actual_constructor (comp_head
, &value
->value
.constructor
,
2194 comp
->ts
.u
.derived
) == FAILURE
)
2196 gfc_free_expr (value
);
2200 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2204 /* If it was not found, try the default initializer if there's any;
2205 otherwise, it's an error. */
2208 if (comp
->initializer
)
2210 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2211 " constructor with missing optional arguments"
2212 " at %C") == FAILURE
)
2214 value
= gfc_copy_expr (comp
->initializer
);
2218 gfc_error ("No initializer for component '%s' given in the"
2219 " structure constructor at %C!", comp
->name
);
2224 value
= comp_iter
->val
;
2226 /* Add the value to the constructor chain built. */
2227 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2229 /* Remove the entry from the component list. We don't want the expression
2230 value to be free'd, so set it to NULL. */
2233 *next_ptr
= comp_iter
->next
;
2234 comp_iter
->val
= NULL
;
2235 gfc_free_structure_ctor_component (comp_iter
);
2242 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
,
2245 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2246 gfc_constructor_base ctor_head
= NULL
;
2247 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2251 const char* last_name
= NULL
;
2253 comp_tail
= comp_head
= NULL
;
2255 if (!parent
&& gfc_match_char ('(') != MATCH_YES
)
2258 where
= gfc_current_locus
;
2260 gfc_find_component (sym
, NULL
, false, true);
2262 /* Check that we're not about to construct an ABSTRACT type. */
2263 if (!parent
&& sym
->attr
.abstract
)
2265 gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym
->name
);
2269 /* Match the component list and store it in a list together with the
2270 corresponding component names. Check for empty argument list first. */
2271 if (gfc_match_char (')') != MATCH_YES
)
2273 comp
= sym
->components
;
2276 gfc_component
*this_comp
= NULL
;
2279 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2282 comp_tail
->next
= gfc_get_structure_ctor_component ();
2283 comp_tail
= comp_tail
->next
;
2285 comp_tail
->name
= XCNEWVEC (char, GFC_MAX_SYMBOL_LEN
+ 1);
2286 comp_tail
->val
= NULL
;
2287 comp_tail
->where
= gfc_current_locus
;
2289 /* Try matching a component name. */
2290 if (gfc_match_name (comp_tail
->name
) == MATCH_YES
2291 && gfc_match_char ('=') == MATCH_YES
)
2293 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2294 " constructor with named arguments at %C")
2298 last_name
= comp_tail
->name
;
2303 /* Components without name are not allowed after the first named
2304 component initializer! */
2308 gfc_error ("Component initializer without name after"
2309 " component named %s at %C!", last_name
);
2311 gfc_error ("Too many components in structure constructor at"
2316 gfc_current_locus
= comp_tail
->where
;
2317 strncpy (comp_tail
->name
, comp
->name
, GFC_MAX_SYMBOL_LEN
+ 1);
2320 /* Find the current component in the structure definition and check
2321 its access is not private. */
2323 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2326 this_comp
= gfc_find_component (sym
,
2327 (const char *)comp_tail
->name
,
2329 comp
= NULL
; /* Reset needed! */
2332 /* Here we can check if a component name is given which does not
2333 correspond to any component of the defined structure. */
2337 /* Check if this component is already given a value. */
2338 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2339 comp_iter
= comp_iter
->next
)
2341 gcc_assert (comp_iter
);
2342 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2344 gfc_error ("Component '%s' is initialized twice in the"
2345 " structure constructor at %C!", comp_tail
->name
);
2350 /* Match the current initializer expression. */
2351 m
= gfc_match_expr (&comp_tail
->val
);
2354 if (m
== MATCH_ERROR
)
2357 /* F2008, R457/C725, for PURE C1283. */
2358 if (this_comp
->attr
.pointer
&& gfc_is_coindexed (comp_tail
->val
))
2360 gfc_error ("Coindexed expression to pointer component '%s' in "
2361 "structure constructor at %C!", comp_tail
->name
);
2366 /* If not explicitly a parent constructor, gather up the components
2368 if (comp
&& comp
== sym
->components
2369 && sym
->attr
.extension
2370 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2372 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2374 gfc_current_locus
= where
;
2375 gfc_free_expr (comp_tail
->val
);
2376 comp_tail
->val
= NULL
;
2378 m
= gfc_match_structure_constructor (comp
->ts
.u
.derived
,
2379 &comp_tail
->val
, true);
2382 if (m
== MATCH_ERROR
)
2389 if (parent
&& !comp
)
2393 while (gfc_match_char (',') == MATCH_YES
);
2395 if (!parent
&& gfc_match_char (')') != MATCH_YES
)
2399 if (build_actual_constructor (&comp_head
, &ctor_head
, sym
) == FAILURE
)
2402 /* No component should be left, as this should have caused an error in the
2403 loop constructing the component-list (name that does not correspond to any
2404 component in the structure definition). */
2405 if (comp_head
&& sym
->attr
.extension
)
2407 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2409 gfc_error ("component '%s' at %L has already been set by a "
2410 "parent derived type constructor", comp_iter
->name
,
2416 gcc_assert (!comp_head
);
2418 e
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &where
);
2419 e
->ts
.u
.derived
= sym
;
2420 e
->value
.constructor
= ctor_head
;
2426 gfc_error ("Syntax error in structure constructor at %C");
2429 for (comp_iter
= comp_head
; comp_iter
; )
2431 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2432 gfc_free_structure_ctor_component (comp_iter
);
2435 gfc_constructor_free (ctor_head
);
2440 /* If the symbol is an implicit do loop index and implicitly typed,
2441 it should not be host associated. Provide a symtree from the
2442 current namespace. */
2444 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2446 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2447 && (*sym
)->ns
!= gfc_current_ns
2448 && (*sym
)->attr
.implied_index
2449 && (*sym
)->attr
.implicit_type
2450 && !(*sym
)->attr
.use_assoc
)
2453 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2456 *sym
= (*st
)->n
.sym
;
2462 /* Procedure pointer as function result: Replace the function symbol by the
2463 auto-generated hidden result variable named "ppr@". */
2466 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2468 /* Check for procedure pointer result variable. */
2469 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2470 && (*sym
)->result
&& (*sym
)->result
!= *sym
2471 && (*sym
)->result
->attr
.proc_pointer
2472 && (*sym
) == gfc_current_ns
->proc_name
2473 && (*sym
) == (*sym
)->result
->ns
->proc_name
2474 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2476 /* Automatic replacement with "hidden" result variable. */
2477 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2478 *sym
= (*sym
)->result
;
2479 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2486 /* Matches a variable name followed by anything that might follow it--
2487 array reference, argument list of a function, etc. */
2490 gfc_match_rvalue (gfc_expr
**result
)
2492 gfc_actual_arglist
*actual_arglist
;
2493 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2496 gfc_symtree
*symtree
;
2497 locus where
, old_loc
;
2505 m
= gfc_match_name (name
);
2509 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2510 && !gfc_current_ns
->has_import_set
)
2511 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2513 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2518 sym
= symtree
->n
.sym
;
2520 where
= gfc_current_locus
;
2522 replace_hidden_procptr_result (&sym
, &symtree
);
2524 /* If this is an implicit do loop index and implicitly typed,
2525 it should not be host associated. */
2526 m
= check_for_implicit_index (&symtree
, &sym
);
2530 gfc_set_sym_referenced (sym
);
2531 sym
->attr
.implied_index
= 0;
2533 if (sym
->attr
.function
&& sym
->result
== sym
)
2535 /* See if this is a directly recursive function call. */
2536 gfc_gobble_whitespace ();
2537 if (sym
->attr
.recursive
2538 && gfc_peek_ascii_char () == '('
2539 && gfc_current_ns
->proc_name
== sym
2540 && !sym
->attr
.dimension
)
2542 gfc_error ("'%s' at %C is the name of a recursive function "
2543 "and so refers to the result variable. Use an "
2544 "explicit RESULT variable for direct recursion "
2545 "(12.5.2.1)", sym
->name
);
2549 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2553 && (sym
->ns
== gfc_current_ns
2554 || sym
->ns
== gfc_current_ns
->parent
))
2556 gfc_entry_list
*el
= NULL
;
2558 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2564 if (gfc_matching_procptr_assignment
)
2567 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2570 if (sym
->attr
.generic
)
2571 goto generic_function
;
2573 switch (sym
->attr
.flavor
)
2577 e
= gfc_get_expr ();
2579 e
->expr_type
= EXPR_VARIABLE
;
2580 e
->symtree
= symtree
;
2582 m
= gfc_match_varspec (e
, 0, false, true);
2586 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2587 end up here. Unfortunately, sym->value->expr_type is set to
2588 EXPR_CONSTANT, and so the if () branch would be followed without
2589 the !sym->as check. */
2590 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2591 e
= gfc_copy_expr (sym
->value
);
2594 e
= gfc_get_expr ();
2595 e
->expr_type
= EXPR_VARIABLE
;
2598 e
->symtree
= symtree
;
2599 m
= gfc_match_varspec (e
, 0, false, true);
2601 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2604 /* Variable array references to derived type parameters cause
2605 all sorts of headaches in simplification. Treating such
2606 expressions as variable works just fine for all array
2608 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2610 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2611 if (ref
->type
== REF_ARRAY
)
2614 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2620 e
= gfc_get_expr ();
2621 e
->expr_type
= EXPR_VARIABLE
;
2622 e
->symtree
= symtree
;
2629 sym
= gfc_use_derived (sym
);
2633 m
= gfc_match_structure_constructor (sym
, &e
, false);
2636 /* If we're here, then the name is known to be the name of a
2637 procedure, yet it is not sure to be the name of a function. */
2640 /* Procedure Pointer Assignments. */
2642 if (gfc_matching_procptr_assignment
)
2644 gfc_gobble_whitespace ();
2645 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2646 /* Parse functions returning a procptr. */
2649 if (gfc_is_intrinsic (sym
, 0, gfc_current_locus
)
2650 || gfc_is_intrinsic (sym
, 1, gfc_current_locus
))
2651 sym
->attr
.intrinsic
= 1;
2652 e
= gfc_get_expr ();
2653 e
->expr_type
= EXPR_VARIABLE
;
2654 e
->symtree
= symtree
;
2655 m
= gfc_match_varspec (e
, 0, false, true);
2659 if (sym
->attr
.subroutine
)
2661 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2667 /* At this point, the name has to be a non-statement function.
2668 If the name is the same as the current function being
2669 compiled, then we have a variable reference (to the function
2670 result) if the name is non-recursive. */
2672 st
= gfc_enclosing_unit (NULL
);
2674 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2676 && !sym
->attr
.recursive
)
2678 e
= gfc_get_expr ();
2679 e
->symtree
= symtree
;
2680 e
->expr_type
= EXPR_VARIABLE
;
2682 m
= gfc_match_varspec (e
, 0, false, true);
2686 /* Match a function reference. */
2688 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2691 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2692 gfc_error ("Statement function '%s' requires argument list at %C",
2695 gfc_error ("Function '%s' requires an argument list at %C",
2708 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2709 sym
= symtree
->n
.sym
;
2711 replace_hidden_procptr_result (&sym
, &symtree
);
2713 e
= gfc_get_expr ();
2714 e
->symtree
= symtree
;
2715 e
->expr_type
= EXPR_FUNCTION
;
2716 e
->value
.function
.actual
= actual_arglist
;
2717 e
->where
= gfc_current_locus
;
2719 if (sym
->as
!= NULL
)
2720 e
->rank
= sym
->as
->rank
;
2722 if (!sym
->attr
.function
2723 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2729 /* Check here for the existence of at least one argument for the
2730 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2731 argument(s) given will be checked in gfc_iso_c_func_interface,
2732 during resolution of the function call. */
2733 if (sym
->attr
.is_iso_c
== 1
2734 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2735 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2736 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2737 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2739 /* make sure we were given a param */
2740 if (actual_arglist
== NULL
)
2742 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2748 if (sym
->result
== NULL
)
2756 /* Special case for derived type variables that get their types
2757 via an IMPLICIT statement. This can't wait for the
2758 resolution phase. */
2760 if (gfc_peek_ascii_char () == '%'
2761 && sym
->ts
.type
== BT_UNKNOWN
2762 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2763 gfc_set_default_type (sym
, 0, sym
->ns
);
2765 /* If the symbol has a dimension attribute, the expression is a
2768 if (sym
->attr
.dimension
)
2770 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2771 sym
->name
, NULL
) == FAILURE
)
2777 e
= gfc_get_expr ();
2778 e
->symtree
= symtree
;
2779 e
->expr_type
= EXPR_VARIABLE
;
2780 m
= gfc_match_varspec (e
, 0, false, true);
2784 /* Name is not an array, so we peek to see if a '(' implies a
2785 function call or a substring reference. Otherwise the
2786 variable is just a scalar. */
2788 gfc_gobble_whitespace ();
2789 if (gfc_peek_ascii_char () != '(')
2791 /* Assume a scalar variable */
2792 e
= gfc_get_expr ();
2793 e
->symtree
= symtree
;
2794 e
->expr_type
= EXPR_VARIABLE
;
2796 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2797 sym
->name
, NULL
) == FAILURE
)
2803 /*FIXME:??? gfc_match_varspec does set this for us: */
2805 m
= gfc_match_varspec (e
, 0, false, true);
2809 /* See if this is a function reference with a keyword argument
2810 as first argument. We do this because otherwise a spurious
2811 symbol would end up in the symbol table. */
2813 old_loc
= gfc_current_locus
;
2814 m2
= gfc_match (" ( %n =", argname
);
2815 gfc_current_locus
= old_loc
;
2817 e
= gfc_get_expr ();
2818 e
->symtree
= symtree
;
2820 if (m2
!= MATCH_YES
)
2822 /* Try to figure out whether we're dealing with a character type.
2823 We're peeking ahead here, because we don't want to call
2824 match_substring if we're dealing with an implicitly typed
2825 non-character variable. */
2826 implicit_char
= false;
2827 if (sym
->ts
.type
== BT_UNKNOWN
)
2829 ts
= gfc_get_default_type (sym
->name
, NULL
);
2830 if (ts
->type
== BT_CHARACTER
)
2831 implicit_char
= true;
2834 /* See if this could possibly be a substring reference of a name
2835 that we're not sure is a variable yet. */
2837 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
2838 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
2841 e
->expr_type
= EXPR_VARIABLE
;
2843 if (sym
->attr
.flavor
!= FL_VARIABLE
2844 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2845 sym
->name
, NULL
) == FAILURE
)
2851 if (sym
->ts
.type
== BT_UNKNOWN
2852 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2866 /* Give up, assume we have a function. */
2868 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
2869 sym
= symtree
->n
.sym
;
2870 e
->expr_type
= EXPR_FUNCTION
;
2872 if (!sym
->attr
.function
2873 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2881 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2883 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2891 /* If our new function returns a character, array or structure
2892 type, it might have subsequent references. */
2894 m
= gfc_match_varspec (e
, 0, false, true);
2901 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
2903 e
= gfc_get_expr ();
2904 e
->symtree
= symtree
;
2905 e
->expr_type
= EXPR_FUNCTION
;
2907 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2911 gfc_error ("Symbol at %C is not appropriate for an expression");
2927 /* Match a variable, i.e. something that can be assigned to. This
2928 starts as a symbol, can be a structure component or an array
2929 reference. It can be a function if the function doesn't have a
2930 separate RESULT variable. If the symbol has not been previously
2931 seen, we assume it is a variable.
2933 This function is called by two interface functions:
2934 gfc_match_variable, which has host_flag = 1, and
2935 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2936 match of the symbol to the local scope. */
2939 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
2947 /* Since nothing has any business being an lvalue in a module
2948 specification block, an interface block or a contains section,
2949 we force the changed_symbols mechanism to work by setting
2950 host_flag to 0. This prevents valid symbols that have the name
2951 of keywords, such as 'end', being turned into variables by
2952 failed matching to assignments for, e.g., END INTERFACE. */
2953 if (gfc_current_state () == COMP_MODULE
2954 || gfc_current_state () == COMP_INTERFACE
2955 || gfc_current_state () == COMP_CONTAINS
)
2958 where
= gfc_current_locus
;
2959 m
= gfc_match_sym_tree (&st
, host_flag
);
2965 /* If this is an implicit do loop index and implicitly typed,
2966 it should not be host associated. */
2967 m
= check_for_implicit_index (&st
, &sym
);
2971 sym
->attr
.implied_index
= 0;
2973 gfc_set_sym_referenced (sym
);
2974 switch (sym
->attr
.flavor
)
2977 if (sym
->attr
.is_protected
&& sym
->attr
.use_assoc
)
2979 gfc_error ("Assigning to PROTECTED variable at %C");
2986 sym_flavor flavor
= FL_UNKNOWN
;
2988 gfc_gobble_whitespace ();
2990 if (sym
->attr
.external
|| sym
->attr
.procedure
2991 || sym
->attr
.function
|| sym
->attr
.subroutine
)
2992 flavor
= FL_PROCEDURE
;
2994 /* If it is not a procedure, is not typed and is host associated,
2995 we cannot give it a flavor yet. */
2996 else if (sym
->ns
== gfc_current_ns
->parent
2997 && sym
->ts
.type
== BT_UNKNOWN
)
3000 /* These are definitive indicators that this is a variable. */
3001 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3002 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3003 flavor
= FL_VARIABLE
;
3005 if (flavor
!= FL_UNKNOWN
3006 && gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
) == FAILURE
)
3013 gfc_error ("Named constant at %C in an EQUIVALENCE");
3015 gfc_error ("Cannot assign to a named constant at %C");
3020 /* Check for a nonrecursive function result variable. */
3021 if (sym
->attr
.function
3022 && !sym
->attr
.external
3023 && sym
->result
== sym
3024 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3026 && sym
->ns
== gfc_current_ns
)
3028 && sym
->ns
== gfc_current_ns
->parent
)))
3030 /* If a function result is a derived type, then the derived
3031 type may still have to be resolved. */
3033 if (sym
->ts
.type
== BT_DERIVED
3034 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3039 if (sym
->attr
.proc_pointer
3040 || replace_hidden_procptr_result (&sym
, &st
) == SUCCESS
)
3043 /* Fall through to error */
3046 gfc_error ("'%s' at %C is not a variable", sym
->name
);
3050 /* Special case for derived type variables that get their types
3051 via an IMPLICIT statement. This can't wait for the
3052 resolution phase. */
3055 gfc_namespace
* implicit_ns
;
3057 if (gfc_current_ns
->proc_name
== sym
)
3058 implicit_ns
= gfc_current_ns
;
3060 implicit_ns
= sym
->ns
;
3062 if (gfc_peek_ascii_char () == '%'
3063 && sym
->ts
.type
== BT_UNKNOWN
3064 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3065 gfc_set_default_type (sym
, 0, implicit_ns
);
3068 expr
= gfc_get_expr ();
3070 expr
->expr_type
= EXPR_VARIABLE
;
3073 expr
->where
= where
;
3075 /* Now see if we have to do more. */
3076 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3079 gfc_free_expr (expr
);
3089 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3091 return match_variable (result
, equiv_flag
, 1);
3096 gfc_match_equiv_variable (gfc_expr
**result
)
3098 return match_variable (result
, 1, 0);