1 /* Primary expression subroutines
2 Copyright (C) 2000-2023 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];
48 m
= gfc_match_small_literal_int (kind
, NULL
, false);
52 m
= gfc_match_name (name
, false);
56 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
62 *is_iso_c
= sym
->attr
.is_iso_c
;
64 if (sym
->attr
.flavor
!= FL_PARAMETER
)
67 if (sym
->value
== NULL
)
70 if (gfc_extract_int (sym
->value
, kind
))
73 gfc_set_sym_referenced (sym
);
82 /* Get a trailing kind-specification for non-character variables.
84 * the integer kind value or
85 * -1 if an error was generated,
86 * -2 if no kind was found.
87 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
88 symbol like e.g. 'c_int'. */
91 get_kind (int *is_iso_c
)
98 if (gfc_match_char ('_', false) != MATCH_YES
)
101 m
= match_kind_param (&kind
, is_iso_c
);
103 gfc_error ("Missing kind-parameter at %C");
105 return (m
== MATCH_YES
) ? kind
: -1;
109 /* Given a character and a radix, see if the character is a valid
110 digit in that radix. */
113 gfc_check_digit (char c
, int radix
)
120 r
= ('0' <= c
&& c
<= '1');
124 r
= ('0' <= c
&& c
<= '7');
128 r
= ('0' <= c
&& c
<= '9');
136 gfc_internal_error ("gfc_check_digit(): bad radix");
143 /* Match the digit string part of an integer if signflag is not set,
144 the signed digit string part if signflag is set. If the buffer
145 is NULL, we just count characters for the resolution pass. Returns
146 the number of characters matched, -1 for no match. */
149 match_digits (int signflag
, int radix
, char *buffer
)
156 c
= gfc_next_ascii_char ();
158 if (signflag
&& (c
== '+' || c
== '-'))
162 gfc_gobble_whitespace ();
163 c
= gfc_next_ascii_char ();
167 if (!gfc_check_digit (c
, radix
))
176 old_loc
= gfc_current_locus
;
177 c
= gfc_next_ascii_char ();
179 if (!gfc_check_digit (c
, radix
))
187 gfc_current_locus
= old_loc
;
192 /* Convert an integer string to an expression node. */
195 convert_integer (const char *buffer
, int kind
, int radix
, locus
*where
)
200 e
= gfc_get_constant_expr (BT_INTEGER
, kind
, where
);
201 /* A leading plus is allowed, but not by mpz_set_str. */
202 if (buffer
[0] == '+')
206 mpz_set_str (e
->value
.integer
, t
, radix
);
212 /* Convert a real string to an expression node. */
215 convert_real (const char *buffer
, int kind
, locus
*where
)
219 e
= gfc_get_constant_expr (BT_REAL
, kind
, where
);
220 mpfr_set_str (e
->value
.real
, buffer
, 10, GFC_RND_MODE
);
226 /* Convert a pair of real, constant expression nodes to a single
227 complex expression node. */
230 convert_complex (gfc_expr
*real
, gfc_expr
*imag
, int kind
)
234 e
= gfc_get_constant_expr (BT_COMPLEX
, kind
, &real
->where
);
235 mpc_set_fr_fr (e
->value
.complex, real
->value
.real
, imag
->value
.real
,
242 /* Match an integer (digit string and optional kind).
243 A sign will be accepted if signflag is set. */
246 match_integer_constant (gfc_expr
**result
, int signflag
)
248 int length
, kind
, is_iso_c
;
253 old_loc
= gfc_current_locus
;
254 gfc_gobble_whitespace ();
256 length
= match_digits (signflag
, 10, NULL
);
257 gfc_current_locus
= old_loc
;
261 buffer
= (char *) alloca (length
+ 1);
262 memset (buffer
, '\0', length
+ 1);
264 gfc_gobble_whitespace ();
266 match_digits (signflag
, 10, buffer
);
268 kind
= get_kind (&is_iso_c
);
270 kind
= gfc_default_integer_kind
;
274 if (kind
== 4 && flag_integer4_kind
== 8)
277 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
279 gfc_error ("Integer kind %d at %C not available", kind
);
283 e
= convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
284 e
->ts
.is_c_interop
= is_iso_c
;
286 if (gfc_range_check (e
) != ARITH_OK
)
288 gfc_error ("Integer too big for its kind at %C. This check can be "
289 "disabled with the option %<-fno-range-check%>");
300 /* Match a Hollerith constant. */
303 match_hollerith_constant (gfc_expr
**result
)
310 old_loc
= gfc_current_locus
;
311 gfc_gobble_whitespace ();
313 if (match_integer_constant (&e
, 0) == MATCH_YES
314 && gfc_match_char ('h') == MATCH_YES
)
316 if (!gfc_notify_std (GFC_STD_LEGACY
, "Hollerith constant at %C"))
319 if (gfc_extract_int (e
, &num
, 1))
323 gfc_error ("Invalid Hollerith constant: %L must contain at least "
324 "one character", &old_loc
);
327 if (e
->ts
.kind
!= gfc_default_integer_kind
)
329 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
330 "should be default", &old_loc
);
336 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
339 /* Calculate padding needed to fit default integer memory. */
340 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
342 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
344 for (i
= 0; i
< num
; i
++)
346 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
347 if (! gfc_wide_fits_in_byte (c
))
349 gfc_error ("Invalid Hollerith constant at %L contains a "
350 "wide character", &old_loc
);
354 e
->representation
.string
[i
] = (unsigned char) c
;
357 /* Now pad with blanks and end with a null char. */
358 for (i
= 0; i
< pad
; i
++)
359 e
->representation
.string
[num
+ i
] = ' ';
361 e
->representation
.string
[num
+ i
] = '\0';
362 e
->representation
.length
= num
+ pad
;
371 gfc_current_locus
= old_loc
;
380 /* Match a binary, octal or hexadecimal constant that can be found in
381 a DATA statement. The standard permits b'010...', o'73...', and
382 z'a1...' where b, o, and z can be capital letters. This function
383 also accepts postfixed forms of the constants: '01...'b, '73...'o,
384 and 'a1...'z. An additional extension is the use of x for z. */
387 match_boz_constant (gfc_expr
**result
)
389 int radix
, length
, x_hex
;
390 locus old_loc
, start_loc
;
391 char *buffer
, post
, delim
;
394 start_loc
= old_loc
= gfc_current_locus
;
395 gfc_gobble_whitespace ();
398 switch (post
= gfc_next_ascii_char ())
420 radix
= 16; /* Set to accept any valid digit string. */
426 /* No whitespace allowed here. */
429 delim
= gfc_next_ascii_char ();
431 if (delim
!= '\'' && delim
!= '\"')
435 && gfc_invalid_boz (G_("Hexadecimal constant at %L uses "
436 "nonstandard X instead of Z"), &gfc_current_locus
))
439 old_loc
= gfc_current_locus
;
441 length
= match_digits (0, radix
, NULL
);
444 gfc_error ("Empty set of digits in BOZ constant at %C");
448 if (gfc_next_ascii_char () != delim
)
450 gfc_error ("Illegal character in BOZ constant at %C");
456 switch (gfc_next_ascii_char ())
473 if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix "
474 "syntax"), &gfc_current_locus
))
478 gfc_current_locus
= old_loc
;
480 buffer
= (char *) alloca (length
+ 1);
481 memset (buffer
, '\0', length
+ 1);
483 match_digits (0, radix
, buffer
);
484 gfc_next_ascii_char (); /* Eat delimiter. */
486 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
489 e
->expr_type
= EXPR_CONSTANT
;
491 e
->where
= gfc_current_locus
;
494 e
->boz
.str
= XCNEWVEC (char, length
+ 1);
495 strncpy (e
->boz
.str
, buffer
, length
);
497 if (!gfc_in_match_data ()
498 && (!gfc_notify_std(GFC_STD_F2003
, "BOZ used outside a DATA "
499 "statement at %L", &e
->where
)))
506 gfc_current_locus
= start_loc
;
511 /* Match a real constant of some sort. Allow a signed constant if signflag
515 match_real_constant (gfc_expr
**result
, int signflag
)
517 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
, default_exponent
;
518 locus old_loc
, temp_loc
;
519 char *p
, *buffer
, c
, exp_char
;
523 old_loc
= gfc_current_locus
;
524 gfc_gobble_whitespace ();
528 default_exponent
= 0;
535 c
= gfc_next_ascii_char ();
536 if (signflag
&& (c
== '+' || c
== '-'))
541 gfc_gobble_whitespace ();
542 c
= gfc_next_ascii_char ();
545 /* Scan significand. */
546 for (;; c
= gfc_next_ascii_char (), count
++)
553 /* Check to see if "." goes with a following operator like
555 temp_loc
= gfc_current_locus
;
556 c
= gfc_next_ascii_char ();
558 if (c
== 'e' || c
== 'd' || c
== 'q')
560 c
= gfc_next_ascii_char ();
562 goto done
; /* Operator named .e. or .d. */
566 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
568 gfc_current_locus
= temp_loc
;
582 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
589 if (!gfc_notify_std (GFC_STD_GNU
, "exponent-letter %<q%> in "
590 "real-literal-constant at %C"))
592 else if (warn_real_q_constant
)
593 gfc_warning (OPT_Wreal_q_constant
,
594 "Extension: exponent-letter %<q%> in real-literal-constant "
599 c
= gfc_next_ascii_char ();
602 if (c
== '+' || c
== '-')
603 { /* optional sign */
604 c
= gfc_next_ascii_char ();
610 /* With -fdec, default exponent to 0 instead of complaining. */
612 default_exponent
= 1;
615 gfc_error ("Missing exponent in real number at %C");
622 c
= gfc_next_ascii_char ();
627 /* Check that we have a numeric constant. */
628 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
630 gfc_current_locus
= old_loc
;
634 /* Convert the number. */
635 gfc_current_locus
= old_loc
;
636 gfc_gobble_whitespace ();
638 buffer
= (char *) alloca (count
+ default_exponent
+ 1);
639 memset (buffer
, '\0', count
+ default_exponent
+ 1);
642 c
= gfc_next_ascii_char ();
643 if (c
== '+' || c
== '-')
645 gfc_gobble_whitespace ();
646 c
= gfc_next_ascii_char ();
649 /* Hack for mpfr_set_str(). */
652 if (c
== 'd' || c
== 'q')
660 c
= gfc_next_ascii_char ();
662 if (default_exponent
)
665 kind
= get_kind (&is_iso_c
);
671 if (flag_real4_kind
== 8)
673 if (flag_real4_kind
== 10)
675 if (flag_real4_kind
== 16)
680 if (flag_real8_kind
== 4)
682 if (flag_real8_kind
== 10)
684 if (flag_real8_kind
== 16)
693 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
697 kind
= gfc_default_double_kind
;
703 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
708 /* The maximum possible real kind type parameter is 16. First, try
709 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
710 extended precision. If neither value works, just given up. */
712 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
715 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
717 gfc_error ("Invalid exponent-letter %<q%> in "
718 "real-literal-constant at %C");
726 kind
= gfc_default_real_kind
;
728 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
730 gfc_error ("Invalid real kind %d at %C", kind
);
735 e
= convert_real (buffer
, kind
, &gfc_current_locus
);
737 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
738 e
->ts
.is_c_interop
= is_iso_c
;
740 switch (gfc_range_check (e
))
745 gfc_error ("Real constant overflows its kind at %C");
748 case ARITH_UNDERFLOW
:
750 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
751 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
755 gfc_internal_error ("gfc_range_check() returned bad value");
758 /* Warn about trailing digits which suggest the user added too many
759 trailing digits, which may cause the appearance of higher precision
760 than the kind can support.
762 This is done by replacing the rightmost non-zero digit with zero
763 and comparing with the original value. If these are equal, we
764 assume the user supplied more digits than intended (or forgot to
765 convert to the correct kind).
768 if (warn_conversion_extra
)
774 c1
= strchr (buffer
, 'e');
776 c1
= buffer
+ strlen(buffer
);
779 for (p
= c1
; p
> buffer
;)
796 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
798 mpfr_neg (r
, r
, GFC_RND_MODE
);
800 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
802 if (mpfr_cmp_ui (r
, 0) == 0)
803 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
804 "in %qs number at %C, maybe incorrect KIND",
805 gfc_typename (&e
->ts
));
820 /* Match a substring reference. */
823 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
, bool deferred
)
825 gfc_expr
*start
, *end
;
833 old_loc
= gfc_current_locus
;
835 m
= gfc_match_char ('(');
839 if (gfc_match_char (':') != MATCH_YES
)
842 m
= gfc_match_init_expr (&start
);
844 m
= gfc_match_expr (&start
);
852 m
= gfc_match_char (':');
857 if (gfc_match_char (')') != MATCH_YES
)
860 m
= gfc_match_init_expr (&end
);
862 m
= gfc_match_expr (&end
);
866 if (m
== MATCH_ERROR
)
869 m
= gfc_match_char (')');
874 /* Optimize away the (:) reference. */
875 if (start
== NULL
&& end
== NULL
&& !deferred
)
879 ref
= gfc_get_ref ();
881 ref
->type
= REF_SUBSTRING
;
883 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
884 ref
->u
.ss
.start
= start
;
885 if (end
== NULL
&& cl
)
886 end
= gfc_copy_expr (cl
->length
);
888 ref
->u
.ss
.length
= cl
;
895 gfc_error ("Syntax error in SUBSTRING specification at %C");
899 gfc_free_expr (start
);
902 gfc_current_locus
= old_loc
;
907 /* Reads the next character of a string constant, taking care to
908 return doubled delimiters on the input as a single instance of
911 Special return values for "ret" argument are:
912 -1 End of the string, as determined by the delimiter
913 -2 Unterminated string detected
915 Backslash codes are also expanded at this time. */
918 next_string_char (gfc_char_t delimiter
, int *ret
)
923 c
= gfc_next_char_literal (INSTRING_WARN
);
932 if (flag_backslash
&& c
== '\\')
934 old_locus
= gfc_current_locus
;
936 if (gfc_match_special_char (&c
) == MATCH_NO
)
937 gfc_current_locus
= old_locus
;
939 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
940 gfc_warning (0, "Extension: backslash character at %C");
946 old_locus
= gfc_current_locus
;
947 c
= gfc_next_char_literal (NONSTRING
);
951 gfc_current_locus
= old_locus
;
958 /* Special case of gfc_match_name() that matches a parameter kind name
959 before a string constant. This takes case of the weird but legal
964 where kind____ is a parameter. gfc_match_name() will happily slurp
965 up all the underscores, which leads to problems. If we return
966 MATCH_YES, the parse pointer points to the final underscore, which
967 is not part of the name. We never return MATCH_ERROR-- errors in
968 the name will be detected later. */
971 match_charkind_name (char *name
)
977 gfc_gobble_whitespace ();
978 c
= gfc_next_ascii_char ();
987 old_loc
= gfc_current_locus
;
988 c
= gfc_next_ascii_char ();
992 peek
= gfc_peek_ascii_char ();
994 if (peek
== '\'' || peek
== '\"')
996 gfc_current_locus
= old_loc
;
1004 && (c
!= '$' || !flag_dollar_ok
))
1008 if (++len
> GFC_MAX_SYMBOL_LEN
)
1016 /* See if the current input matches a character constant. Lots of
1017 contortions have to be done to match the kind parameter which comes
1018 before the actual string. The main consideration is that we don't
1019 want to error out too quickly. For example, we don't actually do
1020 any validation of the kinds until we have actually seen a legal
1021 delimiter. Using match_kind_param() generates errors too quickly. */
1024 match_string_constant (gfc_expr
**result
)
1026 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1028 int kind
,save_warn_ampersand
, ret
;
1029 locus old_locus
, start_locus
;
1033 gfc_char_t c
, delimiter
, *p
;
1035 old_locus
= gfc_current_locus
;
1037 gfc_gobble_whitespace ();
1039 c
= gfc_next_char ();
1040 if (c
== '\'' || c
== '"')
1042 kind
= gfc_default_character_kind
;
1043 start_locus
= gfc_current_locus
;
1047 if (gfc_wide_is_digit (c
))
1051 while (gfc_wide_is_digit (c
))
1053 kind
= kind
* 10 + c
- '0';
1056 c
= gfc_next_char ();
1062 gfc_current_locus
= old_locus
;
1064 m
= match_charkind_name (name
);
1068 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1070 || sym
->attr
.flavor
!= FL_PARAMETER
)
1074 c
= gfc_next_char ();
1080 c
= gfc_next_char ();
1081 if (c
!= '\'' && c
!= '"')
1084 start_locus
= gfc_current_locus
;
1088 if (gfc_extract_int (sym
->value
, &kind
, 1))
1090 gfc_set_sym_referenced (sym
);
1093 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1095 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1100 /* Scan the string into a block of memory by first figuring out how
1101 long it is, allocating the structure, then re-reading it. This
1102 isn't particularly efficient, but string constants aren't that
1103 common in most code. TODO: Use obstacks? */
1110 c
= next_string_char (delimiter
, &ret
);
1115 gfc_current_locus
= start_locus
;
1116 gfc_error ("Unterminated character constant beginning at %C");
1123 /* Peek at the next character to see if it is a b, o, z, or x for the
1124 postfixed BOZ literal constants. */
1125 peek
= gfc_peek_ascii_char ();
1126 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1129 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1131 gfc_current_locus
= start_locus
;
1133 /* We disable the warning for the following loop as the warning has already
1134 been printed in the loop above. */
1135 save_warn_ampersand
= warn_ampersand
;
1136 warn_ampersand
= false;
1138 p
= e
->value
.character
.string
;
1139 for (size_t i
= 0; i
< length
; i
++)
1141 c
= next_string_char (delimiter
, &ret
);
1143 if (!gfc_check_character_range (c
, kind
))
1146 gfc_error ("Character %qs in string at %C is not representable "
1147 "in character kind %d", gfc_print_wide_char (c
), kind
);
1154 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1155 warn_ampersand
= save_warn_ampersand
;
1157 next_string_char (delimiter
, &ret
);
1159 gfc_internal_error ("match_string_constant(): Delimiter not found");
1161 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1162 e
->expr_type
= EXPR_SUBSTRING
;
1164 /* Substrings with constant starting and ending points are eligible as
1165 designators (F2018, section 9.1). Simplify substrings to make them usable
1166 e.g. in data statements. */
1167 if (e
->expr_type
== EXPR_SUBSTRING
1168 && e
->ref
&& e
->ref
->type
== REF_SUBSTRING
1169 && e
->ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1170 && (e
->ref
->u
.ss
.end
== NULL
1171 || e
->ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
))
1174 ptrdiff_t istart
, iend
;
1176 bool equal_length
= false;
1178 /* Basic checks on substring starting and ending indices. */
1179 if (!gfc_resolve_substring (e
->ref
, &equal_length
))
1182 length
= e
->value
.character
.length
;
1183 istart
= gfc_mpz_get_hwi (e
->ref
->u
.ss
.start
->value
.integer
);
1184 if (e
->ref
->u
.ss
.end
== NULL
)
1187 iend
= gfc_mpz_get_hwi (e
->ref
->u
.ss
.end
->value
.integer
);
1193 gfc_error ("Substring start index (%ld) at %L below 1",
1194 (long) istart
, &e
->ref
->u
.ss
.start
->where
);
1197 if (iend
> (ssize_t
) length
)
1199 gfc_error ("Substring end index (%ld) at %L exceeds string "
1200 "length", (long) iend
, &e
->ref
->u
.ss
.end
->where
);
1203 length
= iend
- istart
+ 1;
1208 res
= gfc_get_constant_expr (BT_CHARACTER
, e
->ts
.kind
, &e
->where
);
1209 res
->value
.character
.string
= gfc_get_wide_string (length
+ 1);
1210 res
->value
.character
.length
= length
;
1212 memcpy (res
->value
.character
.string
,
1213 &e
->value
.character
.string
[istart
- 1],
1214 length
* sizeof (gfc_char_t
));
1215 res
->value
.character
.string
[length
] = '\0';
1224 gfc_current_locus
= old_locus
;
1229 /* Match a .true. or .false. Returns 1 if a .true. was found,
1230 0 if a .false. was found, and -1 otherwise. */
1232 match_logical_constant_string (void)
1234 locus orig_loc
= gfc_current_locus
;
1236 gfc_gobble_whitespace ();
1237 if (gfc_next_ascii_char () == '.')
1239 char ch
= gfc_next_ascii_char ();
1242 if (gfc_next_ascii_char () == 'a'
1243 && gfc_next_ascii_char () == 'l'
1244 && gfc_next_ascii_char () == 's'
1245 && gfc_next_ascii_char () == 'e'
1246 && gfc_next_ascii_char () == '.')
1247 /* Matched ".false.". */
1252 if (gfc_next_ascii_char () == 'r'
1253 && gfc_next_ascii_char () == 'u'
1254 && gfc_next_ascii_char () == 'e'
1255 && gfc_next_ascii_char () == '.')
1256 /* Matched ".true.". */
1260 gfc_current_locus
= orig_loc
;
1264 /* Match a .true. or .false. */
1267 match_logical_constant (gfc_expr
**result
)
1270 int i
, kind
, is_iso_c
;
1272 i
= match_logical_constant_string ();
1276 kind
= get_kind (&is_iso_c
);
1280 kind
= gfc_default_logical_kind
;
1282 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1284 gfc_error ("Bad kind for logical constant at %C");
1288 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1289 e
->ts
.is_c_interop
= is_iso_c
;
1296 /* Match a real or imaginary part of a complex constant that is a
1297 symbolic constant. */
1300 match_sym_complex_part (gfc_expr
**result
)
1302 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1307 m
= gfc_match_name (name
);
1311 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1314 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1316 /* Give the matcher for implied do-loops a chance to run. This yields
1317 a much saner error message for "write(*,*) (i, i=1, 6" where the
1318 right parenthesis is missing. */
1320 gfc_gobble_whitespace ();
1321 c
= gfc_peek_ascii_char ();
1322 if (c
== '=' || c
== ',')
1328 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1337 if (!gfc_numeric_ts (&sym
->value
->ts
))
1339 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1343 if (sym
->value
->rank
!= 0)
1345 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1349 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1350 "complex constant at %C"))
1353 switch (sym
->value
->ts
.type
)
1356 e
= gfc_copy_expr (sym
->value
);
1360 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1366 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1372 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1375 *result
= e
; /* e is a scalar, real, constant expression. */
1379 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1384 /* Match a real or imaginary part of a complex number. */
1387 match_complex_part (gfc_expr
**result
)
1391 m
= match_sym_complex_part (result
);
1395 m
= match_real_constant (result
, 1);
1399 return match_integer_constant (result
, 1);
1403 /* Try to match a complex constant. */
1406 match_complex_constant (gfc_expr
**result
)
1408 gfc_expr
*e
, *real
, *imag
;
1409 gfc_error_buffer old_error
;
1410 gfc_typespec target
;
1415 old_loc
= gfc_current_locus
;
1416 real
= imag
= e
= NULL
;
1418 m
= gfc_match_char ('(');
1422 gfc_push_error (&old_error
);
1424 m
= match_complex_part (&real
);
1427 gfc_free_error (&old_error
);
1431 if (gfc_match_char (',') == MATCH_NO
)
1433 /* It is possible that gfc_int2real issued a warning when
1434 converting an integer to real. Throw this away here. */
1436 gfc_clear_warning ();
1437 gfc_pop_error (&old_error
);
1442 /* If m is error, then something was wrong with the real part and we
1443 assume we have a complex constant because we've seen the ','. An
1444 ambiguous case here is the start of an iterator list of some
1445 sort. These sort of lists are matched prior to coming here. */
1447 if (m
== MATCH_ERROR
)
1449 gfc_free_error (&old_error
);
1452 gfc_pop_error (&old_error
);
1454 m
= match_complex_part (&imag
);
1457 if (m
== MATCH_ERROR
)
1460 m
= gfc_match_char (')');
1463 /* Give the matcher for implied do-loops a chance to run. This
1464 yields a much saner error message for (/ (i, 4=i, 6) /). */
1465 if (gfc_peek_ascii_char () == '=')
1474 if (m
== MATCH_ERROR
)
1477 /* Decide on the kind of this complex number. */
1478 if (real
->ts
.type
== BT_REAL
)
1480 if (imag
->ts
.type
== BT_REAL
)
1481 kind
= gfc_kind_max (real
, imag
);
1483 kind
= real
->ts
.kind
;
1487 if (imag
->ts
.type
== BT_REAL
)
1488 kind
= imag
->ts
.kind
;
1490 kind
= gfc_default_real_kind
;
1492 gfc_clear_ts (&target
);
1493 target
.type
= BT_REAL
;
1496 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1497 gfc_convert_type (real
, &target
, 2);
1498 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1499 gfc_convert_type (imag
, &target
, 2);
1501 e
= convert_complex (real
, imag
, kind
);
1502 e
->where
= gfc_current_locus
;
1504 gfc_free_expr (real
);
1505 gfc_free_expr (imag
);
1511 gfc_error ("Syntax error in COMPLEX constant at %C");
1516 gfc_free_expr (real
);
1517 gfc_free_expr (imag
);
1518 gfc_current_locus
= old_loc
;
1524 /* Match constants in any of several forms. Returns nonzero for a
1525 match, zero for no match. */
1528 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1532 m
= match_complex_constant (result
);
1536 m
= match_string_constant (result
);
1540 m
= match_boz_constant (result
);
1544 m
= match_real_constant (result
, signflag
);
1548 m
= match_hollerith_constant (result
);
1552 m
= match_integer_constant (result
, signflag
);
1556 m
= match_logical_constant (result
);
1564 /* This checks if a symbol is the return value of an encompassing function.
1565 Function nesting can be maximally two levels deep, but we may have
1566 additional local namespaces like BLOCK etc. */
1569 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1571 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1575 if (ns
->proc_name
== sym
)
1583 /* Match a single actual argument value. An actual argument is
1584 usually an expression, but can also be a procedure name. If the
1585 argument is a single name, it is not always possible to tell
1586 whether the name is a dummy procedure or not. We treat these cases
1587 by creating an argument that looks like a dummy procedure and
1588 fixing things later during resolution. */
1591 match_actual_arg (gfc_expr
**result
)
1593 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1594 gfc_symtree
*symtree
;
1599 gfc_gobble_whitespace ();
1600 where
= gfc_current_locus
;
1602 switch (gfc_match_name (name
))
1611 w
= gfc_current_locus
;
1612 gfc_gobble_whitespace ();
1613 c
= gfc_next_ascii_char ();
1614 gfc_current_locus
= w
;
1616 if (c
!= ',' && c
!= ')')
1619 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1621 /* Handle error elsewhere. */
1623 /* Eliminate a couple of common cases where we know we don't
1624 have a function argument. */
1625 if (symtree
== NULL
)
1627 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1628 gfc_set_sym_referenced (symtree
->n
.sym
);
1634 sym
= symtree
->n
.sym
;
1635 gfc_set_sym_referenced (sym
);
1636 if (sym
->attr
.flavor
== FL_NAMELIST
)
1638 gfc_error ("Namelist %qs cannot be an argument at %L",
1642 if (sym
->attr
.flavor
!= FL_PROCEDURE
1643 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1646 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1648 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1649 sym
->name
, &sym
->declared_at
))
1654 /* If the symbol is a function with itself as the result and
1655 is being defined, then we have a variable. */
1656 if (sym
->attr
.function
&& sym
->result
== sym
)
1658 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1662 && (sym
->ns
== gfc_current_ns
1663 || sym
->ns
== gfc_current_ns
->parent
))
1665 gfc_entry_list
*el
= NULL
;
1667 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1677 e
= gfc_get_expr (); /* Leave it unknown for now */
1678 e
->symtree
= symtree
;
1679 e
->expr_type
= EXPR_VARIABLE
;
1680 e
->ts
.type
= BT_PROCEDURE
;
1687 gfc_current_locus
= where
;
1688 return gfc_match_expr (result
);
1692 /* Match a keyword argument or type parameter spec list.. */
1695 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
, bool pdt
)
1697 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1698 gfc_actual_arglist
*a
;
1702 name_locus
= gfc_current_locus
;
1703 m
= gfc_match_name (name
);
1707 if (gfc_match_char ('=') != MATCH_YES
)
1715 if (gfc_match_char ('*') == MATCH_YES
)
1717 actual
->spec_type
= SPEC_ASSUMED
;
1720 else if (gfc_match_char (':') == MATCH_YES
)
1722 actual
->spec_type
= SPEC_DEFERRED
;
1726 actual
->spec_type
= SPEC_EXPLICIT
;
1729 m
= match_actual_arg (&actual
->expr
);
1733 /* Make sure this name has not appeared yet. */
1735 if (name
[0] != '\0')
1737 for (a
= base
; a
; a
= a
->next
)
1738 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1740 gfc_error ("Keyword %qs at %C has already appeared in the "
1741 "current argument list", name
);
1746 actual
->name
= gfc_get_string ("%s", name
);
1750 gfc_current_locus
= name_locus
;
1755 /* Match an argument list function, such as %VAL. */
1758 match_arg_list_function (gfc_actual_arglist
*result
)
1760 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1764 old_locus
= gfc_current_locus
;
1766 if (gfc_match_char ('%') != MATCH_YES
)
1772 m
= gfc_match ("%n (", name
);
1776 if (name
[0] != '\0')
1781 if (startswith (name
, "loc"))
1783 result
->name
= "%LOC";
1788 if (startswith (name
, "ref"))
1790 result
->name
= "%REF";
1795 if (startswith (name
, "val"))
1797 result
->name
= "%VAL";
1807 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1813 m
= match_actual_arg (&result
->expr
);
1817 if (gfc_match_char (')') != MATCH_YES
)
1826 gfc_current_locus
= old_locus
;
1831 /* Matches an actual argument list of a function or subroutine, from
1832 the opening parenthesis to the closing parenthesis. The argument
1833 list is assumed to allow keyword arguments because we don't know if
1834 the symbol associated with the procedure has an implicit interface
1835 or not. We make sure keywords are unique. If sub_flag is set,
1836 we're matching the argument list of a subroutine.
1838 NOTE: An alternative use for this function is to match type parameter
1839 spec lists, which are so similar to actual argument lists that the
1840 machinery can be reused. This use is flagged by the optional argument
1844 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
, bool pdt
)
1846 gfc_actual_arglist
*head
, *tail
;
1848 gfc_st_label
*label
;
1852 *argp
= tail
= NULL
;
1853 old_loc
= gfc_current_locus
;
1857 if (gfc_match_char ('(') == MATCH_NO
)
1858 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1860 if (gfc_match_char (')') == MATCH_YES
)
1865 matching_actual_arglist
++;
1870 head
= tail
= gfc_get_actual_arglist ();
1873 tail
->next
= gfc_get_actual_arglist ();
1877 if (sub_flag
&& !pdt
&& gfc_match_char ('*') == MATCH_YES
)
1879 m
= gfc_match_st_label (&label
);
1881 gfc_error ("Expected alternate return label at %C");
1885 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1889 tail
->label
= label
;
1893 if (pdt
&& !seen_keyword
)
1895 if (gfc_match_char (':') == MATCH_YES
)
1897 tail
->spec_type
= SPEC_DEFERRED
;
1900 else if (gfc_match_char ('*') == MATCH_YES
)
1902 tail
->spec_type
= SPEC_ASSUMED
;
1906 tail
->spec_type
= SPEC_EXPLICIT
;
1908 m
= match_keyword_arg (tail
, head
, pdt
);
1914 if (m
== MATCH_ERROR
)
1918 /* After the first keyword argument is seen, the following
1919 arguments must also have keywords. */
1922 m
= match_keyword_arg (tail
, head
, pdt
);
1924 if (m
== MATCH_ERROR
)
1928 gfc_error ("Missing keyword name in actual argument list at %C");
1935 /* Try an argument list function, like %VAL. */
1936 m
= match_arg_list_function (tail
);
1937 if (m
== MATCH_ERROR
)
1940 /* See if we have the first keyword argument. */
1943 m
= match_keyword_arg (tail
, head
, false);
1946 if (m
== MATCH_ERROR
)
1952 /* Try for a non-keyword argument. */
1953 m
= match_actual_arg (&tail
->expr
);
1954 if (m
== MATCH_ERROR
)
1963 if (gfc_match_char (')') == MATCH_YES
)
1965 if (gfc_match_char (',') != MATCH_YES
)
1970 matching_actual_arglist
--;
1974 gfc_error ("Syntax error in argument list at %C");
1977 gfc_free_actual_arglist (head
);
1978 gfc_current_locus
= old_loc
;
1979 matching_actual_arglist
--;
1984 /* Used by gfc_match_varspec() to extend the reference list by one
1988 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1990 if (primary
->ref
== NULL
)
1991 primary
->ref
= tail
= gfc_get_ref ();
1995 gfc_internal_error ("extend_ref(): Bad tail");
1996 tail
->next
= gfc_get_ref ();
2004 /* Used by gfc_match_varspec() to match an inquiry reference. */
2007 is_inquiry_ref (const char *name
, gfc_ref
**ref
)
2014 if (ref
) *ref
= NULL
;
2016 if (strcmp (name
, "re") == 0)
2018 else if (strcmp (name
, "im") == 0)
2020 else if (strcmp (name
, "kind") == 0)
2021 type
= INQUIRY_KIND
;
2022 else if (strcmp (name
, "len") == 0)
2029 *ref
= gfc_get_ref ();
2030 (*ref
)->type
= REF_INQUIRY
;
2038 /* Match any additional specifications associated with the current
2039 variable like member references or substrings. If equiv_flag is
2040 set we only match stuff that is allowed inside an EQUIVALENCE
2041 statement. sub_flag tells whether we expect a type-bound procedure found
2042 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
2043 components, 'ppc_arg' determines whether the PPC may be called (with an
2044 argument list), or whether it may just be referred to as a pointer. */
2047 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
2050 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2051 gfc_ref
*substring
, *tail
, *tmp
;
2052 gfc_component
*component
= NULL
;
2053 gfc_component
*previous
= NULL
;
2054 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
2055 gfc_expr
*tgt_expr
= NULL
;
2065 gfc_gobble_whitespace ();
2067 if (gfc_peek_ascii_char () == '[')
2069 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
2070 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2071 && CLASS_DATA (sym
)->attr
.dimension
))
2073 gfc_error ("Array section designator, e.g. %<(:)%>, is required "
2074 "besides the coarray designator %<[...]%> at %C");
2077 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
2078 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2079 && !CLASS_DATA (sym
)->attr
.codimension
))
2081 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2087 if (sym
->assoc
&& sym
->assoc
->target
)
2088 tgt_expr
= sym
->assoc
->target
;
2090 /* For associate names, we may not yet know whether they are arrays or not.
2091 If the selector expression is unambiguously an array; eg. a full array
2092 or an array section, then the associate name must be an array and we can
2093 fix it now. Otherwise, if parentheses follow and it is not a character
2094 type, we have to assume that it actually is one for now. The final
2095 decision will be made at resolution, of course. */
2097 && gfc_peek_ascii_char () == '('
2098 && sym
->ts
.type
!= BT_CLASS
2099 && !sym
->attr
.dimension
)
2101 gfc_ref
*ref
= NULL
;
2103 if (!sym
->assoc
->dangling
&& tgt_expr
)
2105 if (tgt_expr
->expr_type
== EXPR_VARIABLE
)
2106 gfc_resolve_expr (tgt_expr
);
2108 ref
= tgt_expr
->ref
;
2109 for (; ref
; ref
= ref
->next
)
2110 if (ref
->type
== REF_ARRAY
2111 && (ref
->u
.ar
.type
== AR_FULL
2112 || ref
->u
.ar
.type
== AR_SECTION
))
2116 if (ref
|| (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
2118 && sym
->assoc
->st
->n
.sym
2119 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
2121 sym
->attr
.dimension
= 1;
2124 && sym
->assoc
->st
->n
.sym
2125 && sym
->assoc
->st
->n
.sym
->as
)
2126 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
2129 else if (sym
->ts
.type
== BT_CLASS
2131 && tgt_expr
->expr_type
== EXPR_VARIABLE
2132 && sym
->ts
.u
.derived
!= tgt_expr
->ts
.u
.derived
)
2134 gfc_resolve_expr (tgt_expr
);
2136 sym
->ts
.u
.derived
= tgt_expr
->ts
.u
.derived
;
2139 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
2140 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
2141 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
2142 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
2143 && !(gfc_matching_procptr_assignment
2144 && sym
->attr
.flavor
== FL_PROCEDURE
))
2145 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2146 && sym
->ts
.u
.derived
&& CLASS_DATA (sym
)
2147 && (CLASS_DATA (sym
)->attr
.dimension
2148 || CLASS_DATA (sym
)->attr
.codimension
)))
2152 tail
= extend_ref (primary
, tail
);
2153 tail
->type
= REF_ARRAY
;
2155 /* In EQUIVALENCE, we don't know yet whether we are seeing
2156 an array, character variable or array of character
2157 variables. We'll leave the decision till resolve time. */
2161 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2162 as
= CLASS_DATA (sym
)->as
;
2166 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
2167 as
? as
->corank
: 0);
2171 gfc_gobble_whitespace ();
2172 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
2174 tail
= extend_ref (primary
, tail
);
2175 tail
->type
= REF_ARRAY
;
2177 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2183 primary
->ts
= sym
->ts
;
2188 /* With DEC extensions, member separator may be '.' or '%'. */
2189 sep
= gfc_peek_ascii_char ();
2190 m
= gfc_match_member_sep (sym
);
2191 if (m
== MATCH_ERROR
)
2195 if (m
== MATCH_YES
&& sep
== '%'
2196 && primary
->ts
.type
!= BT_CLASS
2197 && primary
->ts
.type
!= BT_DERIVED
)
2200 old_loc
= gfc_current_locus
;
2201 mm
= gfc_match_name (name
);
2202 if (mm
== MATCH_YES
&& is_inquiry_ref (name
, &tmp
))
2204 gfc_current_locus
= old_loc
;
2207 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2208 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2209 gfc_set_default_type (sym
, 0, sym
->ns
);
2211 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2212 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2216 /* These target expressions can be resolved at any time. */
2217 permissible
= tgt_expr
&& tgt_expr
->symtree
&& tgt_expr
->symtree
->n
.sym
2218 && (tgt_expr
->symtree
->n
.sym
->attr
.use_assoc
2219 || tgt_expr
->symtree
->n
.sym
->attr
.host_assoc
2220 || tgt_expr
->symtree
->n
.sym
->attr
.if_source
2222 permissible
= permissible
2223 || (tgt_expr
&& tgt_expr
->expr_type
== EXPR_OP
);
2227 gfc_resolve_expr (tgt_expr
);
2228 sym
->ts
= tgt_expr
->ts
;
2231 if (sym
->ts
.type
== BT_UNKNOWN
)
2233 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2237 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2238 && m
== MATCH_YES
&& !inquiry
)
2240 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2245 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
&& !inquiry
)
2247 goto check_substring
;
2250 sym
= sym
->ts
.u
.derived
;
2259 m
= gfc_match_name (name
);
2261 gfc_error ("Expected structure component name at %C");
2266 if (primary
->ts
.type
!= BT_CLASS
&& primary
->ts
.type
!= BT_DERIVED
)
2268 inquiry
= is_inquiry_ref (name
, &tmp
);
2280 if (!gfc_notify_std (GFC_STD_F2008
,
2281 "RE or IM part_ref at %C"))
2286 if (!gfc_notify_std (GFC_STD_F2003
,
2287 "KIND part_ref at %C"))
2292 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2297 if ((tmp
->u
.i
== INQUIRY_RE
|| tmp
->u
.i
== INQUIRY_IM
)
2298 && primary
->ts
.type
!= BT_COMPLEX
)
2300 gfc_error ("The RE or IM part_ref at %C must be "
2301 "applied to a COMPLEX expression");
2304 else if (tmp
->u
.i
== INQUIRY_LEN
2305 && primary
->ts
.type
!= BT_CHARACTER
)
2307 gfc_error ("The LEN part_ref at %C must be applied "
2308 "to a CHARACTER expression");
2312 if (primary
->ts
.type
!= BT_UNKNOWN
)
2319 if (sym
&& sym
->f2k_derived
)
2320 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2326 gfc_symbol
* tbp_sym
;
2331 gcc_assert (!tail
|| !tail
->next
);
2333 if (!(primary
->expr_type
== EXPR_VARIABLE
2334 || (primary
->expr_type
== EXPR_STRUCTURE
2335 && primary
->symtree
&& primary
->symtree
->n
.sym
2336 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2339 if (tbp
->n
.tb
->is_generic
)
2342 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2344 primary
->expr_type
= EXPR_COMPCALL
;
2345 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2346 primary
->value
.compcall
.name
= tbp
->name
;
2347 primary
->value
.compcall
.ignore_pass
= 0;
2348 primary
->value
.compcall
.assign
= 0;
2349 primary
->value
.compcall
.base_object
= NULL
;
2350 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2352 primary
->ts
= tbp_sym
->ts
;
2354 gfc_clear_ts (&primary
->ts
);
2356 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2357 &primary
->value
.compcall
.actual
);
2358 if (m
== MATCH_ERROR
)
2363 primary
->value
.compcall
.actual
= NULL
;
2366 gfc_error ("Expected argument list at %C");
2374 previous
= component
;
2376 if (!inquiry
&& !intrinsic
)
2377 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2381 if (intrinsic
&& !inquiry
)
2384 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2385 "type component %qs", name
, previous
->name
);
2387 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2388 "type component", name
);
2391 else if (component
== NULL
&& !inquiry
)
2394 /* Extend the reference chain determined by gfc_find_component or
2396 if (primary
->ref
== NULL
)
2400 /* Set by the for loop below for the last component ref. */
2401 gcc_assert (tail
!= NULL
);
2405 /* The reference chain may be longer than one hop for union
2406 subcomponents; find the new tail. */
2407 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2410 if (tmp
&& tmp
->type
== REF_INQUIRY
)
2412 if (!primary
->where
.lb
|| !primary
->where
.nextc
)
2413 primary
->where
= gfc_current_locus
;
2414 gfc_simplify_expr (primary
, 0);
2416 if (primary
->expr_type
== EXPR_CONSTANT
)
2423 if (!gfc_notify_std (GFC_STD_F2008
, "RE or IM part_ref at %C"))
2426 if (primary
->ts
.type
!= BT_COMPLEX
)
2428 gfc_error ("The RE or IM part_ref at %C must be "
2429 "applied to a COMPLEX expression");
2432 primary
->ts
.type
= BT_REAL
;
2436 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2439 if (primary
->ts
.type
!= BT_CHARACTER
)
2441 gfc_error ("The LEN part_ref at %C must be applied "
2442 "to a CHARACTER expression");
2445 primary
->ts
.u
.cl
= NULL
;
2446 primary
->ts
.type
= BT_INTEGER
;
2447 primary
->ts
.kind
= gfc_default_integer_kind
;
2451 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
2454 if (primary
->ts
.type
== BT_CLASS
2455 || primary
->ts
.type
== BT_DERIVED
)
2457 gfc_error ("The KIND part_ref at %C must be applied "
2458 "to an expression of intrinsic type");
2461 primary
->ts
.type
= BT_INTEGER
;
2462 primary
->ts
.kind
= gfc_default_integer_kind
;
2472 primary
->ts
= component
->ts
;
2474 if (component
->attr
.proc_pointer
&& ppc_arg
)
2476 /* Procedure pointer component call: Look for argument list. */
2477 m
= gfc_match_actual_arglist (sub_flag
,
2478 &primary
->value
.compcall
.actual
);
2479 if (m
== MATCH_ERROR
)
2482 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2483 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2485 gfc_error ("Procedure pointer component %qs requires an "
2486 "argument list at %C", component
->name
);
2491 primary
->expr_type
= EXPR_PPC
;
2496 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2498 tail
= extend_ref (primary
, tail
);
2499 tail
->type
= REF_ARRAY
;
2501 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2502 component
->as
->corank
);
2506 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2507 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2509 tail
= extend_ref (primary
, tail
);
2510 tail
->type
= REF_ARRAY
;
2512 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2514 CLASS_DATA (component
)->as
->corank
);
2520 /* In principle, we could have eg. expr%re%kind so we must allow for
2521 this possibility. */
2522 if (gfc_match_char ('%') == MATCH_YES
)
2524 if (component
&& (component
->ts
.type
== BT_DERIVED
2525 || component
->ts
.type
== BT_CLASS
))
2526 sym
= component
->ts
.u
.derived
;
2532 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2533 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2536 if (component
->ts
.type
== BT_DERIVED
|| component
->ts
.type
== BT_CLASS
)
2537 sym
= component
->ts
.u
.derived
;
2542 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2544 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2546 gfc_set_default_type (sym
, 0, sym
->ns
);
2547 primary
->ts
= sym
->ts
;
2552 if (primary
->ts
.type
== BT_CHARACTER
)
2554 bool def
= primary
->ts
.deferred
== 1;
2555 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2559 primary
->ref
= substring
;
2561 tail
->next
= substring
;
2563 if (primary
->expr_type
== EXPR_CONSTANT
)
2564 primary
->expr_type
= EXPR_SUBSTRING
;
2567 primary
->ts
.u
.cl
= NULL
;
2574 gfc_clear_ts (&primary
->ts
);
2575 gfc_clear_ts (&sym
->ts
);
2585 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2586 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2588 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2593 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2595 gfc_error ("Coindexed procedure-pointer component at %C");
2603 /* Given an expression that is a variable, figure out what the
2604 ultimate variable's type and attribute is, traversing the reference
2605 structures if necessary.
2607 This subroutine is trickier than it looks. We start at the base
2608 symbol and store the attribute. Component references load a
2609 completely new attribute.
2611 A couple of rules come into play. Subobjects of targets are always
2612 targets themselves. If we see a component that goes through a
2613 pointer, then the expression must also be a target, since the
2614 pointer is associated with something (if it isn't core will soon be
2615 dumped). If we see a full part or section of an array, the
2616 expression is also an array.
2618 We can have at most one full array reference. */
2621 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2623 int dimension
, codimension
, pointer
, allocatable
, target
, optional
;
2624 symbol_attribute attr
;
2627 gfc_component
*comp
;
2628 bool has_inquiry_part
;
2630 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2631 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2633 sym
= expr
->symtree
->n
.sym
;
2636 optional
= attr
.optional
;
2637 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& sym
->ts
.u
.derived
)
2639 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2640 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2641 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2642 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2646 dimension
= attr
.dimension
;
2647 codimension
= attr
.codimension
;
2648 pointer
= attr
.pointer
;
2649 allocatable
= attr
.allocatable
;
2652 target
= attr
.target
;
2653 if (pointer
|| attr
.proc_pointer
)
2656 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2659 has_inquiry_part
= false;
2660 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2661 if (ref
->type
== REF_INQUIRY
)
2663 has_inquiry_part
= true;
2668 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2673 switch (ref
->u
.ar
.type
)
2680 allocatable
= pointer
= 0;
2686 /* Handle coarrays. */
2687 if (ref
->u
.ar
.dimen
> 0)
2688 allocatable
= pointer
= optional
= false;
2692 /* For standard conforming code, AR_UNKNOWN should not happen.
2693 For nonconforming code, gfortran can end up here. Treat it
2702 comp
= ref
->u
.c
.component
;
2704 if (ts
!= NULL
&& !has_inquiry_part
)
2707 /* Don't set the string length if a substring reference
2709 if (ts
->type
== BT_CHARACTER
2710 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2714 if (comp
->ts
.type
== BT_CLASS
)
2716 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2717 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2718 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2722 codimension
= comp
->attr
.codimension
;
2723 if (expr
->ts
.type
== BT_CLASS
&& strcmp (comp
->name
, "_data") == 0)
2724 pointer
= comp
->attr
.class_pointer
;
2726 pointer
= comp
->attr
.pointer
;
2727 allocatable
= comp
->attr
.allocatable
;
2729 if (pointer
|| attr
.proc_pointer
)
2736 allocatable
= pointer
= optional
= false;
2740 attr
.dimension
= dimension
;
2741 attr
.codimension
= codimension
;
2742 attr
.pointer
= pointer
;
2743 attr
.allocatable
= allocatable
;
2744 attr
.target
= target
;
2745 attr
.save
= sym
->attr
.save
;
2746 attr
.optional
= optional
;
2752 /* Return the attribute from a general expression. */
2755 gfc_expr_attr (gfc_expr
*e
)
2757 symbol_attribute attr
;
2759 switch (e
->expr_type
)
2762 attr
= gfc_variable_attr (e
, NULL
);
2766 gfc_clear_attr (&attr
);
2768 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2770 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2772 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2774 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2775 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2776 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2779 else if (e
->value
.function
.isym
2780 && e
->value
.function
.isym
->transformational
2781 && e
->ts
.type
== BT_CLASS
)
2782 attr
= CLASS_DATA (e
)->attr
;
2783 else if (e
->symtree
)
2784 attr
= gfc_variable_attr (e
, NULL
);
2786 /* TODO: NULL() returns pointers. May have to take care of this
2792 gfc_clear_attr (&attr
);
2800 /* Given an expression, figure out what the ultimate expression
2801 attribute is. This routine is similar to gfc_variable_attr with
2802 parts of gfc_expr_attr, but focuses more on the needs of
2803 coarrays. For coarrays a codimension attribute is kind of
2804 "infectious" being propagated once set and never cleared.
2805 The coarray_comp is only set, when the expression refs a coarray
2806 component. REFS_COMP is set when present to true only, when this EXPR
2807 refs a (non-_data) component. To check whether EXPR refs an allocatable
2808 component in a derived type coarray *refs_comp needs to be set and
2809 coarray_comp has to false. */
2811 static symbol_attribute
2812 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2814 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2815 symbol_attribute attr
;
2818 gfc_component
*comp
;
2820 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2821 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2823 sym
= expr
->symtree
->n
.sym
;
2824 gfc_clear_attr (&attr
);
2829 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2831 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2832 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2833 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2834 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2835 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2836 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2840 dimension
= sym
->attr
.dimension
;
2841 codimension
= sym
->attr
.codimension
;
2842 pointer
= sym
->attr
.pointer
;
2843 allocatable
= sym
->attr
.allocatable
;
2844 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2845 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2846 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2847 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2850 target
= coarray_comp
= 0;
2851 if (pointer
|| attr
.proc_pointer
)
2854 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2859 switch (ref
->u
.ar
.type
)
2867 /* Handle coarrays. */
2868 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2869 allocatable
= pointer
= 0;
2873 /* If any of start, end or stride is not integer, there will
2874 already have been an error issued. */
2876 gfc_get_errors (NULL
, &errors
);
2878 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2884 comp
= ref
->u
.c
.component
;
2886 if (comp
->ts
.type
== BT_CLASS
)
2888 /* Set coarray_comp only, when this component introduces the
2890 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2891 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2892 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2893 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2897 /* Set coarray_comp only, when this component introduces the
2899 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2900 codimension
|= comp
->attr
.codimension
;
2901 pointer
= comp
->attr
.pointer
;
2902 allocatable
= comp
->attr
.allocatable
;
2905 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2906 && (ref
->next
== NULL
2907 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2910 if (pointer
|| attr
.proc_pointer
)
2917 allocatable
= pointer
= 0;
2921 attr
.dimension
= dimension
;
2922 attr
.codimension
= codimension
;
2923 attr
.pointer
= pointer
;
2924 attr
.allocatable
= allocatable
;
2925 attr
.target
= target
;
2926 attr
.save
= sym
->attr
.save
;
2927 attr
.coarray_comp
= coarray_comp
;
2934 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2936 symbol_attribute attr
;
2938 switch (e
->expr_type
)
2941 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2945 gfc_clear_attr (&attr
);
2947 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2949 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2951 if (sym
->ts
.type
== BT_CLASS
)
2953 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2954 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2955 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2956 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2957 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2958 ->attr
.pointer_comp
;
2961 else if (e
->symtree
)
2962 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2964 gfc_clear_attr (&attr
);
2968 gfc_clear_attr (&attr
);
2976 /* Match a structure constructor. The initial symbol has already been
2979 typedef struct gfc_structure_ctor_component
2984 struct gfc_structure_ctor_component
* next
;
2986 gfc_structure_ctor_component
;
2988 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2991 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2994 gfc_free_expr (comp
->val
);
2999 /* Translate the component list into the actual constructor by sorting it in
3000 the order required; this also checks along the way that each and every
3001 component actually has an initializer and handles default initializers
3002 for components without explicit value given. */
3004 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
3005 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
3007 gfc_structure_ctor_component
*comp_iter
;
3008 gfc_component
*comp
;
3010 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
3012 gfc_structure_ctor_component
**next_ptr
;
3013 gfc_expr
*value
= NULL
;
3015 /* Try to find the initializer for the current component by name. */
3016 next_ptr
= comp_head
;
3017 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3019 if (!strcmp (comp_iter
->name
, comp
->name
))
3021 next_ptr
= &comp_iter
->next
;
3024 /* If an extension, try building the parent derived type by building
3025 a value expression for the parent derived type and calling self. */
3026 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
3028 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
3030 &gfc_current_locus
);
3031 value
->ts
= comp
->ts
;
3033 if (!build_actual_constructor (comp_head
,
3034 &value
->value
.constructor
,
3035 comp
->ts
.u
.derived
))
3037 gfc_free_expr (value
);
3041 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3045 /* If it was not found, apply NULL expression to set the component as
3046 unallocated. Then try the default initializer if there's any;
3047 otherwise, it's an error unless this is a deferred parameter. */
3050 /* F2018 7.5.10: If an allocatable component has no corresponding
3051 component-data-source, then that component has an allocation
3052 status of unallocated.... */
3053 if (comp
->attr
.allocatable
3054 || (comp
->ts
.type
== BT_CLASS
3055 && CLASS_DATA (comp
)->attr
.allocatable
))
3057 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
3058 "allocatable component %qs given in the "
3059 "structure constructor at %C", comp
->name
))
3061 value
= gfc_get_null_expr (&gfc_current_locus
);
3063 /* ....(Preceding sentence) If a component with default
3064 initialization has no corresponding component-data-source, then
3065 the default initialization is applied to that component. */
3066 else if (comp
->initializer
)
3068 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
3069 "with missing optional arguments at %C"))
3071 value
= gfc_copy_expr (comp
->initializer
);
3073 /* Do not trap components such as the string length for deferred
3074 length character components. */
3075 else if (!comp
->attr
.artificial
)
3077 gfc_error ("No initializer for component %qs given in the"
3078 " structure constructor at %C", comp
->name
);
3083 value
= comp_iter
->val
;
3085 /* Add the value to the constructor chain built. */
3086 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3088 /* Remove the entry from the component list. We don't want the expression
3089 value to be free'd, so set it to NULL. */
3092 *next_ptr
= comp_iter
->next
;
3093 comp_iter
->val
= NULL
;
3094 gfc_free_structure_ctor_component (comp_iter
);
3102 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
3103 gfc_actual_arglist
**arglist
,
3106 gfc_actual_arglist
*actual
;
3107 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
3108 gfc_constructor_base ctor_head
= NULL
;
3109 gfc_component
*comp
; /* Is set NULL when named component is first seen */
3110 const char* last_name
= NULL
;
3114 expr
= parent
? *cexpr
: e
;
3115 old_locus
= gfc_current_locus
;
3117 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3119 gfc_current_locus
= expr
->where
;
3121 comp_tail
= comp_head
= NULL
;
3123 if (!parent
&& sym
->attr
.abstract
)
3125 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3126 sym
->name
, &expr
->where
);
3130 comp
= sym
->components
;
3131 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
3134 gfc_component
*this_comp
= NULL
;
3137 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
3140 comp_tail
->next
= gfc_get_structure_ctor_component ();
3141 comp_tail
= comp_tail
->next
;
3145 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
3146 " constructor with named arguments at %C"))
3149 comp_tail
->name
= xstrdup (actual
->name
);
3150 last_name
= comp_tail
->name
;
3155 /* Components without name are not allowed after the first named
3156 component initializer! */
3157 if (!comp
|| comp
->attr
.artificial
)
3160 gfc_error ("Component initializer without name after component"
3161 " named %s at %L", last_name
,
3162 actual
->expr
? &actual
->expr
->where
3163 : &gfc_current_locus
);
3165 gfc_error ("Too many components in structure constructor at "
3166 "%L", actual
->expr
? &actual
->expr
->where
3167 : &gfc_current_locus
);
3171 comp_tail
->name
= xstrdup (comp
->name
);
3174 /* Find the current component in the structure definition and check
3175 its access is not private. */
3177 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
3180 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
3181 false, false, NULL
);
3182 comp
= NULL
; /* Reset needed! */
3185 /* Here we can check if a component name is given which does not
3186 correspond to any component of the defined structure. */
3190 /* For a constant string constructor, make sure the length is
3191 correct; truncate or fill with blanks if needed. */
3192 if (this_comp
->ts
.type
== BT_CHARACTER
&& !this_comp
->attr
.allocatable
3193 && this_comp
->ts
.u
.cl
&& this_comp
->ts
.u
.cl
->length
3194 && this_comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3195 && this_comp
->ts
.u
.cl
->length
->ts
.type
== BT_INTEGER
3196 && actual
->expr
->ts
.type
== BT_CHARACTER
3197 && actual
->expr
->expr_type
== EXPR_CONSTANT
)
3200 c
= gfc_mpz_get_hwi (this_comp
->ts
.u
.cl
->length
->value
.integer
);
3201 e1
= actual
->expr
->value
.character
.length
;
3207 dest
= gfc_get_wide_string (c
+ 1);
3209 to
= e1
< c
? e1
: c
;
3210 for (i
= 0; i
< to
; i
++)
3211 dest
[i
] = actual
->expr
->value
.character
.string
[i
];
3213 for (i
= e1
; i
< c
; i
++)
3217 free (actual
->expr
->value
.character
.string
);
3219 actual
->expr
->value
.character
.length
= c
;
3220 actual
->expr
->value
.character
.string
= dest
;
3222 if (warn_line_truncation
&& c
< e1
)
3223 gfc_warning_now (OPT_Wcharacter_truncation
,
3224 "CHARACTER expression will be truncated "
3225 "in constructor (%ld/%ld) at %L", (long int) c
,
3226 (long int) e1
, &actual
->expr
->where
);
3230 comp_tail
->val
= actual
->expr
;
3231 if (actual
->expr
!= NULL
)
3232 comp_tail
->where
= actual
->expr
->where
;
3233 actual
->expr
= NULL
;
3235 /* Check if this component is already given a value. */
3236 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
3237 comp_iter
= comp_iter
->next
)
3239 gcc_assert (comp_iter
);
3240 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
3242 gfc_error ("Component %qs is initialized twice in the structure"
3243 " constructor at %L", comp_tail
->name
,
3244 comp_tail
->val
? &comp_tail
->where
3245 : &gfc_current_locus
);
3250 /* F2008, R457/C725, for PURE C1283. */
3251 if (this_comp
->attr
.pointer
&& comp_tail
->val
3252 && gfc_is_coindexed (comp_tail
->val
))
3254 gfc_error ("Coindexed expression to pointer component %qs in "
3255 "structure constructor at %L", comp_tail
->name
,
3260 /* If not explicitly a parent constructor, gather up the components
3262 if (comp
&& comp
== sym
->components
3263 && sym
->attr
.extension
3265 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
3267 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
3270 gfc_actual_arglist
*arg_null
= NULL
;
3272 actual
->expr
= comp_tail
->val
;
3273 comp_tail
->val
= NULL
;
3275 m
= gfc_convert_to_structure_constructor (NULL
,
3276 comp
->ts
.u
.derived
, &comp_tail
->val
,
3277 comp
->ts
.u
.derived
->attr
.zero_comp
3278 ? &arg_null
: &actual
, true);
3282 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
3291 if (parent
&& !comp
)
3295 actual
= actual
->next
;
3298 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
3301 /* No component should be left, as this should have caused an error in the
3302 loop constructing the component-list (name that does not correspond to any
3303 component in the structure definition). */
3304 if (comp_head
&& sym
->attr
.extension
)
3306 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3308 gfc_error ("component %qs at %L has already been set by a "
3309 "parent derived type constructor", comp_iter
->name
,
3315 gcc_assert (!comp_head
);
3319 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
3320 expr
->ts
.u
.derived
= sym
;
3321 expr
->value
.constructor
= ctor_head
;
3326 expr
->ts
.u
.derived
= sym
;
3328 expr
->ts
.type
= BT_DERIVED
;
3329 expr
->value
.constructor
= ctor_head
;
3330 expr
->expr_type
= EXPR_STRUCTURE
;
3333 gfc_current_locus
= old_locus
;
3339 gfc_current_locus
= old_locus
;
3341 for (comp_iter
= comp_head
; comp_iter
; )
3343 gfc_structure_ctor_component
*next
= comp_iter
->next
;
3344 gfc_free_structure_ctor_component (comp_iter
);
3347 gfc_constructor_free (ctor_head
);
3354 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
3358 gfc_symtree
*symtree
;
3361 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
3363 e
= gfc_get_expr ();
3364 e
->symtree
= symtree
;
3365 e
->expr_type
= EXPR_FUNCTION
;
3366 e
->where
= gfc_current_locus
;
3368 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
3369 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
3370 e
->value
.function
.esym
= sym
;
3371 e
->symtree
->n
.sym
->attr
.generic
= 1;
3373 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3380 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
3386 /* If a structure constructor is in a DATA statement, then each entity
3387 in the structure constructor must be a constant. Try to reduce the
3389 if (gfc_in_match_data ())
3390 t
= gfc_reduce_init_expr (e
);
3405 /* If the symbol is an implicit do loop index and implicitly typed,
3406 it should not be host associated. Provide a symtree from the
3407 current namespace. */
3409 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
3411 if ((*sym
)->attr
.flavor
== FL_VARIABLE
3412 && (*sym
)->ns
!= gfc_current_ns
3413 && (*sym
)->attr
.implied_index
3414 && (*sym
)->attr
.implicit_type
3415 && !(*sym
)->attr
.use_assoc
)
3418 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
3421 *sym
= (*st
)->n
.sym
;
3427 /* Procedure pointer as function result: Replace the function symbol by the
3428 auto-generated hidden result variable named "ppr@". */
3431 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
3433 /* Check for procedure pointer result variable. */
3434 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
3435 && (*sym
)->result
&& (*sym
)->result
!= *sym
3436 && (*sym
)->result
->attr
.proc_pointer
3437 && (*sym
) == gfc_current_ns
->proc_name
3438 && (*sym
) == (*sym
)->result
->ns
->proc_name
3439 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3441 /* Automatic replacement with "hidden" result variable. */
3442 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3443 *sym
= (*sym
)->result
;
3444 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3451 /* Matches a variable name followed by anything that might follow it--
3452 array reference, argument list of a function, etc. */
3455 gfc_match_rvalue (gfc_expr
**result
)
3457 gfc_actual_arglist
*actual_arglist
;
3458 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3461 gfc_symtree
*symtree
;
3462 locus where
, old_loc
;
3470 m
= gfc_match ("%%loc");
3473 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3475 strncpy (name
, "loc", 4);
3480 m
= gfc_match_name (name
);
3485 /* Check if the symbol exists. */
3486 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3489 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3490 type. For derived types we create a generic symbol which links to the
3491 derived type symbol; STRUCTUREs are simpler and must not conflict with
3494 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3496 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3498 if (gfc_find_state (COMP_INTERFACE
)
3499 && !gfc_current_ns
->has_import_set
)
3500 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3502 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3508 sym
= symtree
->n
.sym
;
3510 where
= gfc_current_locus
;
3512 replace_hidden_procptr_result (&sym
, &symtree
);
3514 /* If this is an implicit do loop index and implicitly typed,
3515 it should not be host associated. */
3516 m
= check_for_implicit_index (&symtree
, &sym
);
3520 gfc_set_sym_referenced (sym
);
3521 sym
->attr
.implied_index
= 0;
3523 if (sym
->attr
.function
&& sym
->result
== sym
)
3525 /* See if this is a directly recursive function call. */
3526 gfc_gobble_whitespace ();
3527 if (sym
->attr
.recursive
3528 && gfc_peek_ascii_char () == '('
3529 && gfc_current_ns
->proc_name
== sym
3530 && !sym
->attr
.dimension
)
3532 gfc_error ("%qs at %C is the name of a recursive function "
3533 "and so refers to the result variable. Use an "
3534 "explicit RESULT variable for direct recursion "
3535 "(12.5.2.1)", sym
->name
);
3539 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3543 && (sym
->ns
== gfc_current_ns
3544 || sym
->ns
== gfc_current_ns
->parent
))
3546 gfc_entry_list
*el
= NULL
;
3548 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3554 if (gfc_matching_procptr_assignment
)
3556 /* It can be a procedure or a derived-type procedure or a not-yet-known
3558 if (sym
->attr
.flavor
!= FL_UNKNOWN
3559 && sym
->attr
.flavor
!= FL_PROCEDURE
3560 && sym
->attr
.flavor
!= FL_PARAMETER
3561 && sym
->attr
.flavor
!= FL_VARIABLE
)
3563 gfc_error ("Symbol at %C is not appropriate for an expression");
3569 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3572 if (sym
->attr
.generic
)
3573 goto generic_function
;
3575 switch (sym
->attr
.flavor
)
3579 e
= gfc_get_expr ();
3581 e
->expr_type
= EXPR_VARIABLE
;
3582 e
->symtree
= symtree
;
3584 m
= gfc_match_varspec (e
, 0, false, true);
3588 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3589 end up here. Unfortunately, sym->value->expr_type is set to
3590 EXPR_CONSTANT, and so the if () branch would be followed without
3591 the !sym->as check. */
3592 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3593 e
= gfc_copy_expr (sym
->value
);
3596 e
= gfc_get_expr ();
3597 e
->expr_type
= EXPR_VARIABLE
;
3600 e
->symtree
= symtree
;
3601 m
= gfc_match_varspec (e
, 0, false, true);
3603 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3606 /* Variable array references to derived type parameters cause
3607 all sorts of headaches in simplification. Treating such
3608 expressions as variable works just fine for all array
3610 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3612 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3613 if (ref
->type
== REF_ARRAY
)
3616 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3622 e
= gfc_get_expr ();
3623 e
->expr_type
= EXPR_VARIABLE
;
3624 e
->symtree
= symtree
;
3632 sym
= gfc_use_derived (sym
);
3636 goto generic_function
;
3639 /* If we're here, then the name is known to be the name of a
3640 procedure, yet it is not sure to be the name of a function. */
3643 /* Procedure Pointer Assignments. */
3645 if (gfc_matching_procptr_assignment
)
3647 gfc_gobble_whitespace ();
3648 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3649 /* Parse functions returning a procptr. */
3652 e
= gfc_get_expr ();
3653 e
->expr_type
= EXPR_VARIABLE
;
3654 e
->symtree
= symtree
;
3655 m
= gfc_match_varspec (e
, 0, false, true);
3656 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3657 && sym
->ts
.type
== BT_UNKNOWN
3658 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3666 if (sym
->attr
.subroutine
)
3668 gfc_error ("Unexpected use of subroutine name %qs at %C",
3674 /* At this point, the name has to be a non-statement function.
3675 If the name is the same as the current function being
3676 compiled, then we have a variable reference (to the function
3677 result) if the name is non-recursive. */
3679 st
= gfc_enclosing_unit (NULL
);
3682 && st
->state
== COMP_FUNCTION
3684 && !sym
->attr
.recursive
)
3686 e
= gfc_get_expr ();
3687 e
->symtree
= symtree
;
3688 e
->expr_type
= EXPR_VARIABLE
;
3690 m
= gfc_match_varspec (e
, 0, false, true);
3694 /* Match a function reference. */
3696 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3699 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3700 gfc_error ("Statement function %qs requires argument list at %C",
3703 gfc_error ("Function %qs requires an argument list at %C",
3716 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3717 sym
= symtree
->n
.sym
;
3719 replace_hidden_procptr_result (&sym
, &symtree
);
3721 e
= gfc_get_expr ();
3722 e
->symtree
= symtree
;
3723 e
->expr_type
= EXPR_FUNCTION
;
3724 e
->value
.function
.actual
= actual_arglist
;
3725 e
->where
= gfc_current_locus
;
3727 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3728 && CLASS_DATA (sym
)->as
)
3729 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3730 else if (sym
->as
!= NULL
)
3731 e
->rank
= sym
->as
->rank
;
3733 if (!sym
->attr
.function
3734 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3740 /* Check here for the existence of at least one argument for the
3741 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3742 argument(s) given will be checked in gfc_iso_c_func_interface,
3743 during resolution of the function call. */
3744 if (sym
->attr
.is_iso_c
== 1
3745 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3746 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3747 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3748 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3750 /* make sure we were given a param */
3751 if (actual_arglist
== NULL
)
3753 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3759 if (sym
->result
== NULL
)
3762 gfc_gobble_whitespace ();
3764 if (gfc_peek_ascii_char() == '%')
3766 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3767 "function reference at %C");
3777 /* Special case for derived type variables that get their types
3778 via an IMPLICIT statement. This can't wait for the
3779 resolution phase. */
3781 old_loc
= gfc_current_locus
;
3782 if (gfc_match_member_sep (sym
) == MATCH_YES
3783 && sym
->ts
.type
== BT_UNKNOWN
3784 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3785 gfc_set_default_type (sym
, 0, sym
->ns
);
3786 gfc_current_locus
= old_loc
;
3788 /* If the symbol has a (co)dimension attribute, the expression is a
3791 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3793 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3799 e
= gfc_get_expr ();
3800 e
->symtree
= symtree
;
3801 e
->expr_type
= EXPR_VARIABLE
;
3802 m
= gfc_match_varspec (e
, 0, false, true);
3806 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3807 && (CLASS_DATA (sym
)->attr
.dimension
3808 || CLASS_DATA (sym
)->attr
.codimension
))
3810 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3816 e
= gfc_get_expr ();
3817 e
->symtree
= symtree
;
3818 e
->expr_type
= EXPR_VARIABLE
;
3819 m
= gfc_match_varspec (e
, 0, false, true);
3823 /* Name is not an array, so we peek to see if a '(' implies a
3824 function call or a substring reference. Otherwise the
3825 variable is just a scalar. */
3827 gfc_gobble_whitespace ();
3828 if (gfc_peek_ascii_char () != '(')
3830 /* Assume a scalar variable */
3831 e
= gfc_get_expr ();
3832 e
->symtree
= symtree
;
3833 e
->expr_type
= EXPR_VARIABLE
;
3835 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3841 /*FIXME:??? gfc_match_varspec does set this for us: */
3843 m
= gfc_match_varspec (e
, 0, false, true);
3847 /* See if this is a function reference with a keyword argument
3848 as first argument. We do this because otherwise a spurious
3849 symbol would end up in the symbol table. */
3851 old_loc
= gfc_current_locus
;
3852 m2
= gfc_match (" ( %n =", argname
);
3853 gfc_current_locus
= old_loc
;
3855 e
= gfc_get_expr ();
3856 e
->symtree
= symtree
;
3858 if (m2
!= MATCH_YES
)
3860 /* Try to figure out whether we're dealing with a character type.
3861 We're peeking ahead here, because we don't want to call
3862 match_substring if we're dealing with an implicitly typed
3863 non-character variable. */
3864 implicit_char
= false;
3865 if (sym
->ts
.type
== BT_UNKNOWN
)
3867 ts
= gfc_get_default_type (sym
->name
, NULL
);
3868 if (ts
->type
== BT_CHARACTER
)
3869 implicit_char
= true;
3872 /* See if this could possibly be a substring reference of a name
3873 that we're not sure is a variable yet. */
3875 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3876 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3879 e
->expr_type
= EXPR_VARIABLE
;
3881 if (sym
->attr
.flavor
!= FL_VARIABLE
3882 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3889 if (sym
->ts
.type
== BT_UNKNOWN
3890 && !gfc_set_default_type (sym
, 1, NULL
))
3904 /* Give up, assume we have a function. */
3906 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3907 sym
= symtree
->n
.sym
;
3908 e
->expr_type
= EXPR_FUNCTION
;
3910 if (!sym
->attr
.function
3911 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3919 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3921 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3929 /* If our new function returns a character, array or structure
3930 type, it might have subsequent references. */
3932 m
= gfc_match_varspec (e
, 0, false, true);
3939 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3940 specially. Creates a generic symbol for derived types. */
3941 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3943 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3944 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3945 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3947 e
= gfc_get_expr ();
3948 e
->symtree
= symtree
;
3949 e
->expr_type
= EXPR_FUNCTION
;
3951 if (gfc_fl_struct (sym
->attr
.flavor
))
3953 e
->value
.function
.esym
= sym
;
3954 e
->symtree
->n
.sym
->attr
.generic
= 1;
3957 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3965 gfc_error ("Symbol at %C is not appropriate for an expression");
3981 /* Match a variable, i.e. something that can be assigned to. This
3982 starts as a symbol, can be a structure component or an array
3983 reference. It can be a function if the function doesn't have a
3984 separate RESULT variable. If the symbol has not been previously
3985 seen, we assume it is a variable.
3987 This function is called by two interface functions:
3988 gfc_match_variable, which has host_flag = 1, and
3989 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3990 match of the symbol to the local scope. */
3993 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3995 gfc_symbol
*sym
, *dt_sym
;
3998 locus where
, old_loc
;
4001 /* Since nothing has any business being an lvalue in a module
4002 specification block, an interface block or a contains section,
4003 we force the changed_symbols mechanism to work by setting
4004 host_flag to 0. This prevents valid symbols that have the name
4005 of keywords, such as 'end', being turned into variables by
4006 failed matching to assignments for, e.g., END INTERFACE. */
4007 if (gfc_current_state () == COMP_MODULE
4008 || gfc_current_state () == COMP_SUBMODULE
4009 || gfc_current_state () == COMP_INTERFACE
4010 || gfc_current_state () == COMP_CONTAINS
)
4013 where
= gfc_current_locus
;
4014 m
= gfc_match_sym_tree (&st
, host_flag
);
4020 /* If this is an implicit do loop index and implicitly typed,
4021 it should not be host associated. */
4022 m
= check_for_implicit_index (&st
, &sym
);
4026 sym
->attr
.implied_index
= 0;
4028 gfc_set_sym_referenced (sym
);
4030 /* STRUCTUREs may share names with variables, but derived types may not. */
4031 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
4032 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
4034 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
4035 gfc_error ("Derived type %qs cannot be used as a variable at %C",
4040 switch (sym
->attr
.flavor
)
4043 /* Everything is alright. */
4048 sym_flavor flavor
= FL_UNKNOWN
;
4050 gfc_gobble_whitespace ();
4052 if (sym
->attr
.external
|| sym
->attr
.procedure
4053 || sym
->attr
.function
|| sym
->attr
.subroutine
)
4054 flavor
= FL_PROCEDURE
;
4056 /* If it is not a procedure, is not typed and is host associated,
4057 we cannot give it a flavor yet. */
4058 else if (sym
->ns
== gfc_current_ns
->parent
4059 && sym
->ts
.type
== BT_UNKNOWN
)
4062 /* These are definitive indicators that this is a variable. */
4063 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
4064 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
4065 flavor
= FL_VARIABLE
;
4067 if (flavor
!= FL_UNKNOWN
4068 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
4076 gfc_error ("Named constant at %C in an EQUIVALENCE");
4079 if (gfc_in_match_data())
4081 gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %C",
4085 /* Otherwise this is checked for an error given in the
4086 variable definition context checks. */
4090 /* Check for a nonrecursive function result variable. */
4091 if (sym
->attr
.function
4092 && !sym
->attr
.external
4093 && sym
->result
== sym
4094 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
4096 && sym
->ns
== gfc_current_ns
)
4098 && sym
->ns
== gfc_current_ns
->parent
)))
4100 /* If a function result is a derived type, then the derived
4101 type may still have to be resolved. */
4103 if (sym
->ts
.type
== BT_DERIVED
4104 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
4109 if (sym
->attr
.proc_pointer
4110 || replace_hidden_procptr_result (&sym
, &st
))
4113 /* Fall through to error */
4117 gfc_error ("%qs at %C is not a variable", sym
->name
);
4121 /* Special case for derived type variables that get their types
4122 via an IMPLICIT statement. This can't wait for the
4123 resolution phase. */
4126 gfc_namespace
* implicit_ns
;
4128 if (gfc_current_ns
->proc_name
== sym
)
4129 implicit_ns
= gfc_current_ns
;
4131 implicit_ns
= sym
->ns
;
4133 old_loc
= gfc_current_locus
;
4134 if (gfc_match_member_sep (sym
) == MATCH_YES
4135 && sym
->ts
.type
== BT_UNKNOWN
4136 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
4137 gfc_set_default_type (sym
, 0, implicit_ns
);
4138 gfc_current_locus
= old_loc
;
4141 expr
= gfc_get_expr ();
4143 expr
->expr_type
= EXPR_VARIABLE
;
4146 expr
->where
= where
;
4148 /* Now see if we have to do more. */
4149 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
4152 gfc_free_expr (expr
);
4162 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
4164 return match_variable (result
, equiv_flag
, 1);
4169 gfc_match_equiv_variable (gfc_expr
**result
)
4171 return match_variable (result
, 1, 0);