1 /* Primary expression subroutines
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
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.
36 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
37 symbol like e.g. 'c_int'. */
40 match_kind_param (int *kind
, int *is_iso_c
)
42 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
49 m
= gfc_match_small_literal_int (kind
, NULL
);
53 m
= gfc_match_name (name
);
57 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
63 *is_iso_c
= sym
->attr
.is_iso_c
;
65 if (sym
->attr
.flavor
!= FL_PARAMETER
)
68 if (sym
->value
== NULL
)
71 p
= gfc_extract_int (sym
->value
, kind
);
75 gfc_set_sym_referenced (sym
);
84 /* Get a trailing kind-specification for non-character variables.
86 * the integer kind value or
87 * -1 if an error was generated,
88 * -2 if no kind was found.
89 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
90 symbol like e.g. 'c_int'. */
93 get_kind (int *is_iso_c
)
100 if (gfc_match_char ('_') != MATCH_YES
)
103 m
= match_kind_param (&kind
, is_iso_c
);
105 gfc_error ("Missing kind-parameter at %C");
107 return (m
== MATCH_YES
) ? kind
: -1;
111 /* Given a character and a radix, see if the character is a valid
112 digit in that radix. */
115 gfc_check_digit (char c
, int radix
)
122 r
= ('0' <= c
&& c
<= '1');
126 r
= ('0' <= c
&& c
<= '7');
130 r
= ('0' <= c
&& c
<= '9');
138 gfc_internal_error ("gfc_check_digit(): bad radix");
145 /* Match the digit string part of an integer if signflag is not set,
146 the signed digit string part if signflag is set. If the buffer
147 is NULL, we just count characters for the resolution pass. Returns
148 the number of characters matched, -1 for no match. */
151 match_digits (int signflag
, int radix
, char *buffer
)
158 c
= gfc_next_ascii_char ();
160 if (signflag
&& (c
== '+' || c
== '-'))
164 gfc_gobble_whitespace ();
165 c
= gfc_next_ascii_char ();
169 if (!gfc_check_digit (c
, radix
))
178 old_loc
= gfc_current_locus
;
179 c
= gfc_next_ascii_char ();
181 if (!gfc_check_digit (c
, radix
))
189 gfc_current_locus
= old_loc
;
195 /* Match an integer (digit string and optional kind).
196 A sign will be accepted if signflag is set. */
199 match_integer_constant (gfc_expr
**result
, int signflag
)
201 int length
, kind
, is_iso_c
;
206 old_loc
= gfc_current_locus
;
207 gfc_gobble_whitespace ();
209 length
= match_digits (signflag
, 10, NULL
);
210 gfc_current_locus
= old_loc
;
214 buffer
= (char *) alloca (length
+ 1);
215 memset (buffer
, '\0', length
+ 1);
217 gfc_gobble_whitespace ();
219 match_digits (signflag
, 10, buffer
);
221 kind
= get_kind (&is_iso_c
);
223 kind
= gfc_default_integer_kind
;
227 if (kind
== 4 && flag_integer4_kind
== 8)
230 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
232 gfc_error ("Integer kind %d at %C not available", kind
);
236 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
237 e
->ts
.is_c_interop
= is_iso_c
;
239 if (gfc_range_check (e
) != ARITH_OK
)
241 gfc_error ("Integer too big for its kind at %C. This check can be "
242 "disabled with the option -fno-range-check");
253 /* Match a Hollerith constant. */
256 match_hollerith_constant (gfc_expr
**result
)
264 old_loc
= gfc_current_locus
;
265 gfc_gobble_whitespace ();
267 if (match_integer_constant (&e
, 0) == MATCH_YES
268 && gfc_match_char ('h') == MATCH_YES
)
270 if (!gfc_notify_std (GFC_STD_LEGACY
, "Hollerith constant at %C"))
273 msg
= gfc_extract_int (e
, &num
);
281 gfc_error ("Invalid Hollerith constant: %L must contain at least "
282 "one character", &old_loc
);
285 if (e
->ts
.kind
!= gfc_default_integer_kind
)
287 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
288 "should be default", &old_loc
);
294 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
297 /* Calculate padding needed to fit default integer memory. */
298 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
300 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
302 for (i
= 0; i
< num
; i
++)
304 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
305 if (! gfc_wide_fits_in_byte (c
))
307 gfc_error ("Invalid Hollerith constant at %L contains a "
308 "wide character", &old_loc
);
312 e
->representation
.string
[i
] = (unsigned char) c
;
315 /* Now pad with blanks and end with a null char. */
316 for (i
= 0; i
< pad
; i
++)
317 e
->representation
.string
[num
+ i
] = ' ';
319 e
->representation
.string
[num
+ i
] = '\0';
320 e
->representation
.length
= num
+ pad
;
329 gfc_current_locus
= old_loc
;
338 /* Match a binary, octal or hexadecimal constant that can be found in
339 a DATA statement. The standard permits b'010...', o'73...', and
340 z'a1...' where b, o, and z can be capital letters. This function
341 also accepts postfixed forms of the constants: '01...'b, '73...'o,
342 and 'a1...'z. An additional extension is the use of x for z. */
345 match_boz_constant (gfc_expr
**result
)
347 int radix
, length
, x_hex
, kind
;
348 locus old_loc
, start_loc
;
349 char *buffer
, post
, delim
;
352 start_loc
= old_loc
= gfc_current_locus
;
353 gfc_gobble_whitespace ();
356 switch (post
= gfc_next_ascii_char ())
378 radix
= 16; /* Set to accept any valid digit string. */
384 /* No whitespace allowed here. */
387 delim
= gfc_next_ascii_char ();
389 if (delim
!= '\'' && delim
!= '\"')
393 && (!gfc_notify_std(GFC_STD_GNU
, "Hexadecimal "
394 "constant at %C uses non-standard syntax")))
397 old_loc
= gfc_current_locus
;
399 length
= match_digits (0, radix
, NULL
);
402 gfc_error ("Empty set of digits in BOZ constant at %C");
406 if (gfc_next_ascii_char () != delim
)
408 gfc_error ("Illegal character in BOZ constant at %C");
414 switch (gfc_next_ascii_char ())
431 if (!gfc_notify_std (GFC_STD_GNU
, "BOZ constant "
432 "at %C uses non-standard postfix syntax"))
436 gfc_current_locus
= old_loc
;
438 buffer
= (char *) alloca (length
+ 1);
439 memset (buffer
, '\0', length
+ 1);
441 match_digits (0, radix
, buffer
);
442 gfc_next_ascii_char (); /* Eat delimiter. */
444 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
446 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
447 "If a data-stmt-constant is a boz-literal-constant, the corresponding
448 variable shall be of type integer. The boz-literal-constant is treated
449 as if it were an int-literal-constant with a kind-param that specifies
450 the representation method with the largest decimal exponent range
451 supported by the processor." */
453 kind
= gfc_max_integer_kind
;
454 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
456 /* Mark as boz variable. */
459 if (gfc_range_check (e
) != ARITH_OK
)
461 gfc_error ("Integer too big for integer kind %i at %C", kind
);
466 if (!gfc_in_match_data ()
467 && (!gfc_notify_std(GFC_STD_F2003
, "BOZ used outside a DATA "
475 gfc_current_locus
= start_loc
;
480 /* Match a real constant of some sort. Allow a signed constant if signflag
484 match_real_constant (gfc_expr
**result
, int signflag
)
486 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
, default_exponent
;
487 locus old_loc
, temp_loc
;
488 char *p
, *buffer
, c
, exp_char
;
492 old_loc
= gfc_current_locus
;
493 gfc_gobble_whitespace ();
497 default_exponent
= 0;
504 c
= gfc_next_ascii_char ();
505 if (signflag
&& (c
== '+' || c
== '-'))
510 gfc_gobble_whitespace ();
511 c
= gfc_next_ascii_char ();
514 /* Scan significand. */
515 for (;; c
= gfc_next_ascii_char (), count
++)
522 /* Check to see if "." goes with a following operator like
524 temp_loc
= gfc_current_locus
;
525 c
= gfc_next_ascii_char ();
527 if (c
== 'e' || c
== 'd' || c
== 'q')
529 c
= gfc_next_ascii_char ();
531 goto done
; /* Operator named .e. or .d. */
535 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
537 gfc_current_locus
= temp_loc
;
551 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
558 if (!gfc_notify_std (GFC_STD_GNU
, "exponent-letter 'q' in "
559 "real-literal-constant at %C"))
561 else if (warn_real_q_constant
)
562 gfc_warning (OPT_Wreal_q_constant
,
563 "Extension: exponent-letter %<q%> in real-literal-constant "
568 c
= gfc_next_ascii_char ();
571 if (c
== '+' || c
== '-')
572 { /* optional sign */
573 c
= gfc_next_ascii_char ();
579 /* With -fdec, default exponent to 0 instead of complaining. */
581 default_exponent
= 1;
584 gfc_error ("Missing exponent in real number at %C");
591 c
= gfc_next_ascii_char ();
596 /* Check that we have a numeric constant. */
597 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
599 gfc_current_locus
= old_loc
;
603 /* Convert the number. */
604 gfc_current_locus
= old_loc
;
605 gfc_gobble_whitespace ();
607 buffer
= (char *) alloca (count
+ default_exponent
+ 1);
608 memset (buffer
, '\0', count
+ default_exponent
+ 1);
611 c
= gfc_next_ascii_char ();
612 if (c
== '+' || c
== '-')
614 gfc_gobble_whitespace ();
615 c
= gfc_next_ascii_char ();
618 /* Hack for mpfr_set_str(). */
621 if (c
== 'd' || c
== 'q')
629 c
= gfc_next_ascii_char ();
631 if (default_exponent
)
634 kind
= get_kind (&is_iso_c
);
643 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
647 kind
= gfc_default_double_kind
;
651 if (flag_real4_kind
== 8)
653 if (flag_real4_kind
== 10)
655 if (flag_real4_kind
== 16)
661 if (flag_real8_kind
== 4)
663 if (flag_real8_kind
== 10)
665 if (flag_real8_kind
== 16)
673 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
678 /* The maximum possible real kind type parameter is 16. First, try
679 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
680 extended precision. If neither value works, just given up. */
682 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
685 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
687 gfc_error ("Invalid exponent-letter %<q%> in "
688 "real-literal-constant at %C");
696 kind
= gfc_default_real_kind
;
700 if (flag_real4_kind
== 8)
702 if (flag_real4_kind
== 10)
704 if (flag_real4_kind
== 16)
710 if (flag_real8_kind
== 4)
712 if (flag_real8_kind
== 10)
714 if (flag_real8_kind
== 16)
718 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
720 gfc_error ("Invalid real kind %d at %C", kind
);
725 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
727 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
728 e
->ts
.is_c_interop
= is_iso_c
;
730 switch (gfc_range_check (e
))
735 gfc_error ("Real constant overflows its kind at %C");
738 case ARITH_UNDERFLOW
:
740 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
741 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
745 gfc_internal_error ("gfc_range_check() returned bad value");
748 /* Warn about trailing digits which suggest the user added too many
749 trailing digits, which may cause the appearance of higher pecision
750 than the kind kan support.
752 This is done by replacing the rightmost non-zero digit with zero
753 and comparing with the original value. If these are equal, we
754 assume the user supplied more digits than intended (or forgot to
755 convert to the correct kind).
758 if (warn_conversion_extra
)
764 c
= strchr (buffer
, 'e');
766 c
= buffer
+ strlen(buffer
);
769 for (p
= c
- 1; p
>= buffer
; p
--)
785 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
787 mpfr_neg (r
, r
, GFC_RND_MODE
);
789 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
791 if (mpfr_cmp_ui (r
, 0) == 0)
792 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
793 "in %qs number at %C, maybe incorrect KIND",
794 gfc_typename (&e
->ts
));
809 /* Match a substring reference. */
812 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
, bool deferred
)
814 gfc_expr
*start
, *end
;
822 old_loc
= gfc_current_locus
;
824 m
= gfc_match_char ('(');
828 if (gfc_match_char (':') != MATCH_YES
)
831 m
= gfc_match_init_expr (&start
);
833 m
= gfc_match_expr (&start
);
841 m
= gfc_match_char (':');
846 if (gfc_match_char (')') != MATCH_YES
)
849 m
= gfc_match_init_expr (&end
);
851 m
= gfc_match_expr (&end
);
855 if (m
== MATCH_ERROR
)
858 m
= gfc_match_char (')');
863 /* Optimize away the (:) reference. */
864 if (start
== NULL
&& end
== NULL
&& !deferred
)
868 ref
= gfc_get_ref ();
870 ref
->type
= REF_SUBSTRING
;
872 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
873 ref
->u
.ss
.start
= start
;
874 if (end
== NULL
&& cl
)
875 end
= gfc_copy_expr (cl
->length
);
877 ref
->u
.ss
.length
= cl
;
884 gfc_error ("Syntax error in SUBSTRING specification at %C");
888 gfc_free_expr (start
);
891 gfc_current_locus
= old_loc
;
896 /* Reads the next character of a string constant, taking care to
897 return doubled delimiters on the input as a single instance of
900 Special return values for "ret" argument are:
901 -1 End of the string, as determined by the delimiter
902 -2 Unterminated string detected
904 Backslash codes are also expanded at this time. */
907 next_string_char (gfc_char_t delimiter
, int *ret
)
912 c
= gfc_next_char_literal (INSTRING_WARN
);
921 if (flag_backslash
&& c
== '\\')
923 old_locus
= gfc_current_locus
;
925 if (gfc_match_special_char (&c
) == MATCH_NO
)
926 gfc_current_locus
= old_locus
;
928 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
929 gfc_warning (0, "Extension: backslash character at %C");
935 old_locus
= gfc_current_locus
;
936 c
= gfc_next_char_literal (NONSTRING
);
940 gfc_current_locus
= old_locus
;
947 /* Special case of gfc_match_name() that matches a parameter kind name
948 before a string constant. This takes case of the weird but legal
953 where kind____ is a parameter. gfc_match_name() will happily slurp
954 up all the underscores, which leads to problems. If we return
955 MATCH_YES, the parse pointer points to the final underscore, which
956 is not part of the name. We never return MATCH_ERROR-- errors in
957 the name will be detected later. */
960 match_charkind_name (char *name
)
966 gfc_gobble_whitespace ();
967 c
= gfc_next_ascii_char ();
976 old_loc
= gfc_current_locus
;
977 c
= gfc_next_ascii_char ();
981 peek
= gfc_peek_ascii_char ();
983 if (peek
== '\'' || peek
== '\"')
985 gfc_current_locus
= old_loc
;
993 && (c
!= '$' || !flag_dollar_ok
))
997 if (++len
> GFC_MAX_SYMBOL_LEN
)
1005 /* See if the current input matches a character constant. Lots of
1006 contortions have to be done to match the kind parameter which comes
1007 before the actual string. The main consideration is that we don't
1008 want to error out too quickly. For example, we don't actually do
1009 any validation of the kinds until we have actually seen a legal
1010 delimiter. Using match_kind_param() generates errors too quickly. */
1013 match_string_constant (gfc_expr
**result
)
1015 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1016 int i
, kind
, length
, save_warn_ampersand
, ret
;
1017 locus old_locus
, start_locus
;
1022 gfc_char_t c
, delimiter
, *p
;
1024 old_locus
= gfc_current_locus
;
1026 gfc_gobble_whitespace ();
1028 c
= gfc_next_char ();
1029 if (c
== '\'' || c
== '"')
1031 kind
= gfc_default_character_kind
;
1032 start_locus
= gfc_current_locus
;
1036 if (gfc_wide_is_digit (c
))
1040 while (gfc_wide_is_digit (c
))
1042 kind
= kind
* 10 + c
- '0';
1045 c
= gfc_next_char ();
1051 gfc_current_locus
= old_locus
;
1053 m
= match_charkind_name (name
);
1057 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1059 || sym
->attr
.flavor
!= FL_PARAMETER
)
1063 c
= gfc_next_char ();
1068 gfc_gobble_whitespace ();
1069 c
= gfc_next_char ();
1075 gfc_gobble_whitespace ();
1077 c
= gfc_next_char ();
1078 if (c
!= '\'' && c
!= '"')
1081 start_locus
= gfc_current_locus
;
1085 q
= gfc_extract_int (sym
->value
, &kind
);
1091 gfc_set_sym_referenced (sym
);
1094 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1096 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1101 /* Scan the string into a block of memory by first figuring out how
1102 long it is, allocating the structure, then re-reading it. This
1103 isn't particularly efficient, but string constants aren't that
1104 common in most code. TODO: Use obstacks? */
1111 c
= next_string_char (delimiter
, &ret
);
1116 gfc_current_locus
= start_locus
;
1117 gfc_error ("Unterminated character constant beginning at %C");
1124 /* Peek at the next character to see if it is a b, o, z, or x for the
1125 postfixed BOZ literal constants. */
1126 peek
= gfc_peek_ascii_char ();
1127 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1130 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1132 gfc_current_locus
= start_locus
;
1134 /* We disable the warning for the following loop as the warning has already
1135 been printed in the loop above. */
1136 save_warn_ampersand
= warn_ampersand
;
1137 warn_ampersand
= false;
1139 p
= e
->value
.character
.string
;
1140 for (i
= 0; i
< length
; i
++)
1142 c
= next_string_char (delimiter
, &ret
);
1144 if (!gfc_check_character_range (c
, kind
))
1147 gfc_error ("Character %qs in string at %C is not representable "
1148 "in character kind %d", gfc_print_wide_char (c
), kind
);
1155 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1156 warn_ampersand
= save_warn_ampersand
;
1158 next_string_char (delimiter
, &ret
);
1160 gfc_internal_error ("match_string_constant(): Delimiter not found");
1162 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1163 e
->expr_type
= EXPR_SUBSTRING
;
1170 gfc_current_locus
= old_locus
;
1175 /* Match a .true. or .false. Returns 1 if a .true. was found,
1176 0 if a .false. was found, and -1 otherwise. */
1178 match_logical_constant_string (void)
1180 locus orig_loc
= gfc_current_locus
;
1182 gfc_gobble_whitespace ();
1183 if (gfc_next_ascii_char () == '.')
1185 char ch
= gfc_next_ascii_char ();
1188 if (gfc_next_ascii_char () == 'a'
1189 && gfc_next_ascii_char () == 'l'
1190 && gfc_next_ascii_char () == 's'
1191 && gfc_next_ascii_char () == 'e'
1192 && gfc_next_ascii_char () == '.')
1193 /* Matched ".false.". */
1198 if (gfc_next_ascii_char () == 'r'
1199 && gfc_next_ascii_char () == 'u'
1200 && gfc_next_ascii_char () == 'e'
1201 && gfc_next_ascii_char () == '.')
1202 /* Matched ".true.". */
1206 gfc_current_locus
= orig_loc
;
1210 /* Match a .true. or .false. */
1213 match_logical_constant (gfc_expr
**result
)
1216 int i
, kind
, is_iso_c
;
1218 i
= match_logical_constant_string ();
1222 kind
= get_kind (&is_iso_c
);
1226 kind
= gfc_default_logical_kind
;
1228 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1230 gfc_error ("Bad kind for logical constant at %C");
1234 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1235 e
->ts
.is_c_interop
= is_iso_c
;
1242 /* Match a real or imaginary part of a complex constant that is a
1243 symbolic constant. */
1246 match_sym_complex_part (gfc_expr
**result
)
1248 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1253 m
= gfc_match_name (name
);
1257 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1260 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1262 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1269 if (!gfc_numeric_ts (&sym
->value
->ts
))
1271 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1275 if (sym
->value
->rank
!= 0)
1277 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1281 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1282 "complex constant at %C"))
1285 switch (sym
->value
->ts
.type
)
1288 e
= gfc_copy_expr (sym
->value
);
1292 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1298 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1304 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1307 *result
= e
; /* e is a scalar, real, constant expression. */
1311 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1316 /* Match a real or imaginary part of a complex number. */
1319 match_complex_part (gfc_expr
**result
)
1323 m
= match_sym_complex_part (result
);
1327 m
= match_real_constant (result
, 1);
1331 return match_integer_constant (result
, 1);
1335 /* Try to match a complex constant. */
1338 match_complex_constant (gfc_expr
**result
)
1340 gfc_expr
*e
, *real
, *imag
;
1341 gfc_error_buffer old_error
;
1342 gfc_typespec target
;
1347 old_loc
= gfc_current_locus
;
1348 real
= imag
= e
= NULL
;
1350 m
= gfc_match_char ('(');
1354 gfc_push_error (&old_error
);
1356 m
= match_complex_part (&real
);
1359 gfc_free_error (&old_error
);
1363 if (gfc_match_char (',') == MATCH_NO
)
1365 /* It is possible that gfc_int2real issued a warning when
1366 converting an integer to real. Throw this away here. */
1368 gfc_clear_warning ();
1369 gfc_pop_error (&old_error
);
1374 /* If m is error, then something was wrong with the real part and we
1375 assume we have a complex constant because we've seen the ','. An
1376 ambiguous case here is the start of an iterator list of some
1377 sort. These sort of lists are matched prior to coming here. */
1379 if (m
== MATCH_ERROR
)
1381 gfc_free_error (&old_error
);
1384 gfc_pop_error (&old_error
);
1386 m
= match_complex_part (&imag
);
1389 if (m
== MATCH_ERROR
)
1392 m
= gfc_match_char (')');
1395 /* Give the matcher for implied do-loops a chance to run. This
1396 yields a much saner error message for (/ (i, 4=i, 6) /). */
1397 if (gfc_peek_ascii_char () == '=')
1406 if (m
== MATCH_ERROR
)
1409 /* Decide on the kind of this complex number. */
1410 if (real
->ts
.type
== BT_REAL
)
1412 if (imag
->ts
.type
== BT_REAL
)
1413 kind
= gfc_kind_max (real
, imag
);
1415 kind
= real
->ts
.kind
;
1419 if (imag
->ts
.type
== BT_REAL
)
1420 kind
= imag
->ts
.kind
;
1422 kind
= gfc_default_real_kind
;
1424 gfc_clear_ts (&target
);
1425 target
.type
= BT_REAL
;
1428 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1429 gfc_convert_type (real
, &target
, 2);
1430 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1431 gfc_convert_type (imag
, &target
, 2);
1433 e
= gfc_convert_complex (real
, imag
, kind
);
1434 e
->where
= gfc_current_locus
;
1436 gfc_free_expr (real
);
1437 gfc_free_expr (imag
);
1443 gfc_error ("Syntax error in COMPLEX constant at %C");
1448 gfc_free_expr (real
);
1449 gfc_free_expr (imag
);
1450 gfc_current_locus
= old_loc
;
1456 /* Match constants in any of several forms. Returns nonzero for a
1457 match, zero for no match. */
1460 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1464 m
= match_complex_constant (result
);
1468 m
= match_string_constant (result
);
1472 m
= match_boz_constant (result
);
1476 m
= match_real_constant (result
, signflag
);
1480 m
= match_hollerith_constant (result
);
1484 m
= match_integer_constant (result
, signflag
);
1488 m
= match_logical_constant (result
);
1496 /* This checks if a symbol is the return value of an encompassing function.
1497 Function nesting can be maximally two levels deep, but we may have
1498 additional local namespaces like BLOCK etc. */
1501 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1503 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1507 if (ns
->proc_name
== sym
)
1515 /* Match a single actual argument value. An actual argument is
1516 usually an expression, but can also be a procedure name. If the
1517 argument is a single name, it is not always possible to tell
1518 whether the name is a dummy procedure or not. We treat these cases
1519 by creating an argument that looks like a dummy procedure and
1520 fixing things later during resolution. */
1523 match_actual_arg (gfc_expr
**result
)
1525 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1526 gfc_symtree
*symtree
;
1531 gfc_gobble_whitespace ();
1532 where
= gfc_current_locus
;
1534 switch (gfc_match_name (name
))
1543 w
= gfc_current_locus
;
1544 gfc_gobble_whitespace ();
1545 c
= gfc_next_ascii_char ();
1546 gfc_current_locus
= w
;
1548 if (c
!= ',' && c
!= ')')
1551 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1553 /* Handle error elsewhere. */
1555 /* Eliminate a couple of common cases where we know we don't
1556 have a function argument. */
1557 if (symtree
== NULL
)
1559 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1560 gfc_set_sym_referenced (symtree
->n
.sym
);
1566 sym
= symtree
->n
.sym
;
1567 gfc_set_sym_referenced (sym
);
1568 if (sym
->attr
.flavor
== FL_NAMELIST
)
1570 gfc_error ("Namelist '%s' can not be an argument at %L",
1574 if (sym
->attr
.flavor
!= FL_PROCEDURE
1575 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1578 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1580 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1581 sym
->name
, &sym
->declared_at
))
1586 /* If the symbol is a function with itself as the result and
1587 is being defined, then we have a variable. */
1588 if (sym
->attr
.function
&& sym
->result
== sym
)
1590 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1594 && (sym
->ns
== gfc_current_ns
1595 || sym
->ns
== gfc_current_ns
->parent
))
1597 gfc_entry_list
*el
= NULL
;
1599 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1609 e
= gfc_get_expr (); /* Leave it unknown for now */
1610 e
->symtree
= symtree
;
1611 e
->expr_type
= EXPR_VARIABLE
;
1612 e
->ts
.type
= BT_PROCEDURE
;
1619 gfc_current_locus
= where
;
1620 return gfc_match_expr (result
);
1624 /* Match a keyword argument. */
1627 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1629 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1630 gfc_actual_arglist
*a
;
1634 name_locus
= gfc_current_locus
;
1635 m
= gfc_match_name (name
);
1639 if (gfc_match_char ('=') != MATCH_YES
)
1645 m
= match_actual_arg (&actual
->expr
);
1649 /* Make sure this name has not appeared yet. */
1651 if (name
[0] != '\0')
1653 for (a
= base
; a
; a
= a
->next
)
1654 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1656 gfc_error ("Keyword %qs at %C has already appeared in the "
1657 "current argument list", name
);
1662 actual
->name
= gfc_get_string (name
);
1666 gfc_current_locus
= name_locus
;
1671 /* Match an argument list function, such as %VAL. */
1674 match_arg_list_function (gfc_actual_arglist
*result
)
1676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1680 old_locus
= gfc_current_locus
;
1682 if (gfc_match_char ('%') != MATCH_YES
)
1688 m
= gfc_match ("%n (", name
);
1692 if (name
[0] != '\0')
1697 if (strncmp (name
, "loc", 3) == 0)
1699 result
->name
= "%LOC";
1704 if (strncmp (name
, "ref", 3) == 0)
1706 result
->name
= "%REF";
1711 if (strncmp (name
, "val", 3) == 0)
1713 result
->name
= "%VAL";
1723 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1729 m
= match_actual_arg (&result
->expr
);
1733 if (gfc_match_char (')') != MATCH_YES
)
1742 gfc_current_locus
= old_locus
;
1747 /* Matches an actual argument list of a function or subroutine, from
1748 the opening parenthesis to the closing parenthesis. The argument
1749 list is assumed to allow keyword arguments because we don't know if
1750 the symbol associated with the procedure has an implicit interface
1751 or not. We make sure keywords are unique. If sub_flag is set,
1752 we're matching the argument list of a subroutine. */
1755 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1757 gfc_actual_arglist
*head
, *tail
;
1759 gfc_st_label
*label
;
1763 *argp
= tail
= NULL
;
1764 old_loc
= gfc_current_locus
;
1768 if (gfc_match_char ('(') == MATCH_NO
)
1769 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1771 if (gfc_match_char (')') == MATCH_YES
)
1775 matching_actual_arglist
++;
1780 head
= tail
= gfc_get_actual_arglist ();
1783 tail
->next
= gfc_get_actual_arglist ();
1787 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1789 m
= gfc_match_st_label (&label
);
1791 gfc_error ("Expected alternate return label at %C");
1795 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1799 tail
->label
= label
;
1803 /* After the first keyword argument is seen, the following
1804 arguments must also have keywords. */
1807 m
= match_keyword_arg (tail
, head
);
1809 if (m
== MATCH_ERROR
)
1813 gfc_error ("Missing keyword name in actual argument list at %C");
1820 /* Try an argument list function, like %VAL. */
1821 m
= match_arg_list_function (tail
);
1822 if (m
== MATCH_ERROR
)
1825 /* See if we have the first keyword argument. */
1828 m
= match_keyword_arg (tail
, head
);
1831 if (m
== MATCH_ERROR
)
1837 /* Try for a non-keyword argument. */
1838 m
= match_actual_arg (&tail
->expr
);
1839 if (m
== MATCH_ERROR
)
1848 if (gfc_match_char (')') == MATCH_YES
)
1850 if (gfc_match_char (',') != MATCH_YES
)
1855 matching_actual_arglist
--;
1859 gfc_error ("Syntax error in argument list at %C");
1862 gfc_free_actual_arglist (head
);
1863 gfc_current_locus
= old_loc
;
1864 matching_actual_arglist
--;
1869 /* Used by gfc_match_varspec() to extend the reference list by one
1873 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1875 if (primary
->ref
== NULL
)
1876 primary
->ref
= tail
= gfc_get_ref ();
1880 gfc_internal_error ("extend_ref(): Bad tail");
1881 tail
->next
= gfc_get_ref ();
1889 /* Match any additional specifications associated with the current
1890 variable like member references or substrings. If equiv_flag is
1891 set we only match stuff that is allowed inside an EQUIVALENCE
1892 statement. sub_flag tells whether we expect a type-bound procedure found
1893 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1894 components, 'ppc_arg' determines whether the PPC may be called (with an
1895 argument list), or whether it may just be referred to as a pointer. */
1898 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1901 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1902 gfc_ref
*substring
, *tail
, *tmp
;
1903 gfc_component
*component
;
1904 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1911 gfc_gobble_whitespace ();
1913 if (gfc_peek_ascii_char () == '[')
1915 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1916 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1917 && CLASS_DATA (sym
)->attr
.dimension
))
1919 gfc_error ("Array section designator, e.g. '(:)', is required "
1920 "besides the coarray designator '[...]' at %C");
1923 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1924 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1925 && !CLASS_DATA (sym
)->attr
.codimension
))
1927 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1933 /* For associate names, we may not yet know whether they are arrays or not.
1934 If the selector expression is unambiguously an array; eg. a full array
1935 or an array section, then the associate name must be an array and we can
1936 fix it now. Otherwise, if parentheses follow and it is not a character
1937 type, we have to assume that it actually is one for now. The final
1938 decision will be made at resolution, of course. */
1940 && gfc_peek_ascii_char () == '('
1941 && sym
->ts
.type
!= BT_CLASS
1942 && !sym
->attr
.dimension
)
1944 if ((!sym
->assoc
->dangling
1945 && sym
->assoc
->target
1946 && sym
->assoc
->target
->ref
1947 && sym
->assoc
->target
->ref
->type
== REF_ARRAY
1948 && (sym
->assoc
->target
->ref
->u
.ar
.type
== AR_FULL
1949 || sym
->assoc
->target
->ref
->u
.ar
.type
== AR_SECTION
))
1951 (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
1953 && sym
->assoc
->st
->n
.sym
1954 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
1956 sym
->attr
.dimension
= 1;
1957 if (sym
->as
== NULL
&& sym
->assoc
1959 && sym
->assoc
->st
->n
.sym
1960 && sym
->assoc
->st
->n
.sym
->as
)
1961 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
1965 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1966 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1967 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1968 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1969 && !(gfc_matching_procptr_assignment
1970 && sym
->attr
.flavor
== FL_PROCEDURE
))
1971 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1972 && (CLASS_DATA (sym
)->attr
.dimension
1973 || CLASS_DATA (sym
)->attr
.codimension
)))
1977 tail
= extend_ref (primary
, tail
);
1978 tail
->type
= REF_ARRAY
;
1980 /* In EQUIVALENCE, we don't know yet whether we are seeing
1981 an array, character variable or array of character
1982 variables. We'll leave the decision till resolve time. */
1986 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1987 as
= CLASS_DATA (sym
)->as
;
1991 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1992 as
? as
->corank
: 0);
1996 gfc_gobble_whitespace ();
1997 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1999 tail
= extend_ref (primary
, tail
);
2000 tail
->type
= REF_ARRAY
;
2002 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2008 primary
->ts
= sym
->ts
;
2013 /* With DEC extensions, member separator may be '.' or '%'. */
2014 sep
= gfc_peek_ascii_char ();
2015 m
= gfc_match_member_sep (sym
);
2016 if (m
== MATCH_ERROR
)
2019 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2020 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2021 gfc_set_default_type (sym
, 0, sym
->ns
);
2023 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2025 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2028 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2031 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2036 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2038 goto check_substring
;
2040 sym
= sym
->ts
.u
.derived
;
2047 m
= gfc_match_name (name
);
2049 gfc_error ("Expected structure component name at %C");
2053 if (sym
&& sym
->f2k_derived
)
2054 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2060 gfc_symbol
* tbp_sym
;
2065 gcc_assert (!tail
|| !tail
->next
);
2067 if (!(primary
->expr_type
== EXPR_VARIABLE
2068 || (primary
->expr_type
== EXPR_STRUCTURE
2069 && primary
->symtree
&& primary
->symtree
->n
.sym
2070 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2073 if (tbp
->n
.tb
->is_generic
)
2076 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2078 primary
->expr_type
= EXPR_COMPCALL
;
2079 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2080 primary
->value
.compcall
.name
= tbp
->name
;
2081 primary
->value
.compcall
.ignore_pass
= 0;
2082 primary
->value
.compcall
.assign
= 0;
2083 primary
->value
.compcall
.base_object
= NULL
;
2084 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2086 primary
->ts
= tbp_sym
->ts
;
2088 gfc_clear_ts (&primary
->ts
);
2090 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2091 &primary
->value
.compcall
.actual
);
2092 if (m
== MATCH_ERROR
)
2097 primary
->value
.compcall
.actual
= NULL
;
2100 gfc_error ("Expected argument list at %C");
2108 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2109 if (component
== NULL
)
2112 /* Extend the reference chain determined by gfc_find_component. */
2113 if (primary
->ref
== NULL
)
2117 /* Set by the for loop below for the last component ref. */
2118 gcc_assert (tail
!= NULL
);
2122 /* The reference chain may be longer than one hop for union
2123 subcomponents; find the new tail. */
2124 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2127 primary
->ts
= component
->ts
;
2129 if (component
->attr
.proc_pointer
&& ppc_arg
)
2131 /* Procedure pointer component call: Look for argument list. */
2132 m
= gfc_match_actual_arglist (sub_flag
,
2133 &primary
->value
.compcall
.actual
);
2134 if (m
== MATCH_ERROR
)
2137 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2138 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2140 gfc_error ("Procedure pointer component %qs requires an "
2141 "argument list at %C", component
->name
);
2146 primary
->expr_type
= EXPR_PPC
;
2151 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2153 tail
= extend_ref (primary
, tail
);
2154 tail
->type
= REF_ARRAY
;
2156 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2157 component
->as
->corank
);
2161 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2162 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2164 tail
= extend_ref (primary
, tail
);
2165 tail
->type
= REF_ARRAY
;
2167 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2169 CLASS_DATA (component
)->as
->corank
);
2174 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2175 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2178 sym
= component
->ts
.u
.derived
;
2183 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2185 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2187 gfc_set_default_type (sym
, 0, sym
->ns
);
2188 primary
->ts
= sym
->ts
;
2193 if (primary
->ts
.type
== BT_CHARACTER
)
2195 bool def
= primary
->ts
.deferred
== 1;
2196 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2200 primary
->ref
= substring
;
2202 tail
->next
= substring
;
2204 if (primary
->expr_type
== EXPR_CONSTANT
)
2205 primary
->expr_type
= EXPR_SUBSTRING
;
2208 primary
->ts
.u
.cl
= NULL
;
2215 gfc_clear_ts (&primary
->ts
);
2216 gfc_clear_ts (&sym
->ts
);
2226 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2227 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2229 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2234 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2236 gfc_error ("Coindexed procedure-pointer component at %C");
2244 /* Given an expression that is a variable, figure out what the
2245 ultimate variable's type and attribute is, traversing the reference
2246 structures if necessary.
2248 This subroutine is trickier than it looks. We start at the base
2249 symbol and store the attribute. Component references load a
2250 completely new attribute.
2252 A couple of rules come into play. Subobjects of targets are always
2253 targets themselves. If we see a component that goes through a
2254 pointer, then the expression must also be a target, since the
2255 pointer is associated with something (if it isn't core will soon be
2256 dumped). If we see a full part or section of an array, the
2257 expression is also an array.
2259 We can have at most one full array reference. */
2262 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2264 int dimension
, codimension
, pointer
, allocatable
, target
;
2265 symbol_attribute attr
;
2268 gfc_component
*comp
;
2270 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2271 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2273 sym
= expr
->symtree
->n
.sym
;
2276 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2278 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2279 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2280 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2281 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2285 dimension
= attr
.dimension
;
2286 codimension
= attr
.codimension
;
2287 pointer
= attr
.pointer
;
2288 allocatable
= attr
.allocatable
;
2291 target
= attr
.target
;
2292 if (pointer
|| attr
.proc_pointer
)
2295 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2298 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2303 switch (ref
->u
.ar
.type
)
2310 allocatable
= pointer
= 0;
2315 /* Handle coarrays. */
2316 if (ref
->u
.ar
.dimen
> 0)
2317 allocatable
= pointer
= 0;
2321 /* If any of start, end or stride is not integer, there will
2322 already have been an error issued. */
2324 gfc_get_errors (NULL
, &errors
);
2326 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2332 comp
= ref
->u
.c
.component
;
2337 /* Don't set the string length if a substring reference
2339 if (ts
->type
== BT_CHARACTER
2340 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2344 if (comp
->ts
.type
== BT_CLASS
)
2346 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2347 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2348 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2352 codimension
= comp
->attr
.codimension
;
2353 pointer
= comp
->attr
.pointer
;
2354 allocatable
= comp
->attr
.allocatable
;
2356 if (pointer
|| attr
.proc_pointer
)
2362 allocatable
= pointer
= 0;
2366 attr
.dimension
= dimension
;
2367 attr
.codimension
= codimension
;
2368 attr
.pointer
= pointer
;
2369 attr
.allocatable
= allocatable
;
2370 attr
.target
= target
;
2371 attr
.save
= sym
->attr
.save
;
2377 /* Return the attribute from a general expression. */
2380 gfc_expr_attr (gfc_expr
*e
)
2382 symbol_attribute attr
;
2384 switch (e
->expr_type
)
2387 attr
= gfc_variable_attr (e
, NULL
);
2391 gfc_clear_attr (&attr
);
2393 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2395 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2397 if (sym
->ts
.type
== BT_CLASS
)
2399 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2400 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2401 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2404 else if (e
->value
.function
.isym
2405 && e
->value
.function
.isym
->transformational
2406 && e
->ts
.type
== BT_CLASS
)
2407 attr
= CLASS_DATA (e
)->attr
;
2409 attr
= gfc_variable_attr (e
, NULL
);
2411 /* TODO: NULL() returns pointers. May have to take care of this
2417 gfc_clear_attr (&attr
);
2425 /* Given an expression, figure out what the ultimate expression
2426 attribute is. This routine is similar to gfc_variable_attr with
2427 parts of gfc_expr_attr, but focuses more on the needs of
2428 coarrays. For coarrays a codimension attribute is kind of
2429 "infectious" being propagated once set and never cleared.
2430 The coarray_comp is only set, when the expression refs a coarray
2431 component. REFS_COMP is set when present to true only, when this EXPR
2432 refs a (non-_data) component. To check whether EXPR refs an allocatable
2433 component in a derived type coarray *refs_comp needs to be set and
2434 coarray_comp has to false. */
2436 static symbol_attribute
2437 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2439 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
,
2441 symbol_attribute attr
;
2444 gfc_component
*comp
;
2446 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2447 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2449 sym
= expr
->symtree
->n
.sym
;
2450 gfc_clear_attr (&attr
);
2455 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2457 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2458 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2459 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2460 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2461 alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2465 dimension
= sym
->attr
.dimension
;
2466 codimension
= sym
->attr
.codimension
;
2467 pointer
= sym
->attr
.pointer
;
2468 allocatable
= sym
->attr
.allocatable
;
2469 alloc_comp
= sym
->ts
.type
== BT_DERIVED
2470 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2473 target
= coarray_comp
= 0;
2474 if (pointer
|| attr
.proc_pointer
)
2477 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2482 switch (ref
->u
.ar
.type
)
2490 /* Handle coarrays. */
2491 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2492 allocatable
= pointer
= 0;
2496 /* If any of start, end or stride is not integer, there will
2497 already have been an error issued. */
2499 gfc_get_errors (NULL
, &errors
);
2501 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2507 comp
= ref
->u
.c
.component
;
2509 if (comp
->ts
.type
== BT_CLASS
)
2511 /* Set coarray_comp only, when this component introduces the
2513 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2514 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2515 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2516 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2520 /* Set coarray_comp only, when this component introduces the
2522 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2523 codimension
|= comp
->attr
.codimension
;
2524 pointer
= comp
->attr
.pointer
;
2525 allocatable
= comp
->attr
.allocatable
;
2528 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0)
2531 if (pointer
|| attr
.proc_pointer
)
2537 allocatable
= pointer
= 0;
2541 attr
.dimension
= dimension
;
2542 attr
.codimension
= codimension
;
2543 attr
.pointer
= pointer
;
2544 attr
.allocatable
= allocatable
;
2545 attr
.target
= target
;
2546 attr
.save
= sym
->attr
.save
;
2547 attr
.coarray_comp
= coarray_comp
;
2548 attr
.alloc_comp
= alloc_comp
;
2555 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2557 symbol_attribute attr
;
2559 switch (e
->expr_type
)
2562 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2566 gfc_clear_attr (&attr
);
2568 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2570 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2572 if (sym
->ts
.type
== BT_CLASS
)
2574 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2575 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2576 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2577 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2580 else if (e
->symtree
)
2581 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2583 gfc_clear_attr (&attr
);
2587 gfc_clear_attr (&attr
);
2595 /* Match a structure constructor. The initial symbol has already been
2598 typedef struct gfc_structure_ctor_component
2603 struct gfc_structure_ctor_component
* next
;
2605 gfc_structure_ctor_component
;
2607 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2610 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2613 gfc_free_expr (comp
->val
);
2618 /* Translate the component list into the actual constructor by sorting it in
2619 the order required; this also checks along the way that each and every
2620 component actually has an initializer and handles default initializers
2621 for components without explicit value given. */
2623 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2624 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2626 gfc_structure_ctor_component
*comp_iter
;
2627 gfc_component
*comp
;
2629 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2631 gfc_structure_ctor_component
**next_ptr
;
2632 gfc_expr
*value
= NULL
;
2634 /* Try to find the initializer for the current component by name. */
2635 next_ptr
= comp_head
;
2636 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2638 if (!strcmp (comp_iter
->name
, comp
->name
))
2640 next_ptr
= &comp_iter
->next
;
2643 /* If an extension, try building the parent derived type by building
2644 a value expression for the parent derived type and calling self. */
2645 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2647 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2649 &gfc_current_locus
);
2650 value
->ts
= comp
->ts
;
2652 if (!build_actual_constructor (comp_head
,
2653 &value
->value
.constructor
,
2654 comp
->ts
.u
.derived
))
2656 gfc_free_expr (value
);
2660 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2664 /* If it was not found, try the default initializer if there's any;
2665 otherwise, it's an error unless this is a deferred parameter. */
2668 if (comp
->initializer
)
2670 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2671 "with missing optional arguments at %C"))
2673 value
= gfc_copy_expr (comp
->initializer
);
2675 else if (comp
->attr
.allocatable
2676 || (comp
->ts
.type
== BT_CLASS
2677 && CLASS_DATA (comp
)->attr
.allocatable
))
2679 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2680 "allocatable component '%qs' given in the "
2681 "structure constructor at %C", comp
->name
))
2684 else if (!comp
->attr
.artificial
)
2686 gfc_error ("No initializer for component %qs given in the"
2687 " structure constructor at %C!", comp
->name
);
2692 value
= comp_iter
->val
;
2694 /* Add the value to the constructor chain built. */
2695 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2697 /* Remove the entry from the component list. We don't want the expression
2698 value to be free'd, so set it to NULL. */
2701 *next_ptr
= comp_iter
->next
;
2702 comp_iter
->val
= NULL
;
2703 gfc_free_structure_ctor_component (comp_iter
);
2711 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2712 gfc_actual_arglist
**arglist
,
2715 gfc_actual_arglist
*actual
;
2716 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2717 gfc_constructor_base ctor_head
= NULL
;
2718 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2719 const char* last_name
= NULL
;
2723 expr
= parent
? *cexpr
: e
;
2724 old_locus
= gfc_current_locus
;
2726 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2728 gfc_current_locus
= expr
->where
;
2730 comp_tail
= comp_head
= NULL
;
2732 if (!parent
&& sym
->attr
.abstract
)
2734 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2735 sym
->name
, &expr
->where
);
2739 comp
= sym
->components
;
2740 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2743 gfc_component
*this_comp
= NULL
;
2746 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2749 comp_tail
->next
= gfc_get_structure_ctor_component ();
2750 comp_tail
= comp_tail
->next
;
2754 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2755 " constructor with named arguments at %C"))
2758 comp_tail
->name
= xstrdup (actual
->name
);
2759 last_name
= comp_tail
->name
;
2764 /* Components without name are not allowed after the first named
2765 component initializer! */
2766 if (!comp
|| comp
->attr
.artificial
)
2769 gfc_error ("Component initializer without name after component"
2770 " named %s at %L!", last_name
,
2771 actual
->expr
? &actual
->expr
->where
2772 : &gfc_current_locus
);
2774 gfc_error ("Too many components in structure constructor at "
2775 "%L!", actual
->expr
? &actual
->expr
->where
2776 : &gfc_current_locus
);
2780 comp_tail
->name
= xstrdup (comp
->name
);
2783 /* Find the current component in the structure definition and check
2784 its access is not private. */
2786 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
2789 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2790 false, false, NULL
);
2791 comp
= NULL
; /* Reset needed! */
2794 /* Here we can check if a component name is given which does not
2795 correspond to any component of the defined structure. */
2799 comp_tail
->val
= actual
->expr
;
2800 if (actual
->expr
!= NULL
)
2801 comp_tail
->where
= actual
->expr
->where
;
2802 actual
->expr
= NULL
;
2804 /* Check if this component is already given a value. */
2805 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2806 comp_iter
= comp_iter
->next
)
2808 gcc_assert (comp_iter
);
2809 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2811 gfc_error ("Component %qs is initialized twice in the structure"
2812 " constructor at %L!", comp_tail
->name
,
2813 comp_tail
->val
? &comp_tail
->where
2814 : &gfc_current_locus
);
2819 /* F2008, R457/C725, for PURE C1283. */
2820 if (this_comp
->attr
.pointer
&& comp_tail
->val
2821 && gfc_is_coindexed (comp_tail
->val
))
2823 gfc_error ("Coindexed expression to pointer component %qs in "
2824 "structure constructor at %L!", comp_tail
->name
,
2829 /* If not explicitly a parent constructor, gather up the components
2831 if (comp
&& comp
== sym
->components
2832 && sym
->attr
.extension
2834 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
2836 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2839 gfc_actual_arglist
*arg_null
= NULL
;
2841 actual
->expr
= comp_tail
->val
;
2842 comp_tail
->val
= NULL
;
2844 m
= gfc_convert_to_structure_constructor (NULL
,
2845 comp
->ts
.u
.derived
, &comp_tail
->val
,
2846 comp
->ts
.u
.derived
->attr
.zero_comp
2847 ? &arg_null
: &actual
, true);
2851 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2860 if (parent
&& !comp
)
2864 actual
= actual
->next
;
2867 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2870 /* No component should be left, as this should have caused an error in the
2871 loop constructing the component-list (name that does not correspond to any
2872 component in the structure definition). */
2873 if (comp_head
&& sym
->attr
.extension
)
2875 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2877 gfc_error ("component %qs at %L has already been set by a "
2878 "parent derived type constructor", comp_iter
->name
,
2884 gcc_assert (!comp_head
);
2888 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2889 expr
->ts
.u
.derived
= sym
;
2890 expr
->value
.constructor
= ctor_head
;
2895 expr
->ts
.u
.derived
= sym
;
2897 expr
->ts
.type
= BT_DERIVED
;
2898 expr
->value
.constructor
= ctor_head
;
2899 expr
->expr_type
= EXPR_STRUCTURE
;
2902 gfc_current_locus
= old_locus
;
2908 gfc_current_locus
= old_locus
;
2910 for (comp_iter
= comp_head
; comp_iter
; )
2912 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2913 gfc_free_structure_ctor_component (comp_iter
);
2916 gfc_constructor_free (ctor_head
);
2923 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2927 gfc_symtree
*symtree
;
2929 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
2931 e
= gfc_get_expr ();
2932 e
->symtree
= symtree
;
2933 e
->expr_type
= EXPR_FUNCTION
;
2935 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
2936 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2937 e
->value
.function
.esym
= sym
;
2938 e
->symtree
->n
.sym
->attr
.generic
= 1;
2940 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2947 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
2953 /* If a structure constructor is in a DATA statement, then each entity
2954 in the structure constructor must be a constant. Try to reduce the
2956 if (gfc_in_match_data ())
2957 gfc_reduce_init_expr (e
);
2964 /* If the symbol is an implicit do loop index and implicitly typed,
2965 it should not be host associated. Provide a symtree from the
2966 current namespace. */
2968 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2970 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2971 && (*sym
)->ns
!= gfc_current_ns
2972 && (*sym
)->attr
.implied_index
2973 && (*sym
)->attr
.implicit_type
2974 && !(*sym
)->attr
.use_assoc
)
2977 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2980 *sym
= (*st
)->n
.sym
;
2986 /* Procedure pointer as function result: Replace the function symbol by the
2987 auto-generated hidden result variable named "ppr@". */
2990 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2992 /* Check for procedure pointer result variable. */
2993 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2994 && (*sym
)->result
&& (*sym
)->result
!= *sym
2995 && (*sym
)->result
->attr
.proc_pointer
2996 && (*sym
) == gfc_current_ns
->proc_name
2997 && (*sym
) == (*sym
)->result
->ns
->proc_name
2998 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3000 /* Automatic replacement with "hidden" result variable. */
3001 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3002 *sym
= (*sym
)->result
;
3003 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3010 /* Matches a variable name followed by anything that might follow it--
3011 array reference, argument list of a function, etc. */
3014 gfc_match_rvalue (gfc_expr
**result
)
3016 gfc_actual_arglist
*actual_arglist
;
3017 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3020 gfc_symtree
*symtree
;
3021 locus where
, old_loc
;
3029 m
= gfc_match ("%%loc");
3032 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3034 strncpy (name
, "loc", 4);
3039 m
= gfc_match_name (name
);
3044 /* Check if the symbol exists. */
3045 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3048 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3049 type. For derived types we create a generic symbol which links to the
3050 derived type symbol; STRUCTUREs are simpler and must not conflict with
3053 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3055 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3057 if (gfc_find_state (COMP_INTERFACE
)
3058 && !gfc_current_ns
->has_import_set
)
3059 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3061 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3067 sym
= symtree
->n
.sym
;
3069 where
= gfc_current_locus
;
3071 replace_hidden_procptr_result (&sym
, &symtree
);
3073 /* If this is an implicit do loop index and implicitly typed,
3074 it should not be host associated. */
3075 m
= check_for_implicit_index (&symtree
, &sym
);
3079 gfc_set_sym_referenced (sym
);
3080 sym
->attr
.implied_index
= 0;
3082 if (sym
->attr
.function
&& sym
->result
== sym
)
3084 /* See if this is a directly recursive function call. */
3085 gfc_gobble_whitespace ();
3086 if (sym
->attr
.recursive
3087 && gfc_peek_ascii_char () == '('
3088 && gfc_current_ns
->proc_name
== sym
3089 && !sym
->attr
.dimension
)
3091 gfc_error ("%qs at %C is the name of a recursive function "
3092 "and so refers to the result variable. Use an "
3093 "explicit RESULT variable for direct recursion "
3094 "(12.5.2.1)", sym
->name
);
3098 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3102 && (sym
->ns
== gfc_current_ns
3103 || sym
->ns
== gfc_current_ns
->parent
))
3105 gfc_entry_list
*el
= NULL
;
3107 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3113 if (gfc_matching_procptr_assignment
)
3116 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3119 if (sym
->attr
.generic
)
3120 goto generic_function
;
3122 switch (sym
->attr
.flavor
)
3126 e
= gfc_get_expr ();
3128 e
->expr_type
= EXPR_VARIABLE
;
3129 e
->symtree
= symtree
;
3131 m
= gfc_match_varspec (e
, 0, false, true);
3135 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3136 end up here. Unfortunately, sym->value->expr_type is set to
3137 EXPR_CONSTANT, and so the if () branch would be followed without
3138 the !sym->as check. */
3139 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3140 e
= gfc_copy_expr (sym
->value
);
3143 e
= gfc_get_expr ();
3144 e
->expr_type
= EXPR_VARIABLE
;
3147 e
->symtree
= symtree
;
3148 m
= gfc_match_varspec (e
, 0, false, true);
3150 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3153 /* Variable array references to derived type parameters cause
3154 all sorts of headaches in simplification. Treating such
3155 expressions as variable works just fine for all array
3157 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3159 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3160 if (ref
->type
== REF_ARRAY
)
3163 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3169 e
= gfc_get_expr ();
3170 e
->expr_type
= EXPR_VARIABLE
;
3171 e
->symtree
= symtree
;
3179 sym
= gfc_use_derived (sym
);
3183 goto generic_function
;
3186 /* If we're here, then the name is known to be the name of a
3187 procedure, yet it is not sure to be the name of a function. */
3190 /* Procedure Pointer Assignments. */
3192 if (gfc_matching_procptr_assignment
)
3194 gfc_gobble_whitespace ();
3195 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3196 /* Parse functions returning a procptr. */
3199 e
= gfc_get_expr ();
3200 e
->expr_type
= EXPR_VARIABLE
;
3201 e
->symtree
= symtree
;
3202 m
= gfc_match_varspec (e
, 0, false, true);
3203 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3204 && sym
->ts
.type
== BT_UNKNOWN
3205 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3213 if (sym
->attr
.subroutine
)
3215 gfc_error ("Unexpected use of subroutine name %qs at %C",
3221 /* At this point, the name has to be a non-statement function.
3222 If the name is the same as the current function being
3223 compiled, then we have a variable reference (to the function
3224 result) if the name is non-recursive. */
3226 st
= gfc_enclosing_unit (NULL
);
3229 && st
->state
== COMP_FUNCTION
3231 && !sym
->attr
.recursive
)
3233 e
= gfc_get_expr ();
3234 e
->symtree
= symtree
;
3235 e
->expr_type
= EXPR_VARIABLE
;
3237 m
= gfc_match_varspec (e
, 0, false, true);
3241 /* Match a function reference. */
3243 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3246 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3247 gfc_error ("Statement function %qs requires argument list at %C",
3250 gfc_error ("Function %qs requires an argument list at %C",
3263 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3264 sym
= symtree
->n
.sym
;
3266 replace_hidden_procptr_result (&sym
, &symtree
);
3268 e
= gfc_get_expr ();
3269 e
->symtree
= symtree
;
3270 e
->expr_type
= EXPR_FUNCTION
;
3271 e
->value
.function
.actual
= actual_arglist
;
3272 e
->where
= gfc_current_locus
;
3274 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3275 && CLASS_DATA (sym
)->as
)
3276 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3277 else if (sym
->as
!= NULL
)
3278 e
->rank
= sym
->as
->rank
;
3280 if (!sym
->attr
.function
3281 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3287 /* Check here for the existence of at least one argument for the
3288 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3289 argument(s) given will be checked in gfc_iso_c_func_interface,
3290 during resolution of the function call. */
3291 if (sym
->attr
.is_iso_c
== 1
3292 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3293 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3294 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3295 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3297 /* make sure we were given a param */
3298 if (actual_arglist
== NULL
)
3300 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3306 if (sym
->result
== NULL
)
3309 gfc_gobble_whitespace ();
3311 if (gfc_peek_ascii_char() == '%')
3313 gfc_error ("The leftmost part-ref in a data-ref can not be a "
3314 "function reference at %C");
3323 /* Special case for derived type variables that get their types
3324 via an IMPLICIT statement. This can't wait for the
3325 resolution phase. */
3327 old_loc
= gfc_current_locus
;
3328 if (gfc_match_member_sep (sym
) == MATCH_YES
3329 && sym
->ts
.type
== BT_UNKNOWN
3330 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3331 gfc_set_default_type (sym
, 0, sym
->ns
);
3332 gfc_current_locus
= old_loc
;
3334 /* If the symbol has a (co)dimension attribute, the expression is a
3337 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3339 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3345 e
= gfc_get_expr ();
3346 e
->symtree
= symtree
;
3347 e
->expr_type
= EXPR_VARIABLE
;
3348 m
= gfc_match_varspec (e
, 0, false, true);
3352 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3353 && (CLASS_DATA (sym
)->attr
.dimension
3354 || CLASS_DATA (sym
)->attr
.codimension
))
3356 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3362 e
= gfc_get_expr ();
3363 e
->symtree
= symtree
;
3364 e
->expr_type
= EXPR_VARIABLE
;
3365 m
= gfc_match_varspec (e
, 0, false, true);
3369 /* Name is not an array, so we peek to see if a '(' implies a
3370 function call or a substring reference. Otherwise the
3371 variable is just a scalar. */
3373 gfc_gobble_whitespace ();
3374 if (gfc_peek_ascii_char () != '(')
3376 /* Assume a scalar variable */
3377 e
= gfc_get_expr ();
3378 e
->symtree
= symtree
;
3379 e
->expr_type
= EXPR_VARIABLE
;
3381 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3387 /*FIXME:??? gfc_match_varspec does set this for us: */
3389 m
= gfc_match_varspec (e
, 0, false, true);
3393 /* See if this is a function reference with a keyword argument
3394 as first argument. We do this because otherwise a spurious
3395 symbol would end up in the symbol table. */
3397 old_loc
= gfc_current_locus
;
3398 m2
= gfc_match (" ( %n =", argname
);
3399 gfc_current_locus
= old_loc
;
3401 e
= gfc_get_expr ();
3402 e
->symtree
= symtree
;
3404 if (m2
!= MATCH_YES
)
3406 /* Try to figure out whether we're dealing with a character type.
3407 We're peeking ahead here, because we don't want to call
3408 match_substring if we're dealing with an implicitly typed
3409 non-character variable. */
3410 implicit_char
= false;
3411 if (sym
->ts
.type
== BT_UNKNOWN
)
3413 ts
= gfc_get_default_type (sym
->name
, NULL
);
3414 if (ts
->type
== BT_CHARACTER
)
3415 implicit_char
= true;
3418 /* See if this could possibly be a substring reference of a name
3419 that we're not sure is a variable yet. */
3421 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3422 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3425 e
->expr_type
= EXPR_VARIABLE
;
3427 if (sym
->attr
.flavor
!= FL_VARIABLE
3428 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3435 if (sym
->ts
.type
== BT_UNKNOWN
3436 && !gfc_set_default_type (sym
, 1, NULL
))
3450 /* Give up, assume we have a function. */
3452 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3453 sym
= symtree
->n
.sym
;
3454 e
->expr_type
= EXPR_FUNCTION
;
3456 if (!sym
->attr
.function
3457 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3465 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3467 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3475 /* If our new function returns a character, array or structure
3476 type, it might have subsequent references. */
3478 m
= gfc_match_varspec (e
, 0, false, true);
3485 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3486 specially. Creates a generic symbol for derived types. */
3487 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3489 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3490 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3491 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3493 e
= gfc_get_expr ();
3494 e
->symtree
= symtree
;
3495 e
->expr_type
= EXPR_FUNCTION
;
3497 if (gfc_fl_struct (sym
->attr
.flavor
))
3499 e
->value
.function
.esym
= sym
;
3500 e
->symtree
->n
.sym
->attr
.generic
= 1;
3503 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3511 gfc_error ("Symbol at %C is not appropriate for an expression");
3527 /* Match a variable, i.e. something that can be assigned to. This
3528 starts as a symbol, can be a structure component or an array
3529 reference. It can be a function if the function doesn't have a
3530 separate RESULT variable. If the symbol has not been previously
3531 seen, we assume it is a variable.
3533 This function is called by two interface functions:
3534 gfc_match_variable, which has host_flag = 1, and
3535 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3536 match of the symbol to the local scope. */
3539 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3541 gfc_symbol
*sym
, *dt_sym
;
3544 locus where
, old_loc
;
3547 /* Since nothing has any business being an lvalue in a module
3548 specification block, an interface block or a contains section,
3549 we force the changed_symbols mechanism to work by setting
3550 host_flag to 0. This prevents valid symbols that have the name
3551 of keywords, such as 'end', being turned into variables by
3552 failed matching to assignments for, e.g., END INTERFACE. */
3553 if (gfc_current_state () == COMP_MODULE
3554 || gfc_current_state () == COMP_SUBMODULE
3555 || gfc_current_state () == COMP_INTERFACE
3556 || gfc_current_state () == COMP_CONTAINS
)
3559 where
= gfc_current_locus
;
3560 m
= gfc_match_sym_tree (&st
, host_flag
);
3566 /* If this is an implicit do loop index and implicitly typed,
3567 it should not be host associated. */
3568 m
= check_for_implicit_index (&st
, &sym
);
3572 sym
->attr
.implied_index
= 0;
3574 gfc_set_sym_referenced (sym
);
3576 /* STRUCTUREs may share names with variables, but derived types may not. */
3577 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3578 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3580 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3581 gfc_error ("Derived type '%s' cannot be used as a variable at %C",
3586 switch (sym
->attr
.flavor
)
3589 /* Everything is alright. */
3594 sym_flavor flavor
= FL_UNKNOWN
;
3596 gfc_gobble_whitespace ();
3598 if (sym
->attr
.external
|| sym
->attr
.procedure
3599 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3600 flavor
= FL_PROCEDURE
;
3602 /* If it is not a procedure, is not typed and is host associated,
3603 we cannot give it a flavor yet. */
3604 else if (sym
->ns
== gfc_current_ns
->parent
3605 && sym
->ts
.type
== BT_UNKNOWN
)
3608 /* These are definitive indicators that this is a variable. */
3609 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3610 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3611 flavor
= FL_VARIABLE
;
3613 if (flavor
!= FL_UNKNOWN
3614 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3622 gfc_error ("Named constant at %C in an EQUIVALENCE");
3625 /* Otherwise this is checked for and an error given in the
3626 variable definition context checks. */
3630 /* Check for a nonrecursive function result variable. */
3631 if (sym
->attr
.function
3632 && !sym
->attr
.external
3633 && sym
->result
== sym
3634 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3636 && sym
->ns
== gfc_current_ns
)
3638 && sym
->ns
== gfc_current_ns
->parent
)))
3640 /* If a function result is a derived type, then the derived
3641 type may still have to be resolved. */
3643 if (sym
->ts
.type
== BT_DERIVED
3644 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3649 if (sym
->attr
.proc_pointer
3650 || replace_hidden_procptr_result (&sym
, &st
))
3653 /* Fall through to error */
3657 gfc_error ("%qs at %C is not a variable", sym
->name
);
3661 /* Special case for derived type variables that get their types
3662 via an IMPLICIT statement. This can't wait for the
3663 resolution phase. */
3666 gfc_namespace
* implicit_ns
;
3668 if (gfc_current_ns
->proc_name
== sym
)
3669 implicit_ns
= gfc_current_ns
;
3671 implicit_ns
= sym
->ns
;
3673 old_loc
= gfc_current_locus
;
3674 if (gfc_match_member_sep (sym
) == MATCH_YES
3675 && sym
->ts
.type
== BT_UNKNOWN
3676 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3677 gfc_set_default_type (sym
, 0, implicit_ns
);
3678 gfc_current_locus
= old_loc
;
3681 expr
= gfc_get_expr ();
3683 expr
->expr_type
= EXPR_VARIABLE
;
3686 expr
->where
= where
;
3688 /* Now see if we have to do more. */
3689 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3692 gfc_free_expr (expr
);
3702 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3704 return match_variable (result
, equiv_flag
, 1);
3709 gfc_match_equiv_variable (gfc_expr
**result
)
3711 return match_variable (result
, 1, 0);