1 /* Primary expression subroutines
2 Copyright (C) 2000-2015 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
;
487 locus old_loc
, temp_loc
;
488 char *p
, *buffer
, c
, exp_char
;
492 old_loc
= gfc_current_locus
;
493 gfc_gobble_whitespace ();
503 c
= gfc_next_ascii_char ();
504 if (signflag
&& (c
== '+' || c
== '-'))
509 gfc_gobble_whitespace ();
510 c
= gfc_next_ascii_char ();
513 /* Scan significand. */
514 for (;; c
= gfc_next_ascii_char (), count
++)
521 /* Check to see if "." goes with a following operator like
523 temp_loc
= gfc_current_locus
;
524 c
= gfc_next_ascii_char ();
526 if (c
== 'e' || c
== 'd' || c
== 'q')
528 c
= gfc_next_ascii_char ();
530 goto done
; /* Operator named .e. or .d. */
534 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
536 gfc_current_locus
= temp_loc
;
550 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
557 if (!gfc_notify_std (GFC_STD_GNU
, "exponent-letter 'q' in "
558 "real-literal-constant at %C"))
560 else if (warn_real_q_constant
)
561 gfc_warning (OPT_Wreal_q_constant
,
562 "Extension: exponent-letter %<q%> in real-literal-constant "
567 c
= gfc_next_ascii_char ();
570 if (c
== '+' || c
== '-')
571 { /* optional sign */
572 c
= gfc_next_ascii_char ();
578 gfc_error ("Missing exponent in real number at %C");
584 c
= gfc_next_ascii_char ();
589 /* Check that we have a numeric constant. */
590 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
592 gfc_current_locus
= old_loc
;
596 /* Convert the number. */
597 gfc_current_locus
= old_loc
;
598 gfc_gobble_whitespace ();
600 buffer
= (char *) alloca (count
+ 1);
601 memset (buffer
, '\0', count
+ 1);
604 c
= gfc_next_ascii_char ();
605 if (c
== '+' || c
== '-')
607 gfc_gobble_whitespace ();
608 c
= gfc_next_ascii_char ();
611 /* Hack for mpfr_set_str(). */
614 if (c
== 'd' || c
== 'q')
622 c
= gfc_next_ascii_char ();
625 kind
= get_kind (&is_iso_c
);
634 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
638 kind
= gfc_default_double_kind
;
642 if (flag_real4_kind
== 8)
644 if (flag_real4_kind
== 10)
646 if (flag_real4_kind
== 16)
652 if (flag_real8_kind
== 4)
654 if (flag_real8_kind
== 10)
656 if (flag_real8_kind
== 16)
664 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
669 /* The maximum possible real kind type parameter is 16. First, try
670 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
671 extended precision. If neither value works, just given up. */
673 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
676 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
678 gfc_error ("Invalid exponent-letter %<q%> in "
679 "real-literal-constant at %C");
687 kind
= gfc_default_real_kind
;
691 if (flag_real4_kind
== 8)
693 if (flag_real4_kind
== 10)
695 if (flag_real4_kind
== 16)
701 if (flag_real8_kind
== 4)
703 if (flag_real8_kind
== 10)
705 if (flag_real8_kind
== 16)
709 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
711 gfc_error ("Invalid real kind %d at %C", kind
);
716 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
718 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
719 e
->ts
.is_c_interop
= is_iso_c
;
721 switch (gfc_range_check (e
))
726 gfc_error ("Real constant overflows its kind at %C");
729 case ARITH_UNDERFLOW
:
731 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
732 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
736 gfc_internal_error ("gfc_range_check() returned bad value");
739 /* Warn about trailing digits which suggest the user added too many
740 trailing digits, which may cause the appearance of higher pecision
741 than the kind kan support.
743 This is done by replacing the rightmost non-zero digit with zero
744 and comparing with the original value. If these are equal, we
745 assume the user supplied more digits than intended (or forgot to
746 convert to the correct kind).
749 if (warn_conversion_extra
)
755 c
= strchr (buffer
, 'e');
757 c
= buffer
+ strlen(buffer
);
760 for (p
= c
- 1; p
>= buffer
; p
--)
776 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
778 mpfr_neg (r
, r
, GFC_RND_MODE
);
780 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
782 if (mpfr_cmp_ui (r
, 0) == 0)
783 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
784 "in %qs number at %C, maybe incorrect KIND",
785 gfc_typename (&e
->ts
));
800 /* Match a substring reference. */
803 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
805 gfc_expr
*start
, *end
;
813 old_loc
= gfc_current_locus
;
815 m
= gfc_match_char ('(');
819 if (gfc_match_char (':') != MATCH_YES
)
822 m
= gfc_match_init_expr (&start
);
824 m
= gfc_match_expr (&start
);
832 m
= gfc_match_char (':');
837 if (gfc_match_char (')') != MATCH_YES
)
840 m
= gfc_match_init_expr (&end
);
842 m
= gfc_match_expr (&end
);
846 if (m
== MATCH_ERROR
)
849 m
= gfc_match_char (')');
854 /* Optimize away the (:) reference. */
855 if (start
== NULL
&& end
== NULL
)
859 ref
= gfc_get_ref ();
861 ref
->type
= REF_SUBSTRING
;
863 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
864 ref
->u
.ss
.start
= start
;
865 if (end
== NULL
&& cl
)
866 end
= gfc_copy_expr (cl
->length
);
868 ref
->u
.ss
.length
= cl
;
875 gfc_error ("Syntax error in SUBSTRING specification at %C");
879 gfc_free_expr (start
);
882 gfc_current_locus
= old_loc
;
887 /* Reads the next character of a string constant, taking care to
888 return doubled delimiters on the input as a single instance of
891 Special return values for "ret" argument are:
892 -1 End of the string, as determined by the delimiter
893 -2 Unterminated string detected
895 Backslash codes are also expanded at this time. */
898 next_string_char (gfc_char_t delimiter
, int *ret
)
903 c
= gfc_next_char_literal (INSTRING_WARN
);
912 if (flag_backslash
&& c
== '\\')
914 old_locus
= gfc_current_locus
;
916 if (gfc_match_special_char (&c
) == MATCH_NO
)
917 gfc_current_locus
= old_locus
;
919 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
920 gfc_warning (0, "Extension: backslash character at %C");
926 old_locus
= gfc_current_locus
;
927 c
= gfc_next_char_literal (NONSTRING
);
931 gfc_current_locus
= old_locus
;
938 /* Special case of gfc_match_name() that matches a parameter kind name
939 before a string constant. This takes case of the weird but legal
944 where kind____ is a parameter. gfc_match_name() will happily slurp
945 up all the underscores, which leads to problems. If we return
946 MATCH_YES, the parse pointer points to the final underscore, which
947 is not part of the name. We never return MATCH_ERROR-- errors in
948 the name will be detected later. */
951 match_charkind_name (char *name
)
957 gfc_gobble_whitespace ();
958 c
= gfc_next_ascii_char ();
967 old_loc
= gfc_current_locus
;
968 c
= gfc_next_ascii_char ();
972 peek
= gfc_peek_ascii_char ();
974 if (peek
== '\'' || peek
== '\"')
976 gfc_current_locus
= old_loc
;
984 && (c
!= '$' || !flag_dollar_ok
))
988 if (++len
> GFC_MAX_SYMBOL_LEN
)
996 /* See if the current input matches a character constant. Lots of
997 contortions have to be done to match the kind parameter which comes
998 before the actual string. The main consideration is that we don't
999 want to error out too quickly. For example, we don't actually do
1000 any validation of the kinds until we have actually seen a legal
1001 delimiter. Using match_kind_param() generates errors too quickly. */
1004 match_string_constant (gfc_expr
**result
)
1006 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1007 int i
, kind
, length
, save_warn_ampersand
, ret
;
1008 locus old_locus
, start_locus
;
1013 gfc_char_t c
, delimiter
, *p
;
1015 old_locus
= gfc_current_locus
;
1017 gfc_gobble_whitespace ();
1019 c
= gfc_next_char ();
1020 if (c
== '\'' || c
== '"')
1022 kind
= gfc_default_character_kind
;
1023 start_locus
= gfc_current_locus
;
1027 if (gfc_wide_is_digit (c
))
1031 while (gfc_wide_is_digit (c
))
1033 kind
= kind
* 10 + c
- '0';
1036 c
= gfc_next_char ();
1042 gfc_current_locus
= old_locus
;
1044 m
= match_charkind_name (name
);
1048 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1050 || sym
->attr
.flavor
!= FL_PARAMETER
)
1054 c
= gfc_next_char ();
1059 gfc_gobble_whitespace ();
1060 c
= gfc_next_char ();
1066 gfc_gobble_whitespace ();
1068 c
= gfc_next_char ();
1069 if (c
!= '\'' && c
!= '"')
1072 start_locus
= gfc_current_locus
;
1076 q
= gfc_extract_int (sym
->value
, &kind
);
1082 gfc_set_sym_referenced (sym
);
1085 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1087 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1092 /* Scan the string into a block of memory by first figuring out how
1093 long it is, allocating the structure, then re-reading it. This
1094 isn't particularly efficient, but string constants aren't that
1095 common in most code. TODO: Use obstacks? */
1102 c
= next_string_char (delimiter
, &ret
);
1107 gfc_current_locus
= start_locus
;
1108 gfc_error ("Unterminated character constant beginning at %C");
1115 /* Peek at the next character to see if it is a b, o, z, or x for the
1116 postfixed BOZ literal constants. */
1117 peek
= gfc_peek_ascii_char ();
1118 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1121 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1123 gfc_current_locus
= start_locus
;
1125 /* We disable the warning for the following loop as the warning has already
1126 been printed in the loop above. */
1127 save_warn_ampersand
= warn_ampersand
;
1128 warn_ampersand
= false;
1130 p
= e
->value
.character
.string
;
1131 for (i
= 0; i
< length
; i
++)
1133 c
= next_string_char (delimiter
, &ret
);
1135 if (!gfc_check_character_range (c
, kind
))
1138 gfc_error ("Character %qs in string at %C is not representable "
1139 "in character kind %d", gfc_print_wide_char (c
), kind
);
1146 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1147 warn_ampersand
= save_warn_ampersand
;
1149 next_string_char (delimiter
, &ret
);
1151 gfc_internal_error ("match_string_constant(): Delimiter not found");
1153 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1154 e
->expr_type
= EXPR_SUBSTRING
;
1161 gfc_current_locus
= old_locus
;
1166 /* Match a .true. or .false. Returns 1 if a .true. was found,
1167 0 if a .false. was found, and -1 otherwise. */
1169 match_logical_constant_string (void)
1171 locus orig_loc
= gfc_current_locus
;
1173 gfc_gobble_whitespace ();
1174 if (gfc_next_ascii_char () == '.')
1176 char ch
= gfc_next_ascii_char ();
1179 if (gfc_next_ascii_char () == 'a'
1180 && gfc_next_ascii_char () == 'l'
1181 && gfc_next_ascii_char () == 's'
1182 && gfc_next_ascii_char () == 'e'
1183 && gfc_next_ascii_char () == '.')
1184 /* Matched ".false.". */
1189 if (gfc_next_ascii_char () == 'r'
1190 && gfc_next_ascii_char () == 'u'
1191 && gfc_next_ascii_char () == 'e'
1192 && gfc_next_ascii_char () == '.')
1193 /* Matched ".true.". */
1197 gfc_current_locus
= orig_loc
;
1201 /* Match a .true. or .false. */
1204 match_logical_constant (gfc_expr
**result
)
1207 int i
, kind
, is_iso_c
;
1209 i
= match_logical_constant_string ();
1213 kind
= get_kind (&is_iso_c
);
1217 kind
= gfc_default_logical_kind
;
1219 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1221 gfc_error ("Bad kind for logical constant at %C");
1225 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1226 e
->ts
.is_c_interop
= is_iso_c
;
1233 /* Match a real or imaginary part of a complex constant that is a
1234 symbolic constant. */
1237 match_sym_complex_part (gfc_expr
**result
)
1239 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1244 m
= gfc_match_name (name
);
1248 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1251 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1253 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1257 if (!gfc_numeric_ts (&sym
->value
->ts
))
1259 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1263 if (sym
->value
->rank
!= 0)
1265 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1269 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1270 "complex constant at %C"))
1273 switch (sym
->value
->ts
.type
)
1276 e
= gfc_copy_expr (sym
->value
);
1280 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1286 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1292 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1295 *result
= e
; /* e is a scalar, real, constant expression. */
1299 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1304 /* Match a real or imaginary part of a complex number. */
1307 match_complex_part (gfc_expr
**result
)
1311 m
= match_sym_complex_part (result
);
1315 m
= match_real_constant (result
, 1);
1319 return match_integer_constant (result
, 1);
1323 /* Try to match a complex constant. */
1326 match_complex_constant (gfc_expr
**result
)
1328 gfc_expr
*e
, *real
, *imag
;
1329 gfc_error_buffer old_error
;
1330 gfc_typespec target
;
1335 old_loc
= gfc_current_locus
;
1336 real
= imag
= e
= NULL
;
1338 m
= gfc_match_char ('(');
1342 gfc_push_error (&old_error
);
1344 m
= match_complex_part (&real
);
1347 gfc_free_error (&old_error
);
1351 if (gfc_match_char (',') == MATCH_NO
)
1353 gfc_pop_error (&old_error
);
1358 /* If m is error, then something was wrong with the real part and we
1359 assume we have a complex constant because we've seen the ','. An
1360 ambiguous case here is the start of an iterator list of some
1361 sort. These sort of lists are matched prior to coming here. */
1363 if (m
== MATCH_ERROR
)
1365 gfc_free_error (&old_error
);
1368 gfc_pop_error (&old_error
);
1370 m
= match_complex_part (&imag
);
1373 if (m
== MATCH_ERROR
)
1376 m
= gfc_match_char (')');
1379 /* Give the matcher for implied do-loops a chance to run. This
1380 yields a much saner error message for (/ (i, 4=i, 6) /). */
1381 if (gfc_peek_ascii_char () == '=')
1390 if (m
== MATCH_ERROR
)
1393 /* Decide on the kind of this complex number. */
1394 if (real
->ts
.type
== BT_REAL
)
1396 if (imag
->ts
.type
== BT_REAL
)
1397 kind
= gfc_kind_max (real
, imag
);
1399 kind
= real
->ts
.kind
;
1403 if (imag
->ts
.type
== BT_REAL
)
1404 kind
= imag
->ts
.kind
;
1406 kind
= gfc_default_real_kind
;
1408 gfc_clear_ts (&target
);
1409 target
.type
= BT_REAL
;
1412 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1413 gfc_convert_type (real
, &target
, 2);
1414 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1415 gfc_convert_type (imag
, &target
, 2);
1417 e
= gfc_convert_complex (real
, imag
, kind
);
1418 e
->where
= gfc_current_locus
;
1420 gfc_free_expr (real
);
1421 gfc_free_expr (imag
);
1427 gfc_error ("Syntax error in COMPLEX constant at %C");
1432 gfc_free_expr (real
);
1433 gfc_free_expr (imag
);
1434 gfc_current_locus
= old_loc
;
1440 /* Match constants in any of several forms. Returns nonzero for a
1441 match, zero for no match. */
1444 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1448 m
= match_complex_constant (result
);
1452 m
= match_string_constant (result
);
1456 m
= match_boz_constant (result
);
1460 m
= match_real_constant (result
, signflag
);
1464 m
= match_hollerith_constant (result
);
1468 m
= match_integer_constant (result
, signflag
);
1472 m
= match_logical_constant (result
);
1480 /* This checks if a symbol is the return value of an encompassing function.
1481 Function nesting can be maximally two levels deep, but we may have
1482 additional local namespaces like BLOCK etc. */
1485 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1487 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1491 if (ns
->proc_name
== sym
)
1499 /* Match a single actual argument value. An actual argument is
1500 usually an expression, but can also be a procedure name. If the
1501 argument is a single name, it is not always possible to tell
1502 whether the name is a dummy procedure or not. We treat these cases
1503 by creating an argument that looks like a dummy procedure and
1504 fixing things later during resolution. */
1507 match_actual_arg (gfc_expr
**result
)
1509 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1510 gfc_symtree
*symtree
;
1515 gfc_gobble_whitespace ();
1516 where
= gfc_current_locus
;
1518 switch (gfc_match_name (name
))
1527 w
= gfc_current_locus
;
1528 gfc_gobble_whitespace ();
1529 c
= gfc_next_ascii_char ();
1530 gfc_current_locus
= w
;
1532 if (c
!= ',' && c
!= ')')
1535 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1537 /* Handle error elsewhere. */
1539 /* Eliminate a couple of common cases where we know we don't
1540 have a function argument. */
1541 if (symtree
== NULL
)
1543 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1544 gfc_set_sym_referenced (symtree
->n
.sym
);
1550 sym
= symtree
->n
.sym
;
1551 gfc_set_sym_referenced (sym
);
1552 if (sym
->attr
.flavor
!= FL_PROCEDURE
1553 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1556 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1558 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1559 sym
->name
, &sym
->declared_at
))
1564 /* If the symbol is a function with itself as the result and
1565 is being defined, then we have a variable. */
1566 if (sym
->attr
.function
&& sym
->result
== sym
)
1568 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1572 && (sym
->ns
== gfc_current_ns
1573 || sym
->ns
== gfc_current_ns
->parent
))
1575 gfc_entry_list
*el
= NULL
;
1577 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1587 e
= gfc_get_expr (); /* Leave it unknown for now */
1588 e
->symtree
= symtree
;
1589 e
->expr_type
= EXPR_VARIABLE
;
1590 e
->ts
.type
= BT_PROCEDURE
;
1597 gfc_current_locus
= where
;
1598 return gfc_match_expr (result
);
1602 /* Match a keyword argument. */
1605 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1607 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1608 gfc_actual_arglist
*a
;
1612 name_locus
= gfc_current_locus
;
1613 m
= gfc_match_name (name
);
1617 if (gfc_match_char ('=') != MATCH_YES
)
1623 m
= match_actual_arg (&actual
->expr
);
1627 /* Make sure this name has not appeared yet. */
1629 if (name
[0] != '\0')
1631 for (a
= base
; a
; a
= a
->next
)
1632 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1634 gfc_error ("Keyword %qs at %C has already appeared in the "
1635 "current argument list", name
);
1640 actual
->name
= gfc_get_string (name
);
1644 gfc_current_locus
= name_locus
;
1649 /* Match an argument list function, such as %VAL. */
1652 match_arg_list_function (gfc_actual_arglist
*result
)
1654 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1658 old_locus
= gfc_current_locus
;
1660 if (gfc_match_char ('%') != MATCH_YES
)
1666 m
= gfc_match ("%n (", name
);
1670 if (name
[0] != '\0')
1675 if (strncmp (name
, "loc", 3) == 0)
1677 result
->name
= "%LOC";
1681 if (strncmp (name
, "ref", 3) == 0)
1683 result
->name
= "%REF";
1687 if (strncmp (name
, "val", 3) == 0)
1689 result
->name
= "%VAL";
1698 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1704 m
= match_actual_arg (&result
->expr
);
1708 if (gfc_match_char (')') != MATCH_YES
)
1717 gfc_current_locus
= old_locus
;
1722 /* Matches an actual argument list of a function or subroutine, from
1723 the opening parenthesis to the closing parenthesis. The argument
1724 list is assumed to allow keyword arguments because we don't know if
1725 the symbol associated with the procedure has an implicit interface
1726 or not. We make sure keywords are unique. If sub_flag is set,
1727 we're matching the argument list of a subroutine. */
1730 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1732 gfc_actual_arglist
*head
, *tail
;
1734 gfc_st_label
*label
;
1738 *argp
= tail
= NULL
;
1739 old_loc
= gfc_current_locus
;
1743 if (gfc_match_char ('(') == MATCH_NO
)
1744 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1746 if (gfc_match_char (')') == MATCH_YES
)
1750 matching_actual_arglist
++;
1755 head
= tail
= gfc_get_actual_arglist ();
1758 tail
->next
= gfc_get_actual_arglist ();
1762 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1764 m
= gfc_match_st_label (&label
);
1766 gfc_error ("Expected alternate return label at %C");
1770 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1774 tail
->label
= label
;
1778 /* After the first keyword argument is seen, the following
1779 arguments must also have keywords. */
1782 m
= match_keyword_arg (tail
, head
);
1784 if (m
== MATCH_ERROR
)
1788 gfc_error ("Missing keyword name in actual argument list at %C");
1795 /* Try an argument list function, like %VAL. */
1796 m
= match_arg_list_function (tail
);
1797 if (m
== MATCH_ERROR
)
1800 /* See if we have the first keyword argument. */
1803 m
= match_keyword_arg (tail
, head
);
1806 if (m
== MATCH_ERROR
)
1812 /* Try for a non-keyword argument. */
1813 m
= match_actual_arg (&tail
->expr
);
1814 if (m
== MATCH_ERROR
)
1823 if (gfc_match_char (')') == MATCH_YES
)
1825 if (gfc_match_char (',') != MATCH_YES
)
1830 matching_actual_arglist
--;
1834 gfc_error ("Syntax error in argument list at %C");
1837 gfc_free_actual_arglist (head
);
1838 gfc_current_locus
= old_loc
;
1839 matching_actual_arglist
--;
1844 /* Used by gfc_match_varspec() to extend the reference list by one
1848 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1850 if (primary
->ref
== NULL
)
1851 primary
->ref
= tail
= gfc_get_ref ();
1855 gfc_internal_error ("extend_ref(): Bad tail");
1856 tail
->next
= gfc_get_ref ();
1864 /* Match any additional specifications associated with the current
1865 variable like member references or substrings. If equiv_flag is
1866 set we only match stuff that is allowed inside an EQUIVALENCE
1867 statement. sub_flag tells whether we expect a type-bound procedure found
1868 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1869 components, 'ppc_arg' determines whether the PPC may be called (with an
1870 argument list), or whether it may just be referred to as a pointer. */
1873 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1876 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1877 gfc_ref
*substring
, *tail
;
1878 gfc_component
*component
;
1879 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1885 gfc_gobble_whitespace ();
1887 if (gfc_peek_ascii_char () == '[')
1889 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1890 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1891 && CLASS_DATA (sym
)->attr
.dimension
))
1893 gfc_error ("Array section designator, e.g. '(:)', is required "
1894 "besides the coarray designator '[...]' at %C");
1897 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1898 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1899 && !CLASS_DATA (sym
)->attr
.codimension
))
1901 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1907 /* For associate names, we may not yet know whether they are arrays or not.
1908 Thus if we have one and parentheses follow, we have to assume that it
1909 actually is one for now. The final decision will be made at
1910 resolution time, of course. */
1911 if (sym
->assoc
&& gfc_peek_ascii_char () == '('
1912 && !(sym
->assoc
->dangling
&& sym
->assoc
->st
1913 && sym
->assoc
->st
->n
.sym
1914 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0)
1915 && sym
->ts
.type
!= BT_CLASS
)
1916 sym
->attr
.dimension
= 1;
1918 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1919 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1920 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1921 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1922 && !(gfc_matching_procptr_assignment
1923 && sym
->attr
.flavor
== FL_PROCEDURE
))
1924 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1925 && (CLASS_DATA (sym
)->attr
.dimension
1926 || CLASS_DATA (sym
)->attr
.codimension
)))
1930 tail
= extend_ref (primary
, tail
);
1931 tail
->type
= REF_ARRAY
;
1933 /* In EQUIVALENCE, we don't know yet whether we are seeing
1934 an array, character variable or array of character
1935 variables. We'll leave the decision till resolve time. */
1939 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1940 as
= CLASS_DATA (sym
)->as
;
1944 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1945 as
? as
->corank
: 0);
1949 gfc_gobble_whitespace ();
1950 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1952 tail
= extend_ref (primary
, tail
);
1953 tail
->type
= REF_ARRAY
;
1955 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1961 primary
->ts
= sym
->ts
;
1966 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1967 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1968 gfc_set_default_type (sym
, 0, sym
->ns
);
1970 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_match_char ('%') == MATCH_YES
)
1972 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
1975 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1976 && gfc_match_char ('%') == MATCH_YES
)
1978 gfc_error ("Unexpected %<%%%> for nonderived-type variable %qs at %C",
1983 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1984 || gfc_match_char ('%') != MATCH_YES
)
1985 goto check_substring
;
1987 sym
= sym
->ts
.u
.derived
;
1994 m
= gfc_match_name (name
);
1996 gfc_error ("Expected structure component name at %C");
2000 if (sym
->f2k_derived
)
2001 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2007 gfc_symbol
* tbp_sym
;
2012 gcc_assert (!tail
|| !tail
->next
);
2014 if (!(primary
->expr_type
== EXPR_VARIABLE
2015 || (primary
->expr_type
== EXPR_STRUCTURE
2016 && primary
->symtree
&& primary
->symtree
->n
.sym
2017 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2020 if (tbp
->n
.tb
->is_generic
)
2023 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2025 primary
->expr_type
= EXPR_COMPCALL
;
2026 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2027 primary
->value
.compcall
.name
= tbp
->name
;
2028 primary
->value
.compcall
.ignore_pass
= 0;
2029 primary
->value
.compcall
.assign
= 0;
2030 primary
->value
.compcall
.base_object
= NULL
;
2031 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2033 primary
->ts
= tbp_sym
->ts
;
2035 gfc_clear_ts (&primary
->ts
);
2037 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2038 &primary
->value
.compcall
.actual
);
2039 if (m
== MATCH_ERROR
)
2044 primary
->value
.compcall
.actual
= NULL
;
2047 gfc_error ("Expected argument list at %C");
2055 component
= gfc_find_component (sym
, name
, false, false);
2056 if (component
== NULL
)
2059 tail
= extend_ref (primary
, tail
);
2060 tail
->type
= REF_COMPONENT
;
2062 tail
->u
.c
.component
= component
;
2063 tail
->u
.c
.sym
= sym
;
2065 primary
->ts
= component
->ts
;
2067 if (component
->attr
.proc_pointer
&& ppc_arg
)
2069 /* Procedure pointer component call: Look for argument list. */
2070 m
= gfc_match_actual_arglist (sub_flag
,
2071 &primary
->value
.compcall
.actual
);
2072 if (m
== MATCH_ERROR
)
2075 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2076 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2078 gfc_error ("Procedure pointer component %qs requires an "
2079 "argument list at %C", component
->name
);
2084 primary
->expr_type
= EXPR_PPC
;
2089 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2091 tail
= extend_ref (primary
, tail
);
2092 tail
->type
= REF_ARRAY
;
2094 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2095 component
->as
->corank
);
2099 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2100 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2102 tail
= extend_ref (primary
, tail
);
2103 tail
->type
= REF_ARRAY
;
2105 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2107 CLASS_DATA (component
)->as
->corank
);
2112 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2113 || gfc_match_char ('%') != MATCH_YES
)
2116 sym
= component
->ts
.u
.derived
;
2121 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
2123 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2125 gfc_set_default_type (sym
, 0, sym
->ns
);
2126 primary
->ts
= sym
->ts
;
2131 if (primary
->ts
.type
== BT_CHARACTER
)
2133 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
2137 primary
->ref
= substring
;
2139 tail
->next
= substring
;
2141 if (primary
->expr_type
== EXPR_CONSTANT
)
2142 primary
->expr_type
= EXPR_SUBSTRING
;
2145 primary
->ts
.u
.cl
= NULL
;
2152 gfc_clear_ts (&primary
->ts
);
2153 gfc_clear_ts (&sym
->ts
);
2163 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2165 gfc_error ("Coindexed procedure-pointer component at %C");
2173 /* Given an expression that is a variable, figure out what the
2174 ultimate variable's type and attribute is, traversing the reference
2175 structures if necessary.
2177 This subroutine is trickier than it looks. We start at the base
2178 symbol and store the attribute. Component references load a
2179 completely new attribute.
2181 A couple of rules come into play. Subobjects of targets are always
2182 targets themselves. If we see a component that goes through a
2183 pointer, then the expression must also be a target, since the
2184 pointer is associated with something (if it isn't core will soon be
2185 dumped). If we see a full part or section of an array, the
2186 expression is also an array.
2188 We can have at most one full array reference. */
2191 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2193 int dimension
, codimension
, pointer
, allocatable
, target
, n
;
2194 symbol_attribute attr
;
2197 gfc_component
*comp
;
2199 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2200 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2202 sym
= expr
->symtree
->n
.sym
;
2205 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2207 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2208 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2209 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2210 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2214 dimension
= attr
.dimension
;
2215 codimension
= attr
.codimension
;
2216 pointer
= attr
.pointer
;
2217 allocatable
= attr
.allocatable
;
2220 target
= attr
.target
;
2221 if (pointer
|| attr
.proc_pointer
)
2224 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2227 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2232 switch (ref
->u
.ar
.type
)
2239 allocatable
= pointer
= 0;
2244 /* Handle coarrays. */
2245 if (ref
->u
.ar
.dimen
> 0)
2246 allocatable
= pointer
= 0;
2250 /* If any of start, end or stride is not integer, there will
2251 already have been an error issued. */
2252 for (n
= 0; n
< ref
->u
.ar
.as
->rank
; n
++)
2255 gfc_get_errors (NULL
, &errors
);
2256 if (((ref
->u
.ar
.start
[n
]
2257 && ref
->u
.ar
.start
[n
]->ts
.type
== BT_UNKNOWN
)
2260 && ref
->u
.ar
.end
[n
]->ts
.type
== BT_UNKNOWN
)
2262 (ref
->u
.ar
.stride
[n
]
2263 && ref
->u
.ar
.stride
[n
]->ts
.type
== BT_UNKNOWN
))
2267 if (n
== ref
->u
.ar
.as
->rank
)
2268 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2274 comp
= ref
->u
.c
.component
;
2279 /* Don't set the string length if a substring reference
2281 if (ts
->type
== BT_CHARACTER
2282 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2286 if (comp
->ts
.type
== BT_CLASS
)
2288 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2289 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2290 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2294 codimension
= comp
->attr
.codimension
;
2295 pointer
= comp
->attr
.pointer
;
2296 allocatable
= comp
->attr
.allocatable
;
2298 if (pointer
|| attr
.proc_pointer
)
2304 allocatable
= pointer
= 0;
2308 attr
.dimension
= dimension
;
2309 attr
.codimension
= codimension
;
2310 attr
.pointer
= pointer
;
2311 attr
.allocatable
= allocatable
;
2312 attr
.target
= target
;
2313 attr
.save
= sym
->attr
.save
;
2319 /* Return the attribute from a general expression. */
2322 gfc_expr_attr (gfc_expr
*e
)
2324 symbol_attribute attr
;
2326 switch (e
->expr_type
)
2329 attr
= gfc_variable_attr (e
, NULL
);
2333 gfc_clear_attr (&attr
);
2335 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2337 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2339 if (sym
->ts
.type
== BT_CLASS
)
2341 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2342 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2343 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2347 attr
= gfc_variable_attr (e
, NULL
);
2349 /* TODO: NULL() returns pointers. May have to take care of this
2355 gfc_clear_attr (&attr
);
2363 /* Match a structure constructor. The initial symbol has already been
2366 typedef struct gfc_structure_ctor_component
2371 struct gfc_structure_ctor_component
* next
;
2373 gfc_structure_ctor_component
;
2375 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2378 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2381 gfc_free_expr (comp
->val
);
2386 /* Translate the component list into the actual constructor by sorting it in
2387 the order required; this also checks along the way that each and every
2388 component actually has an initializer and handles default initializers
2389 for components without explicit value given. */
2391 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2392 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2394 gfc_structure_ctor_component
*comp_iter
;
2395 gfc_component
*comp
;
2397 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2399 gfc_structure_ctor_component
**next_ptr
;
2400 gfc_expr
*value
= NULL
;
2402 /* Try to find the initializer for the current component by name. */
2403 next_ptr
= comp_head
;
2404 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2406 if (!strcmp (comp_iter
->name
, comp
->name
))
2408 next_ptr
= &comp_iter
->next
;
2411 /* If an extension, try building the parent derived type by building
2412 a value expression for the parent derived type and calling self. */
2413 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2415 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2417 &gfc_current_locus
);
2418 value
->ts
= comp
->ts
;
2420 if (!build_actual_constructor (comp_head
,
2421 &value
->value
.constructor
,
2422 comp
->ts
.u
.derived
))
2424 gfc_free_expr (value
);
2428 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2432 /* If it was not found, try the default initializer if there's any;
2433 otherwise, it's an error unless this is a deferred parameter. */
2436 if (comp
->initializer
)
2438 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2439 "with missing optional arguments at %C"))
2441 value
= gfc_copy_expr (comp
->initializer
);
2443 else if (comp
->attr
.allocatable
2444 || (comp
->ts
.type
== BT_CLASS
2445 && CLASS_DATA (comp
)->attr
.allocatable
))
2447 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2448 "allocatable component '%qs' given in the "
2449 "structure constructor at %C", comp
->name
))
2452 else if (!comp
->attr
.artificial
)
2454 gfc_error ("No initializer for component %qs given in the"
2455 " structure constructor at %C!", comp
->name
);
2460 value
= comp_iter
->val
;
2462 /* Add the value to the constructor chain built. */
2463 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2465 /* Remove the entry from the component list. We don't want the expression
2466 value to be free'd, so set it to NULL. */
2469 *next_ptr
= comp_iter
->next
;
2470 comp_iter
->val
= NULL
;
2471 gfc_free_structure_ctor_component (comp_iter
);
2479 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2480 gfc_actual_arglist
**arglist
,
2483 gfc_actual_arglist
*actual
;
2484 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2485 gfc_constructor_base ctor_head
= NULL
;
2486 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2487 const char* last_name
= NULL
;
2491 expr
= parent
? *cexpr
: e
;
2492 old_locus
= gfc_current_locus
;
2494 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2496 gfc_current_locus
= expr
->where
;
2498 comp_tail
= comp_head
= NULL
;
2500 if (!parent
&& sym
->attr
.abstract
)
2502 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2503 sym
->name
, &expr
->where
);
2507 comp
= sym
->components
;
2508 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2511 gfc_component
*this_comp
= NULL
;
2514 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2517 comp_tail
->next
= gfc_get_structure_ctor_component ();
2518 comp_tail
= comp_tail
->next
;
2522 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2523 " constructor with named arguments at %C"))
2526 comp_tail
->name
= xstrdup (actual
->name
);
2527 last_name
= comp_tail
->name
;
2532 /* Components without name are not allowed after the first named
2533 component initializer! */
2534 if (!comp
|| comp
->attr
.artificial
)
2537 gfc_error ("Component initializer without name after component"
2538 " named %s at %L!", last_name
,
2539 actual
->expr
? &actual
->expr
->where
2540 : &gfc_current_locus
);
2542 gfc_error ("Too many components in structure constructor at "
2543 "%L!", actual
->expr
? &actual
->expr
->where
2544 : &gfc_current_locus
);
2548 comp_tail
->name
= xstrdup (comp
->name
);
2551 /* Find the current component in the structure definition and check
2552 its access is not private. */
2554 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2557 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2559 comp
= NULL
; /* Reset needed! */
2562 /* Here we can check if a component name is given which does not
2563 correspond to any component of the defined structure. */
2567 comp_tail
->val
= actual
->expr
;
2568 if (actual
->expr
!= NULL
)
2569 comp_tail
->where
= actual
->expr
->where
;
2570 actual
->expr
= NULL
;
2572 /* Check if this component is already given a value. */
2573 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2574 comp_iter
= comp_iter
->next
)
2576 gcc_assert (comp_iter
);
2577 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2579 gfc_error ("Component %qs is initialized twice in the structure"
2580 " constructor at %L!", comp_tail
->name
,
2581 comp_tail
->val
? &comp_tail
->where
2582 : &gfc_current_locus
);
2587 /* F2008, R457/C725, for PURE C1283. */
2588 if (this_comp
->attr
.pointer
&& comp_tail
->val
2589 && gfc_is_coindexed (comp_tail
->val
))
2591 gfc_error ("Coindexed expression to pointer component %qs in "
2592 "structure constructor at %L!", comp_tail
->name
,
2597 /* If not explicitly a parent constructor, gather up the components
2599 if (comp
&& comp
== sym
->components
2600 && sym
->attr
.extension
2602 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2604 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2607 gfc_actual_arglist
*arg_null
= NULL
;
2609 actual
->expr
= comp_tail
->val
;
2610 comp_tail
->val
= NULL
;
2612 m
= gfc_convert_to_structure_constructor (NULL
,
2613 comp
->ts
.u
.derived
, &comp_tail
->val
,
2614 comp
->ts
.u
.derived
->attr
.zero_comp
2615 ? &arg_null
: &actual
, true);
2619 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2628 if (parent
&& !comp
)
2632 actual
= actual
->next
;
2635 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2638 /* No component should be left, as this should have caused an error in the
2639 loop constructing the component-list (name that does not correspond to any
2640 component in the structure definition). */
2641 if (comp_head
&& sym
->attr
.extension
)
2643 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2645 gfc_error ("component %qs at %L has already been set by a "
2646 "parent derived type constructor", comp_iter
->name
,
2652 gcc_assert (!comp_head
);
2656 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2657 expr
->ts
.u
.derived
= sym
;
2658 expr
->value
.constructor
= ctor_head
;
2663 expr
->ts
.u
.derived
= sym
;
2665 expr
->ts
.type
= BT_DERIVED
;
2666 expr
->value
.constructor
= ctor_head
;
2667 expr
->expr_type
= EXPR_STRUCTURE
;
2670 gfc_current_locus
= old_locus
;
2676 gfc_current_locus
= old_locus
;
2678 for (comp_iter
= comp_head
; comp_iter
; )
2680 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2681 gfc_free_structure_ctor_component (comp_iter
);
2684 gfc_constructor_free (ctor_head
);
2691 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2695 gfc_symtree
*symtree
;
2697 gfc_get_sym_tree (sym
->name
, NULL
, &symtree
, false); /* Can't fail */
2699 e
= gfc_get_expr ();
2700 e
->symtree
= symtree
;
2701 e
->expr_type
= EXPR_FUNCTION
;
2703 gcc_assert (sym
->attr
.flavor
== FL_DERIVED
2704 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2705 e
->value
.function
.esym
= sym
;
2706 e
->symtree
->n
.sym
->attr
.generic
= 1;
2708 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2715 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
2726 /* If the symbol is an implicit do loop index and implicitly typed,
2727 it should not be host associated. Provide a symtree from the
2728 current namespace. */
2730 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2732 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2733 && (*sym
)->ns
!= gfc_current_ns
2734 && (*sym
)->attr
.implied_index
2735 && (*sym
)->attr
.implicit_type
2736 && !(*sym
)->attr
.use_assoc
)
2739 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2742 *sym
= (*st
)->n
.sym
;
2748 /* Procedure pointer as function result: Replace the function symbol by the
2749 auto-generated hidden result variable named "ppr@". */
2752 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2754 /* Check for procedure pointer result variable. */
2755 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2756 && (*sym
)->result
&& (*sym
)->result
!= *sym
2757 && (*sym
)->result
->attr
.proc_pointer
2758 && (*sym
) == gfc_current_ns
->proc_name
2759 && (*sym
) == (*sym
)->result
->ns
->proc_name
2760 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2762 /* Automatic replacement with "hidden" result variable. */
2763 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2764 *sym
= (*sym
)->result
;
2765 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2772 /* Matches a variable name followed by anything that might follow it--
2773 array reference, argument list of a function, etc. */
2776 gfc_match_rvalue (gfc_expr
**result
)
2778 gfc_actual_arglist
*actual_arglist
;
2779 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2782 gfc_symtree
*symtree
;
2783 locus where
, old_loc
;
2791 m
= gfc_match_name (name
);
2795 if (gfc_find_state (COMP_INTERFACE
)
2796 && !gfc_current_ns
->has_import_set
)
2797 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2799 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2804 sym
= symtree
->n
.sym
;
2806 where
= gfc_current_locus
;
2808 replace_hidden_procptr_result (&sym
, &symtree
);
2810 /* If this is an implicit do loop index and implicitly typed,
2811 it should not be host associated. */
2812 m
= check_for_implicit_index (&symtree
, &sym
);
2816 gfc_set_sym_referenced (sym
);
2817 sym
->attr
.implied_index
= 0;
2819 if (sym
->attr
.function
&& sym
->result
== sym
)
2821 /* See if this is a directly recursive function call. */
2822 gfc_gobble_whitespace ();
2823 if (sym
->attr
.recursive
2824 && gfc_peek_ascii_char () == '('
2825 && gfc_current_ns
->proc_name
== sym
2826 && !sym
->attr
.dimension
)
2828 gfc_error ("%qs at %C is the name of a recursive function "
2829 "and so refers to the result variable. Use an "
2830 "explicit RESULT variable for direct recursion "
2831 "(12.5.2.1)", sym
->name
);
2835 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2839 && (sym
->ns
== gfc_current_ns
2840 || sym
->ns
== gfc_current_ns
->parent
))
2842 gfc_entry_list
*el
= NULL
;
2844 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2850 if (gfc_matching_procptr_assignment
)
2853 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2856 if (sym
->attr
.generic
)
2857 goto generic_function
;
2859 switch (sym
->attr
.flavor
)
2863 e
= gfc_get_expr ();
2865 e
->expr_type
= EXPR_VARIABLE
;
2866 e
->symtree
= symtree
;
2868 m
= gfc_match_varspec (e
, 0, false, true);
2872 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2873 end up here. Unfortunately, sym->value->expr_type is set to
2874 EXPR_CONSTANT, and so the if () branch would be followed without
2875 the !sym->as check. */
2876 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2877 e
= gfc_copy_expr (sym
->value
);
2880 e
= gfc_get_expr ();
2881 e
->expr_type
= EXPR_VARIABLE
;
2884 e
->symtree
= symtree
;
2885 m
= gfc_match_varspec (e
, 0, false, true);
2887 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2890 /* Variable array references to derived type parameters cause
2891 all sorts of headaches in simplification. Treating such
2892 expressions as variable works just fine for all array
2894 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2896 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2897 if (ref
->type
== REF_ARRAY
)
2900 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2906 e
= gfc_get_expr ();
2907 e
->expr_type
= EXPR_VARIABLE
;
2908 e
->symtree
= symtree
;
2915 sym
= gfc_use_derived (sym
);
2919 goto generic_function
;
2922 /* If we're here, then the name is known to be the name of a
2923 procedure, yet it is not sure to be the name of a function. */
2926 /* Procedure Pointer Assignments. */
2928 if (gfc_matching_procptr_assignment
)
2930 gfc_gobble_whitespace ();
2931 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2932 /* Parse functions returning a procptr. */
2935 e
= gfc_get_expr ();
2936 e
->expr_type
= EXPR_VARIABLE
;
2937 e
->symtree
= symtree
;
2938 m
= gfc_match_varspec (e
, 0, false, true);
2939 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
2940 && sym
->ts
.type
== BT_UNKNOWN
2941 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
2949 if (sym
->attr
.subroutine
)
2951 gfc_error ("Unexpected use of subroutine name %qs at %C",
2957 /* At this point, the name has to be a non-statement function.
2958 If the name is the same as the current function being
2959 compiled, then we have a variable reference (to the function
2960 result) if the name is non-recursive. */
2962 st
= gfc_enclosing_unit (NULL
);
2964 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2966 && !sym
->attr
.recursive
)
2968 e
= gfc_get_expr ();
2969 e
->symtree
= symtree
;
2970 e
->expr_type
= EXPR_VARIABLE
;
2972 m
= gfc_match_varspec (e
, 0, false, true);
2976 /* Match a function reference. */
2978 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2981 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2982 gfc_error ("Statement function %qs requires argument list at %C",
2985 gfc_error ("Function %qs requires an argument list at %C",
2998 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2999 sym
= symtree
->n
.sym
;
3001 replace_hidden_procptr_result (&sym
, &symtree
);
3003 e
= gfc_get_expr ();
3004 e
->symtree
= symtree
;
3005 e
->expr_type
= EXPR_FUNCTION
;
3006 e
->value
.function
.actual
= actual_arglist
;
3007 e
->where
= gfc_current_locus
;
3009 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3010 && CLASS_DATA (sym
)->as
)
3011 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3012 else if (sym
->as
!= NULL
)
3013 e
->rank
= sym
->as
->rank
;
3015 if (!sym
->attr
.function
3016 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3022 /* Check here for the existence of at least one argument for the
3023 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3024 argument(s) given will be checked in gfc_iso_c_func_interface,
3025 during resolution of the function call. */
3026 if (sym
->attr
.is_iso_c
== 1
3027 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3028 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3029 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3030 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3032 /* make sure we were given a param */
3033 if (actual_arglist
== NULL
)
3035 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3041 if (sym
->result
== NULL
)
3049 /* Special case for derived type variables that get their types
3050 via an IMPLICIT statement. This can't wait for the
3051 resolution phase. */
3053 if (gfc_peek_ascii_char () == '%'
3054 && sym
->ts
.type
== BT_UNKNOWN
3055 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3056 gfc_set_default_type (sym
, 0, sym
->ns
);
3058 /* If the symbol has a (co)dimension attribute, the expression is a
3061 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3063 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3069 e
= gfc_get_expr ();
3070 e
->symtree
= symtree
;
3071 e
->expr_type
= EXPR_VARIABLE
;
3072 m
= gfc_match_varspec (e
, 0, false, true);
3076 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3077 && (CLASS_DATA (sym
)->attr
.dimension
3078 || CLASS_DATA (sym
)->attr
.codimension
))
3080 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3086 e
= gfc_get_expr ();
3087 e
->symtree
= symtree
;
3088 e
->expr_type
= EXPR_VARIABLE
;
3089 m
= gfc_match_varspec (e
, 0, false, true);
3093 /* Name is not an array, so we peek to see if a '(' implies a
3094 function call or a substring reference. Otherwise the
3095 variable is just a scalar. */
3097 gfc_gobble_whitespace ();
3098 if (gfc_peek_ascii_char () != '(')
3100 /* Assume a scalar variable */
3101 e
= gfc_get_expr ();
3102 e
->symtree
= symtree
;
3103 e
->expr_type
= EXPR_VARIABLE
;
3105 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3111 /*FIXME:??? gfc_match_varspec does set this for us: */
3113 m
= gfc_match_varspec (e
, 0, false, true);
3117 /* See if this is a function reference with a keyword argument
3118 as first argument. We do this because otherwise a spurious
3119 symbol would end up in the symbol table. */
3121 old_loc
= gfc_current_locus
;
3122 m2
= gfc_match (" ( %n =", argname
);
3123 gfc_current_locus
= old_loc
;
3125 e
= gfc_get_expr ();
3126 e
->symtree
= symtree
;
3128 if (m2
!= MATCH_YES
)
3130 /* Try to figure out whether we're dealing with a character type.
3131 We're peeking ahead here, because we don't want to call
3132 match_substring if we're dealing with an implicitly typed
3133 non-character variable. */
3134 implicit_char
= false;
3135 if (sym
->ts
.type
== BT_UNKNOWN
)
3137 ts
= gfc_get_default_type (sym
->name
, NULL
);
3138 if (ts
->type
== BT_CHARACTER
)
3139 implicit_char
= true;
3142 /* See if this could possibly be a substring reference of a name
3143 that we're not sure is a variable yet. */
3145 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3146 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
3149 e
->expr_type
= EXPR_VARIABLE
;
3151 if (sym
->attr
.flavor
!= FL_VARIABLE
3152 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3159 if (sym
->ts
.type
== BT_UNKNOWN
3160 && !gfc_set_default_type (sym
, 1, NULL
))
3174 /* Give up, assume we have a function. */
3176 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3177 sym
= symtree
->n
.sym
;
3178 e
->expr_type
= EXPR_FUNCTION
;
3180 if (!sym
->attr
.function
3181 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3189 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3191 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3199 /* If our new function returns a character, array or structure
3200 type, it might have subsequent references. */
3202 m
= gfc_match_varspec (e
, 0, false, true);
3209 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3211 e
= gfc_get_expr ();
3212 e
->symtree
= symtree
;
3213 e
->expr_type
= EXPR_FUNCTION
;
3215 if (sym
->attr
.flavor
== FL_DERIVED
)
3217 e
->value
.function
.esym
= sym
;
3218 e
->symtree
->n
.sym
->attr
.generic
= 1;
3221 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3225 gfc_error ("Symbol at %C is not appropriate for an expression");
3241 /* Match a variable, i.e. something that can be assigned to. This
3242 starts as a symbol, can be a structure component or an array
3243 reference. It can be a function if the function doesn't have a
3244 separate RESULT variable. If the symbol has not been previously
3245 seen, we assume it is a variable.
3247 This function is called by two interface functions:
3248 gfc_match_variable, which has host_flag = 1, and
3249 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3250 match of the symbol to the local scope. */
3253 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3261 /* Since nothing has any business being an lvalue in a module
3262 specification block, an interface block or a contains section,
3263 we force the changed_symbols mechanism to work by setting
3264 host_flag to 0. This prevents valid symbols that have the name
3265 of keywords, such as 'end', being turned into variables by
3266 failed matching to assignments for, e.g., END INTERFACE. */
3267 if (gfc_current_state () == COMP_MODULE
3268 || gfc_current_state () == COMP_INTERFACE
3269 || gfc_current_state () == COMP_CONTAINS
)
3272 where
= gfc_current_locus
;
3273 m
= gfc_match_sym_tree (&st
, host_flag
);
3279 /* If this is an implicit do loop index and implicitly typed,
3280 it should not be host associated. */
3281 m
= check_for_implicit_index (&st
, &sym
);
3285 sym
->attr
.implied_index
= 0;
3287 gfc_set_sym_referenced (sym
);
3288 switch (sym
->attr
.flavor
)
3291 /* Everything is alright. */
3296 sym_flavor flavor
= FL_UNKNOWN
;
3298 gfc_gobble_whitespace ();
3300 if (sym
->attr
.external
|| sym
->attr
.procedure
3301 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3302 flavor
= FL_PROCEDURE
;
3304 /* If it is not a procedure, is not typed and is host associated,
3305 we cannot give it a flavor yet. */
3306 else if (sym
->ns
== gfc_current_ns
->parent
3307 && sym
->ts
.type
== BT_UNKNOWN
)
3310 /* These are definitive indicators that this is a variable. */
3311 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3312 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3313 flavor
= FL_VARIABLE
;
3315 if (flavor
!= FL_UNKNOWN
3316 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3324 gfc_error ("Named constant at %C in an EQUIVALENCE");
3327 /* Otherwise this is checked for and an error given in the
3328 variable definition context checks. */
3332 /* Check for a nonrecursive function result variable. */
3333 if (sym
->attr
.function
3334 && !sym
->attr
.external
3335 && sym
->result
== sym
3336 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3338 && sym
->ns
== gfc_current_ns
)
3340 && sym
->ns
== gfc_current_ns
->parent
)))
3342 /* If a function result is a derived type, then the derived
3343 type may still have to be resolved. */
3345 if (sym
->ts
.type
== BT_DERIVED
3346 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3351 if (sym
->attr
.proc_pointer
3352 || replace_hidden_procptr_result (&sym
, &st
))
3355 /* Fall through to error */
3358 gfc_error ("%qs at %C is not a variable", sym
->name
);
3362 /* Special case for derived type variables that get their types
3363 via an IMPLICIT statement. This can't wait for the
3364 resolution phase. */
3367 gfc_namespace
* implicit_ns
;
3369 if (gfc_current_ns
->proc_name
== sym
)
3370 implicit_ns
= gfc_current_ns
;
3372 implicit_ns
= sym
->ns
;
3374 if (gfc_peek_ascii_char () == '%'
3375 && sym
->ts
.type
== BT_UNKNOWN
3376 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3377 gfc_set_default_type (sym
, 0, implicit_ns
);
3380 expr
= gfc_get_expr ();
3382 expr
->expr_type
= EXPR_VARIABLE
;
3385 expr
->where
= where
;
3387 /* Now see if we have to do more. */
3388 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3391 gfc_free_expr (expr
);
3401 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3403 return match_variable (result
, equiv_flag
, 1);
3408 gfc_match_equiv_variable (gfc_expr
**result
)
3410 return match_variable (result
, 1, 0);