1 /* Primary expression subroutines
2 Copyright (C) 2000-2021 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
);
52 m
= gfc_match_name (name
);
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 ('_') != 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
);
674 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
678 kind
= gfc_default_double_kind
;
682 if (flag_real4_kind
== 8)
684 if (flag_real4_kind
== 10)
686 if (flag_real4_kind
== 16)
692 if (flag_real8_kind
== 4)
694 if (flag_real8_kind
== 10)
696 if (flag_real8_kind
== 16)
704 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
709 /* The maximum possible real kind type parameter is 16. First, try
710 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
711 extended precision. If neither value works, just given up. */
713 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
716 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
718 gfc_error ("Invalid exponent-letter %<q%> in "
719 "real-literal-constant at %C");
727 kind
= gfc_default_real_kind
;
731 if (flag_real4_kind
== 8)
733 if (flag_real4_kind
== 10)
735 if (flag_real4_kind
== 16)
741 if (flag_real8_kind
== 4)
743 if (flag_real8_kind
== 10)
745 if (flag_real8_kind
== 16)
749 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
751 gfc_error ("Invalid real kind %d at %C", kind
);
756 e
= convert_real (buffer
, kind
, &gfc_current_locus
);
758 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
759 e
->ts
.is_c_interop
= is_iso_c
;
761 switch (gfc_range_check (e
))
766 gfc_error ("Real constant overflows its kind at %C");
769 case ARITH_UNDERFLOW
:
771 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
772 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
776 gfc_internal_error ("gfc_range_check() returned bad value");
779 /* Warn about trailing digits which suggest the user added too many
780 trailing digits, which may cause the appearance of higher pecision
781 than the kind kan support.
783 This is done by replacing the rightmost non-zero digit with zero
784 and comparing with the original value. If these are equal, we
785 assume the user supplied more digits than intended (or forgot to
786 convert to the correct kind).
789 if (warn_conversion_extra
)
795 c1
= strchr (buffer
, 'e');
797 c1
= buffer
+ strlen(buffer
);
800 for (p
= c1
; p
> buffer
;)
817 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
819 mpfr_neg (r
, r
, GFC_RND_MODE
);
821 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
823 if (mpfr_cmp_ui (r
, 0) == 0)
824 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
825 "in %qs number at %C, maybe incorrect KIND",
826 gfc_typename (&e
->ts
));
841 /* Match a substring reference. */
844 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
, bool deferred
)
846 gfc_expr
*start
, *end
;
854 old_loc
= gfc_current_locus
;
856 m
= gfc_match_char ('(');
860 if (gfc_match_char (':') != MATCH_YES
)
863 m
= gfc_match_init_expr (&start
);
865 m
= gfc_match_expr (&start
);
873 m
= gfc_match_char (':');
878 if (gfc_match_char (')') != MATCH_YES
)
881 m
= gfc_match_init_expr (&end
);
883 m
= gfc_match_expr (&end
);
887 if (m
== MATCH_ERROR
)
890 m
= gfc_match_char (')');
895 /* Optimize away the (:) reference. */
896 if (start
== NULL
&& end
== NULL
&& !deferred
)
900 ref
= gfc_get_ref ();
902 ref
->type
= REF_SUBSTRING
;
904 start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
905 ref
->u
.ss
.start
= start
;
906 if (end
== NULL
&& cl
)
907 end
= gfc_copy_expr (cl
->length
);
909 ref
->u
.ss
.length
= cl
;
916 gfc_error ("Syntax error in SUBSTRING specification at %C");
920 gfc_free_expr (start
);
923 gfc_current_locus
= old_loc
;
928 /* Reads the next character of a string constant, taking care to
929 return doubled delimiters on the input as a single instance of
932 Special return values for "ret" argument are:
933 -1 End of the string, as determined by the delimiter
934 -2 Unterminated string detected
936 Backslash codes are also expanded at this time. */
939 next_string_char (gfc_char_t delimiter
, int *ret
)
944 c
= gfc_next_char_literal (INSTRING_WARN
);
953 if (flag_backslash
&& c
== '\\')
955 old_locus
= gfc_current_locus
;
957 if (gfc_match_special_char (&c
) == MATCH_NO
)
958 gfc_current_locus
= old_locus
;
960 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
961 gfc_warning (0, "Extension: backslash character at %C");
967 old_locus
= gfc_current_locus
;
968 c
= gfc_next_char_literal (NONSTRING
);
972 gfc_current_locus
= old_locus
;
979 /* Special case of gfc_match_name() that matches a parameter kind name
980 before a string constant. This takes case of the weird but legal
985 where kind____ is a parameter. gfc_match_name() will happily slurp
986 up all the underscores, which leads to problems. If we return
987 MATCH_YES, the parse pointer points to the final underscore, which
988 is not part of the name. We never return MATCH_ERROR-- errors in
989 the name will be detected later. */
992 match_charkind_name (char *name
)
998 gfc_gobble_whitespace ();
999 c
= gfc_next_ascii_char ();
1008 old_loc
= gfc_current_locus
;
1009 c
= gfc_next_ascii_char ();
1013 peek
= gfc_peek_ascii_char ();
1015 if (peek
== '\'' || peek
== '\"')
1017 gfc_current_locus
= old_loc
;
1025 && (c
!= '$' || !flag_dollar_ok
))
1029 if (++len
> GFC_MAX_SYMBOL_LEN
)
1037 /* See if the current input matches a character constant. Lots of
1038 contortions have to be done to match the kind parameter which comes
1039 before the actual string. The main consideration is that we don't
1040 want to error out too quickly. For example, we don't actually do
1041 any validation of the kinds until we have actually seen a legal
1042 delimiter. Using match_kind_param() generates errors too quickly. */
1045 match_string_constant (gfc_expr
**result
)
1047 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1049 int kind
,save_warn_ampersand
, ret
;
1050 locus old_locus
, start_locus
;
1054 gfc_char_t c
, delimiter
, *p
;
1056 old_locus
= gfc_current_locus
;
1058 gfc_gobble_whitespace ();
1060 c
= gfc_next_char ();
1061 if (c
== '\'' || c
== '"')
1063 kind
= gfc_default_character_kind
;
1064 start_locus
= gfc_current_locus
;
1068 if (gfc_wide_is_digit (c
))
1072 while (gfc_wide_is_digit (c
))
1074 kind
= kind
* 10 + c
- '0';
1077 c
= gfc_next_char ();
1083 gfc_current_locus
= old_locus
;
1085 m
= match_charkind_name (name
);
1089 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1091 || sym
->attr
.flavor
!= FL_PARAMETER
)
1095 c
= gfc_next_char ();
1100 gfc_gobble_whitespace ();
1101 c
= gfc_next_char ();
1107 gfc_gobble_whitespace ();
1109 c
= gfc_next_char ();
1110 if (c
!= '\'' && c
!= '"')
1113 start_locus
= gfc_current_locus
;
1117 if (gfc_extract_int (sym
->value
, &kind
, 1))
1119 gfc_set_sym_referenced (sym
);
1122 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1124 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1129 /* Scan the string into a block of memory by first figuring out how
1130 long it is, allocating the structure, then re-reading it. This
1131 isn't particularly efficient, but string constants aren't that
1132 common in most code. TODO: Use obstacks? */
1139 c
= next_string_char (delimiter
, &ret
);
1144 gfc_current_locus
= start_locus
;
1145 gfc_error ("Unterminated character constant beginning at %C");
1152 /* Peek at the next character to see if it is a b, o, z, or x for the
1153 postfixed BOZ literal constants. */
1154 peek
= gfc_peek_ascii_char ();
1155 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1158 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1160 gfc_current_locus
= start_locus
;
1162 /* We disable the warning for the following loop as the warning has already
1163 been printed in the loop above. */
1164 save_warn_ampersand
= warn_ampersand
;
1165 warn_ampersand
= false;
1167 p
= e
->value
.character
.string
;
1168 for (size_t i
= 0; i
< length
; i
++)
1170 c
= next_string_char (delimiter
, &ret
);
1172 if (!gfc_check_character_range (c
, kind
))
1175 gfc_error ("Character %qs in string at %C is not representable "
1176 "in character kind %d", gfc_print_wide_char (c
), kind
);
1183 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1184 warn_ampersand
= save_warn_ampersand
;
1186 next_string_char (delimiter
, &ret
);
1188 gfc_internal_error ("match_string_constant(): Delimiter not found");
1190 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1191 e
->expr_type
= EXPR_SUBSTRING
;
1198 gfc_current_locus
= old_locus
;
1203 /* Match a .true. or .false. Returns 1 if a .true. was found,
1204 0 if a .false. was found, and -1 otherwise. */
1206 match_logical_constant_string (void)
1208 locus orig_loc
= gfc_current_locus
;
1210 gfc_gobble_whitespace ();
1211 if (gfc_next_ascii_char () == '.')
1213 char ch
= gfc_next_ascii_char ();
1216 if (gfc_next_ascii_char () == 'a'
1217 && gfc_next_ascii_char () == 'l'
1218 && gfc_next_ascii_char () == 's'
1219 && gfc_next_ascii_char () == 'e'
1220 && gfc_next_ascii_char () == '.')
1221 /* Matched ".false.". */
1226 if (gfc_next_ascii_char () == 'r'
1227 && gfc_next_ascii_char () == 'u'
1228 && gfc_next_ascii_char () == 'e'
1229 && gfc_next_ascii_char () == '.')
1230 /* Matched ".true.". */
1234 gfc_current_locus
= orig_loc
;
1238 /* Match a .true. or .false. */
1241 match_logical_constant (gfc_expr
**result
)
1244 int i
, kind
, is_iso_c
;
1246 i
= match_logical_constant_string ();
1250 kind
= get_kind (&is_iso_c
);
1254 kind
= gfc_default_logical_kind
;
1256 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1258 gfc_error ("Bad kind for logical constant at %C");
1262 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1263 e
->ts
.is_c_interop
= is_iso_c
;
1270 /* Match a real or imaginary part of a complex constant that is a
1271 symbolic constant. */
1274 match_sym_complex_part (gfc_expr
**result
)
1276 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1281 m
= gfc_match_name (name
);
1285 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1288 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1290 /* Give the matcher for implied do-loops a chance to run. This yields
1291 a much saner error message for "write(*,*) (i, i=1, 6" where the
1292 right parenthesis is missing. */
1294 gfc_gobble_whitespace ();
1295 c
= gfc_peek_ascii_char ();
1296 if (c
== '=' || c
== ',')
1302 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1311 if (!gfc_numeric_ts (&sym
->value
->ts
))
1313 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1317 if (sym
->value
->rank
!= 0)
1319 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1323 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1324 "complex constant at %C"))
1327 switch (sym
->value
->ts
.type
)
1330 e
= gfc_copy_expr (sym
->value
);
1334 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1340 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1346 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1349 *result
= e
; /* e is a scalar, real, constant expression. */
1353 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1358 /* Match a real or imaginary part of a complex number. */
1361 match_complex_part (gfc_expr
**result
)
1365 m
= match_sym_complex_part (result
);
1369 m
= match_real_constant (result
, 1);
1373 return match_integer_constant (result
, 1);
1377 /* Try to match a complex constant. */
1380 match_complex_constant (gfc_expr
**result
)
1382 gfc_expr
*e
, *real
, *imag
;
1383 gfc_error_buffer old_error
;
1384 gfc_typespec target
;
1389 old_loc
= gfc_current_locus
;
1390 real
= imag
= e
= NULL
;
1392 m
= gfc_match_char ('(');
1396 gfc_push_error (&old_error
);
1398 m
= match_complex_part (&real
);
1401 gfc_free_error (&old_error
);
1405 if (gfc_match_char (',') == MATCH_NO
)
1407 /* It is possible that gfc_int2real issued a warning when
1408 converting an integer to real. Throw this away here. */
1410 gfc_clear_warning ();
1411 gfc_pop_error (&old_error
);
1416 /* If m is error, then something was wrong with the real part and we
1417 assume we have a complex constant because we've seen the ','. An
1418 ambiguous case here is the start of an iterator list of some
1419 sort. These sort of lists are matched prior to coming here. */
1421 if (m
== MATCH_ERROR
)
1423 gfc_free_error (&old_error
);
1426 gfc_pop_error (&old_error
);
1428 m
= match_complex_part (&imag
);
1431 if (m
== MATCH_ERROR
)
1434 m
= gfc_match_char (')');
1437 /* Give the matcher for implied do-loops a chance to run. This
1438 yields a much saner error message for (/ (i, 4=i, 6) /). */
1439 if (gfc_peek_ascii_char () == '=')
1448 if (m
== MATCH_ERROR
)
1451 /* Decide on the kind of this complex number. */
1452 if (real
->ts
.type
== BT_REAL
)
1454 if (imag
->ts
.type
== BT_REAL
)
1455 kind
= gfc_kind_max (real
, imag
);
1457 kind
= real
->ts
.kind
;
1461 if (imag
->ts
.type
== BT_REAL
)
1462 kind
= imag
->ts
.kind
;
1464 kind
= gfc_default_real_kind
;
1466 gfc_clear_ts (&target
);
1467 target
.type
= BT_REAL
;
1470 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1471 gfc_convert_type (real
, &target
, 2);
1472 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1473 gfc_convert_type (imag
, &target
, 2);
1475 e
= convert_complex (real
, imag
, kind
);
1476 e
->where
= gfc_current_locus
;
1478 gfc_free_expr (real
);
1479 gfc_free_expr (imag
);
1485 gfc_error ("Syntax error in COMPLEX constant at %C");
1490 gfc_free_expr (real
);
1491 gfc_free_expr (imag
);
1492 gfc_current_locus
= old_loc
;
1498 /* Match constants in any of several forms. Returns nonzero for a
1499 match, zero for no match. */
1502 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1506 m
= match_complex_constant (result
);
1510 m
= match_string_constant (result
);
1514 m
= match_boz_constant (result
);
1518 m
= match_real_constant (result
, signflag
);
1522 m
= match_hollerith_constant (result
);
1526 m
= match_integer_constant (result
, signflag
);
1530 m
= match_logical_constant (result
);
1538 /* This checks if a symbol is the return value of an encompassing function.
1539 Function nesting can be maximally two levels deep, but we may have
1540 additional local namespaces like BLOCK etc. */
1543 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1545 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1549 if (ns
->proc_name
== sym
)
1557 /* Match a single actual argument value. An actual argument is
1558 usually an expression, but can also be a procedure name. If the
1559 argument is a single name, it is not always possible to tell
1560 whether the name is a dummy procedure or not. We treat these cases
1561 by creating an argument that looks like a dummy procedure and
1562 fixing things later during resolution. */
1565 match_actual_arg (gfc_expr
**result
)
1567 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1568 gfc_symtree
*symtree
;
1573 gfc_gobble_whitespace ();
1574 where
= gfc_current_locus
;
1576 switch (gfc_match_name (name
))
1585 w
= gfc_current_locus
;
1586 gfc_gobble_whitespace ();
1587 c
= gfc_next_ascii_char ();
1588 gfc_current_locus
= w
;
1590 if (c
!= ',' && c
!= ')')
1593 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1595 /* Handle error elsewhere. */
1597 /* Eliminate a couple of common cases where we know we don't
1598 have a function argument. */
1599 if (symtree
== NULL
)
1601 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1602 gfc_set_sym_referenced (symtree
->n
.sym
);
1608 sym
= symtree
->n
.sym
;
1609 gfc_set_sym_referenced (sym
);
1610 if (sym
->attr
.flavor
== FL_NAMELIST
)
1612 gfc_error ("Namelist %qs cannot be an argument at %L",
1616 if (sym
->attr
.flavor
!= FL_PROCEDURE
1617 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1620 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1622 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1623 sym
->name
, &sym
->declared_at
))
1628 /* If the symbol is a function with itself as the result and
1629 is being defined, then we have a variable. */
1630 if (sym
->attr
.function
&& sym
->result
== sym
)
1632 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1636 && (sym
->ns
== gfc_current_ns
1637 || sym
->ns
== gfc_current_ns
->parent
))
1639 gfc_entry_list
*el
= NULL
;
1641 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1651 e
= gfc_get_expr (); /* Leave it unknown for now */
1652 e
->symtree
= symtree
;
1653 e
->expr_type
= EXPR_VARIABLE
;
1654 e
->ts
.type
= BT_PROCEDURE
;
1661 gfc_current_locus
= where
;
1662 return gfc_match_expr (result
);
1666 /* Match a keyword argument or type parameter spec list.. */
1669 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
, bool pdt
)
1671 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1672 gfc_actual_arglist
*a
;
1676 name_locus
= gfc_current_locus
;
1677 m
= gfc_match_name (name
);
1681 if (gfc_match_char ('=') != MATCH_YES
)
1689 if (gfc_match_char ('*') == MATCH_YES
)
1691 actual
->spec_type
= SPEC_ASSUMED
;
1694 else if (gfc_match_char (':') == MATCH_YES
)
1696 actual
->spec_type
= SPEC_DEFERRED
;
1700 actual
->spec_type
= SPEC_EXPLICIT
;
1703 m
= match_actual_arg (&actual
->expr
);
1707 /* Make sure this name has not appeared yet. */
1709 if (name
[0] != '\0')
1711 for (a
= base
; a
; a
= a
->next
)
1712 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1714 gfc_error ("Keyword %qs at %C has already appeared in the "
1715 "current argument list", name
);
1720 actual
->name
= gfc_get_string ("%s", name
);
1724 gfc_current_locus
= name_locus
;
1729 /* Match an argument list function, such as %VAL. */
1732 match_arg_list_function (gfc_actual_arglist
*result
)
1734 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1738 old_locus
= gfc_current_locus
;
1740 if (gfc_match_char ('%') != MATCH_YES
)
1746 m
= gfc_match ("%n (", name
);
1750 if (name
[0] != '\0')
1755 if (gfc_str_startswith (name
, "loc"))
1757 result
->name
= "%LOC";
1762 if (gfc_str_startswith (name
, "ref"))
1764 result
->name
= "%REF";
1769 if (gfc_str_startswith (name
, "val"))
1771 result
->name
= "%VAL";
1781 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1787 m
= match_actual_arg (&result
->expr
);
1791 if (gfc_match_char (')') != MATCH_YES
)
1800 gfc_current_locus
= old_locus
;
1805 /* Matches an actual argument list of a function or subroutine, from
1806 the opening parenthesis to the closing parenthesis. The argument
1807 list is assumed to allow keyword arguments because we don't know if
1808 the symbol associated with the procedure has an implicit interface
1809 or not. We make sure keywords are unique. If sub_flag is set,
1810 we're matching the argument list of a subroutine.
1812 NOTE: An alternative use for this function is to match type parameter
1813 spec lists, which are so similar to actual argument lists that the
1814 machinery can be reused. This use is flagged by the optional argument
1818 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
, bool pdt
)
1820 gfc_actual_arglist
*head
, *tail
;
1822 gfc_st_label
*label
;
1826 *argp
= tail
= NULL
;
1827 old_loc
= gfc_current_locus
;
1831 if (gfc_match_char ('(') == MATCH_NO
)
1832 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1834 if (gfc_match_char (')') == MATCH_YES
)
1839 matching_actual_arglist
++;
1844 head
= tail
= gfc_get_actual_arglist ();
1847 tail
->next
= gfc_get_actual_arglist ();
1851 if (sub_flag
&& !pdt
&& gfc_match_char ('*') == MATCH_YES
)
1853 m
= gfc_match_st_label (&label
);
1855 gfc_error ("Expected alternate return label at %C");
1859 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1863 tail
->label
= label
;
1867 if (pdt
&& !seen_keyword
)
1869 if (gfc_match_char (':') == MATCH_YES
)
1871 tail
->spec_type
= SPEC_DEFERRED
;
1874 else if (gfc_match_char ('*') == MATCH_YES
)
1876 tail
->spec_type
= SPEC_ASSUMED
;
1880 tail
->spec_type
= SPEC_EXPLICIT
;
1882 m
= match_keyword_arg (tail
, head
, pdt
);
1888 if (m
== MATCH_ERROR
)
1892 /* After the first keyword argument is seen, the following
1893 arguments must also have keywords. */
1896 m
= match_keyword_arg (tail
, head
, pdt
);
1898 if (m
== MATCH_ERROR
)
1902 gfc_error ("Missing keyword name in actual argument list at %C");
1909 /* Try an argument list function, like %VAL. */
1910 m
= match_arg_list_function (tail
);
1911 if (m
== MATCH_ERROR
)
1914 /* See if we have the first keyword argument. */
1917 m
= match_keyword_arg (tail
, head
, false);
1920 if (m
== MATCH_ERROR
)
1926 /* Try for a non-keyword argument. */
1927 m
= match_actual_arg (&tail
->expr
);
1928 if (m
== MATCH_ERROR
)
1937 if (gfc_match_char (')') == MATCH_YES
)
1939 if (gfc_match_char (',') != MATCH_YES
)
1944 matching_actual_arglist
--;
1948 gfc_error ("Syntax error in argument list at %C");
1951 gfc_free_actual_arglist (head
);
1952 gfc_current_locus
= old_loc
;
1953 matching_actual_arglist
--;
1958 /* Used by gfc_match_varspec() to extend the reference list by one
1962 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1964 if (primary
->ref
== NULL
)
1965 primary
->ref
= tail
= gfc_get_ref ();
1969 gfc_internal_error ("extend_ref(): Bad tail");
1970 tail
->next
= gfc_get_ref ();
1978 /* Used by gfc_match_varspec() to match an inquiry reference. */
1981 is_inquiry_ref (const char *name
, gfc_ref
**ref
)
1988 if (ref
) *ref
= NULL
;
1990 if (strcmp (name
, "re") == 0)
1992 else if (strcmp (name
, "im") == 0)
1994 else if (strcmp (name
, "kind") == 0)
1995 type
= INQUIRY_KIND
;
1996 else if (strcmp (name
, "len") == 0)
2003 *ref
= gfc_get_ref ();
2004 (*ref
)->type
= REF_INQUIRY
;
2012 /* Match any additional specifications associated with the current
2013 variable like member references or substrings. If equiv_flag is
2014 set we only match stuff that is allowed inside an EQUIVALENCE
2015 statement. sub_flag tells whether we expect a type-bound procedure found
2016 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
2017 components, 'ppc_arg' determines whether the PPC may be called (with an
2018 argument list), or whether it may just be referred to as a pointer. */
2021 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
2024 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2025 gfc_ref
*substring
, *tail
, *tmp
;
2026 gfc_component
*component
= NULL
;
2027 gfc_component
*previous
= NULL
;
2028 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
2029 gfc_expr
*tgt_expr
= NULL
;
2039 gfc_gobble_whitespace ();
2041 if (gfc_peek_ascii_char () == '[')
2043 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
2044 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2045 && CLASS_DATA (sym
)->attr
.dimension
))
2047 gfc_error ("Array section designator, e.g. '(:)', is required "
2048 "besides the coarray designator '[...]' at %C");
2051 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
2052 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2053 && !CLASS_DATA (sym
)->attr
.codimension
))
2055 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2061 if (sym
->assoc
&& sym
->assoc
->target
)
2062 tgt_expr
= sym
->assoc
->target
;
2064 /* For associate names, we may not yet know whether they are arrays or not.
2065 If the selector expression is unambiguously an array; eg. a full array
2066 or an array section, then the associate name must be an array and we can
2067 fix it now. Otherwise, if parentheses follow and it is not a character
2068 type, we have to assume that it actually is one for now. The final
2069 decision will be made at resolution, of course. */
2071 && gfc_peek_ascii_char () == '('
2072 && sym
->ts
.type
!= BT_CLASS
2073 && !sym
->attr
.dimension
)
2075 gfc_ref
*ref
= NULL
;
2077 if (!sym
->assoc
->dangling
&& tgt_expr
)
2079 if (tgt_expr
->expr_type
== EXPR_VARIABLE
)
2080 gfc_resolve_expr (tgt_expr
);
2082 ref
= tgt_expr
->ref
;
2083 for (; ref
; ref
= ref
->next
)
2084 if (ref
->type
== REF_ARRAY
2085 && (ref
->u
.ar
.type
== AR_FULL
2086 || ref
->u
.ar
.type
== AR_SECTION
))
2090 if (ref
|| (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
2092 && sym
->assoc
->st
->n
.sym
2093 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
2095 sym
->attr
.dimension
= 1;
2098 && sym
->assoc
->st
->n
.sym
2099 && sym
->assoc
->st
->n
.sym
->as
)
2100 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
2103 else if (sym
->ts
.type
== BT_CLASS
2105 && tgt_expr
->expr_type
== EXPR_VARIABLE
2106 && sym
->ts
.u
.derived
!= tgt_expr
->ts
.u
.derived
)
2108 gfc_resolve_expr (tgt_expr
);
2110 sym
->ts
.u
.derived
= tgt_expr
->ts
.u
.derived
;
2113 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
2114 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
2115 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
2116 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
2117 && !(gfc_matching_procptr_assignment
2118 && sym
->attr
.flavor
== FL_PROCEDURE
))
2119 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2120 && (CLASS_DATA (sym
)->attr
.dimension
2121 || CLASS_DATA (sym
)->attr
.codimension
)))
2125 tail
= extend_ref (primary
, tail
);
2126 tail
->type
= REF_ARRAY
;
2128 /* In EQUIVALENCE, we don't know yet whether we are seeing
2129 an array, character variable or array of character
2130 variables. We'll leave the decision till resolve time. */
2134 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2135 as
= CLASS_DATA (sym
)->as
;
2139 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
2140 as
? as
->corank
: 0);
2144 gfc_gobble_whitespace ();
2145 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
2147 tail
= extend_ref (primary
, tail
);
2148 tail
->type
= REF_ARRAY
;
2150 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2156 primary
->ts
= sym
->ts
;
2161 /* With DEC extensions, member separator may be '.' or '%'. */
2162 sep
= gfc_peek_ascii_char ();
2163 m
= gfc_match_member_sep (sym
);
2164 if (m
== MATCH_ERROR
)
2168 if (m
== MATCH_YES
&& sep
== '%'
2169 && primary
->ts
.type
!= BT_CLASS
2170 && primary
->ts
.type
!= BT_DERIVED
)
2173 old_loc
= gfc_current_locus
;
2174 mm
= gfc_match_name (name
);
2175 if (mm
== MATCH_YES
&& is_inquiry_ref (name
, &tmp
))
2177 gfc_current_locus
= old_loc
;
2180 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2181 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2182 gfc_set_default_type (sym
, 0, sym
->ns
);
2184 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2185 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2189 /* These target expressions can be resolved at any time. */
2190 permissible
= tgt_expr
&& tgt_expr
->symtree
&& tgt_expr
->symtree
->n
.sym
2191 && (tgt_expr
->symtree
->n
.sym
->attr
.use_assoc
2192 || tgt_expr
->symtree
->n
.sym
->attr
.host_assoc
2193 || tgt_expr
->symtree
->n
.sym
->attr
.if_source
2195 permissible
= permissible
2196 || (tgt_expr
&& tgt_expr
->expr_type
== EXPR_OP
);
2200 gfc_resolve_expr (tgt_expr
);
2201 sym
->ts
= tgt_expr
->ts
;
2204 if (sym
->ts
.type
== BT_UNKNOWN
)
2206 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2210 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2211 && m
== MATCH_YES
&& !inquiry
)
2213 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2218 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
&& !inquiry
)
2220 goto check_substring
;
2223 sym
= sym
->ts
.u
.derived
;
2232 m
= gfc_match_name (name
);
2234 gfc_error ("Expected structure component name at %C");
2239 if (primary
->ts
.type
!= BT_CLASS
&& primary
->ts
.type
!= BT_DERIVED
)
2241 inquiry
= is_inquiry_ref (name
, &tmp
);
2253 if (!gfc_notify_std (GFC_STD_F2008
,
2254 "RE or IM part_ref at %C"))
2259 if (!gfc_notify_std (GFC_STD_F2003
,
2260 "KIND part_ref at %C"))
2265 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2270 if ((tmp
->u
.i
== INQUIRY_RE
|| tmp
->u
.i
== INQUIRY_IM
)
2271 && primary
->ts
.type
!= BT_COMPLEX
)
2273 gfc_error ("The RE or IM part_ref at %C must be "
2274 "applied to a COMPLEX expression");
2277 else if (tmp
->u
.i
== INQUIRY_LEN
2278 && primary
->ts
.type
!= BT_CHARACTER
)
2280 gfc_error ("The LEN part_ref at %C must be applied "
2281 "to a CHARACTER expression");
2285 if (primary
->ts
.type
!= BT_UNKNOWN
)
2292 if (sym
&& sym
->f2k_derived
)
2293 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2299 gfc_symbol
* tbp_sym
;
2304 gcc_assert (!tail
|| !tail
->next
);
2306 if (!(primary
->expr_type
== EXPR_VARIABLE
2307 || (primary
->expr_type
== EXPR_STRUCTURE
2308 && primary
->symtree
&& primary
->symtree
->n
.sym
2309 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2312 if (tbp
->n
.tb
->is_generic
)
2315 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2317 primary
->expr_type
= EXPR_COMPCALL
;
2318 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2319 primary
->value
.compcall
.name
= tbp
->name
;
2320 primary
->value
.compcall
.ignore_pass
= 0;
2321 primary
->value
.compcall
.assign
= 0;
2322 primary
->value
.compcall
.base_object
= NULL
;
2323 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2325 primary
->ts
= tbp_sym
->ts
;
2327 gfc_clear_ts (&primary
->ts
);
2329 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2330 &primary
->value
.compcall
.actual
);
2331 if (m
== MATCH_ERROR
)
2336 primary
->value
.compcall
.actual
= NULL
;
2339 gfc_error ("Expected argument list at %C");
2347 previous
= component
;
2349 if (!inquiry
&& !intrinsic
)
2350 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2354 if (intrinsic
&& !inquiry
)
2356 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2357 "type component %qs", name
, previous
->name
);
2360 else if (component
== NULL
&& !inquiry
)
2363 /* Extend the reference chain determined by gfc_find_component or
2365 if (primary
->ref
== NULL
)
2369 /* Set by the for loop below for the last component ref. */
2370 gcc_assert (tail
!= NULL
);
2374 /* The reference chain may be longer than one hop for union
2375 subcomponents; find the new tail. */
2376 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2379 if (tmp
&& tmp
->type
== REF_INQUIRY
)
2381 if (!primary
->where
.lb
|| !primary
->where
.nextc
)
2382 primary
->where
= gfc_current_locus
;
2383 gfc_simplify_expr (primary
, 0);
2385 if (primary
->expr_type
== EXPR_CONSTANT
)
2392 if (!gfc_notify_std (GFC_STD_F2008
, "RE or IM part_ref at %C"))
2395 if (primary
->ts
.type
!= BT_COMPLEX
)
2397 gfc_error ("The RE or IM part_ref at %C must be "
2398 "applied to a COMPLEX expression");
2401 primary
->ts
.type
= BT_REAL
;
2405 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2408 if (primary
->ts
.type
!= BT_CHARACTER
)
2410 gfc_error ("The LEN part_ref at %C must be applied "
2411 "to a CHARACTER expression");
2414 primary
->ts
.u
.cl
= NULL
;
2415 primary
->ts
.type
= BT_INTEGER
;
2416 primary
->ts
.kind
= gfc_default_integer_kind
;
2420 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
2423 if (primary
->ts
.type
== BT_CLASS
2424 || primary
->ts
.type
== BT_DERIVED
)
2426 gfc_error ("The KIND part_ref at %C must be applied "
2427 "to an expression of intrinsic type");
2430 primary
->ts
.type
= BT_INTEGER
;
2431 primary
->ts
.kind
= gfc_default_integer_kind
;
2441 primary
->ts
= component
->ts
;
2443 if (component
->attr
.proc_pointer
&& ppc_arg
)
2445 /* Procedure pointer component call: Look for argument list. */
2446 m
= gfc_match_actual_arglist (sub_flag
,
2447 &primary
->value
.compcall
.actual
);
2448 if (m
== MATCH_ERROR
)
2451 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2452 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2454 gfc_error ("Procedure pointer component %qs requires an "
2455 "argument list at %C", component
->name
);
2460 primary
->expr_type
= EXPR_PPC
;
2465 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2467 tail
= extend_ref (primary
, tail
);
2468 tail
->type
= REF_ARRAY
;
2470 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2471 component
->as
->corank
);
2475 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2476 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2478 tail
= extend_ref (primary
, tail
);
2479 tail
->type
= REF_ARRAY
;
2481 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2483 CLASS_DATA (component
)->as
->corank
);
2489 /* In principle, we could have eg. expr%re%kind so we must allow for
2490 this possibility. */
2491 if (gfc_match_char ('%') == MATCH_YES
)
2493 if (component
&& (component
->ts
.type
== BT_DERIVED
2494 || component
->ts
.type
== BT_CLASS
))
2495 sym
= component
->ts
.u
.derived
;
2501 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2502 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2505 if (component
->ts
.type
== BT_DERIVED
|| component
->ts
.type
== BT_CLASS
)
2506 sym
= component
->ts
.u
.derived
;
2511 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2513 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2515 gfc_set_default_type (sym
, 0, sym
->ns
);
2516 primary
->ts
= sym
->ts
;
2521 if (primary
->ts
.type
== BT_CHARACTER
)
2523 bool def
= primary
->ts
.deferred
== 1;
2524 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2528 primary
->ref
= substring
;
2530 tail
->next
= substring
;
2532 if (primary
->expr_type
== EXPR_CONSTANT
)
2533 primary
->expr_type
= EXPR_SUBSTRING
;
2536 primary
->ts
.u
.cl
= NULL
;
2543 gfc_clear_ts (&primary
->ts
);
2544 gfc_clear_ts (&sym
->ts
);
2554 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2555 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2557 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2562 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2564 gfc_error ("Coindexed procedure-pointer component at %C");
2572 /* Given an expression that is a variable, figure out what the
2573 ultimate variable's type and attribute is, traversing the reference
2574 structures if necessary.
2576 This subroutine is trickier than it looks. We start at the base
2577 symbol and store the attribute. Component references load a
2578 completely new attribute.
2580 A couple of rules come into play. Subobjects of targets are always
2581 targets themselves. If we see a component that goes through a
2582 pointer, then the expression must also be a target, since the
2583 pointer is associated with something (if it isn't core will soon be
2584 dumped). If we see a full part or section of an array, the
2585 expression is also an array.
2587 We can have at most one full array reference. */
2590 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2592 int dimension
, codimension
, pointer
, allocatable
, target
;
2593 symbol_attribute attr
;
2596 gfc_component
*comp
;
2597 bool has_inquiry_part
;
2599 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2600 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2602 sym
= expr
->symtree
->n
.sym
;
2605 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
&& sym
->ts
.u
.derived
)
2607 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2608 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2609 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2610 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2614 dimension
= attr
.dimension
;
2615 codimension
= attr
.codimension
;
2616 pointer
= attr
.pointer
;
2617 allocatable
= attr
.allocatable
;
2620 target
= attr
.target
;
2621 if (pointer
|| attr
.proc_pointer
)
2624 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2627 has_inquiry_part
= false;
2628 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2629 if (ref
->type
== REF_INQUIRY
)
2631 has_inquiry_part
= true;
2635 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2640 switch (ref
->u
.ar
.type
)
2647 allocatable
= pointer
= 0;
2652 /* Handle coarrays. */
2653 if (ref
->u
.ar
.dimen
> 0)
2654 allocatable
= pointer
= 0;
2658 /* For standard conforming code, AR_UNKNOWN should not happen.
2659 For nonconforming code, gfortran can end up here. Treat it
2667 comp
= ref
->u
.c
.component
;
2669 if (ts
!= NULL
&& !has_inquiry_part
)
2672 /* Don't set the string length if a substring reference
2674 if (ts
->type
== BT_CHARACTER
2675 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2679 if (comp
->ts
.type
== BT_CLASS
)
2681 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2682 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2683 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2687 codimension
= comp
->attr
.codimension
;
2688 pointer
= comp
->attr
.pointer
;
2689 allocatable
= comp
->attr
.allocatable
;
2691 if (pointer
|| attr
.proc_pointer
)
2698 allocatable
= pointer
= 0;
2702 attr
.dimension
= dimension
;
2703 attr
.codimension
= codimension
;
2704 attr
.pointer
= pointer
;
2705 attr
.allocatable
= allocatable
;
2706 attr
.target
= target
;
2707 attr
.save
= sym
->attr
.save
;
2713 /* Return the attribute from a general expression. */
2716 gfc_expr_attr (gfc_expr
*e
)
2718 symbol_attribute attr
;
2720 switch (e
->expr_type
)
2723 attr
= gfc_variable_attr (e
, NULL
);
2727 gfc_clear_attr (&attr
);
2729 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2731 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2733 if (sym
->ts
.type
== BT_CLASS
)
2735 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2736 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2737 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2740 else if (e
->value
.function
.isym
2741 && e
->value
.function
.isym
->transformational
2742 && e
->ts
.type
== BT_CLASS
)
2743 attr
= CLASS_DATA (e
)->attr
;
2745 attr
= gfc_variable_attr (e
, NULL
);
2747 /* TODO: NULL() returns pointers. May have to take care of this
2753 gfc_clear_attr (&attr
);
2761 /* Given an expression, figure out what the ultimate expression
2762 attribute is. This routine is similar to gfc_variable_attr with
2763 parts of gfc_expr_attr, but focuses more on the needs of
2764 coarrays. For coarrays a codimension attribute is kind of
2765 "infectious" being propagated once set and never cleared.
2766 The coarray_comp is only set, when the expression refs a coarray
2767 component. REFS_COMP is set when present to true only, when this EXPR
2768 refs a (non-_data) component. To check whether EXPR refs an allocatable
2769 component in a derived type coarray *refs_comp needs to be set and
2770 coarray_comp has to false. */
2772 static symbol_attribute
2773 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2775 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2776 symbol_attribute attr
;
2779 gfc_component
*comp
;
2781 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2782 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2784 sym
= expr
->symtree
->n
.sym
;
2785 gfc_clear_attr (&attr
);
2790 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2792 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2793 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2794 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2795 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2796 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2797 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2801 dimension
= sym
->attr
.dimension
;
2802 codimension
= sym
->attr
.codimension
;
2803 pointer
= sym
->attr
.pointer
;
2804 allocatable
= sym
->attr
.allocatable
;
2805 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2806 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2807 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2808 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2811 target
= coarray_comp
= 0;
2812 if (pointer
|| attr
.proc_pointer
)
2815 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2820 switch (ref
->u
.ar
.type
)
2828 /* Handle coarrays. */
2829 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2830 allocatable
= pointer
= 0;
2834 /* If any of start, end or stride is not integer, there will
2835 already have been an error issued. */
2837 gfc_get_errors (NULL
, &errors
);
2839 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2845 comp
= ref
->u
.c
.component
;
2847 if (comp
->ts
.type
== BT_CLASS
)
2849 /* Set coarray_comp only, when this component introduces the
2851 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2852 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2853 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2854 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2858 /* Set coarray_comp only, when this component introduces the
2860 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2861 codimension
|= comp
->attr
.codimension
;
2862 pointer
= comp
->attr
.pointer
;
2863 allocatable
= comp
->attr
.allocatable
;
2866 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2867 && (ref
->next
== NULL
2868 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2871 if (pointer
|| attr
.proc_pointer
)
2878 allocatable
= pointer
= 0;
2882 attr
.dimension
= dimension
;
2883 attr
.codimension
= codimension
;
2884 attr
.pointer
= pointer
;
2885 attr
.allocatable
= allocatable
;
2886 attr
.target
= target
;
2887 attr
.save
= sym
->attr
.save
;
2888 attr
.coarray_comp
= coarray_comp
;
2895 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2897 symbol_attribute attr
;
2899 switch (e
->expr_type
)
2902 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2906 gfc_clear_attr (&attr
);
2908 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2910 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2912 if (sym
->ts
.type
== BT_CLASS
)
2914 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2915 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2916 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2917 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2918 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2919 ->attr
.pointer_comp
;
2922 else if (e
->symtree
)
2923 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2925 gfc_clear_attr (&attr
);
2929 gfc_clear_attr (&attr
);
2937 /* Match a structure constructor. The initial symbol has already been
2940 typedef struct gfc_structure_ctor_component
2945 struct gfc_structure_ctor_component
* next
;
2947 gfc_structure_ctor_component
;
2949 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2952 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2955 gfc_free_expr (comp
->val
);
2960 /* Translate the component list into the actual constructor by sorting it in
2961 the order required; this also checks along the way that each and every
2962 component actually has an initializer and handles default initializers
2963 for components without explicit value given. */
2965 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2966 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2968 gfc_structure_ctor_component
*comp_iter
;
2969 gfc_component
*comp
;
2971 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2973 gfc_structure_ctor_component
**next_ptr
;
2974 gfc_expr
*value
= NULL
;
2976 /* Try to find the initializer for the current component by name. */
2977 next_ptr
= comp_head
;
2978 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2980 if (!strcmp (comp_iter
->name
, comp
->name
))
2982 next_ptr
= &comp_iter
->next
;
2985 /* If an extension, try building the parent derived type by building
2986 a value expression for the parent derived type and calling self. */
2987 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2989 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2991 &gfc_current_locus
);
2992 value
->ts
= comp
->ts
;
2994 if (!build_actual_constructor (comp_head
,
2995 &value
->value
.constructor
,
2996 comp
->ts
.u
.derived
))
2998 gfc_free_expr (value
);
3002 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3006 /* If it was not found, apply NULL expression to set the component as
3007 unallocated. Then try the default initializer if there's any;
3008 otherwise, it's an error unless this is a deferred parameter. */
3011 /* F2018 7.5.10: If an allocatable component has no corresponding
3012 component-data-source, then that component has an allocation
3013 status of unallocated.... */
3014 if (comp
->attr
.allocatable
3015 || (comp
->ts
.type
== BT_CLASS
3016 && CLASS_DATA (comp
)->attr
.allocatable
))
3018 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
3019 "allocatable component %qs given in the "
3020 "structure constructor at %C", comp
->name
))
3022 value
= gfc_get_null_expr (&gfc_current_locus
);
3024 /* ....(Preceeding sentence) If a component with default
3025 initialization has no corresponding component-data-source, then
3026 the default initialization is applied to that component. */
3027 else if (comp
->initializer
)
3029 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
3030 "with missing optional arguments at %C"))
3032 value
= gfc_copy_expr (comp
->initializer
);
3034 /* Do not trap components such as the string length for deferred
3035 length character components. */
3036 else if (!comp
->attr
.artificial
)
3038 gfc_error ("No initializer for component %qs given in the"
3039 " structure constructor at %C", comp
->name
);
3044 value
= comp_iter
->val
;
3046 /* Add the value to the constructor chain built. */
3047 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
3049 /* Remove the entry from the component list. We don't want the expression
3050 value to be free'd, so set it to NULL. */
3053 *next_ptr
= comp_iter
->next
;
3054 comp_iter
->val
= NULL
;
3055 gfc_free_structure_ctor_component (comp_iter
);
3063 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
3064 gfc_actual_arglist
**arglist
,
3067 gfc_actual_arglist
*actual
;
3068 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
3069 gfc_constructor_base ctor_head
= NULL
;
3070 gfc_component
*comp
; /* Is set NULL when named component is first seen */
3071 const char* last_name
= NULL
;
3075 expr
= parent
? *cexpr
: e
;
3076 old_locus
= gfc_current_locus
;
3078 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3080 gfc_current_locus
= expr
->where
;
3082 comp_tail
= comp_head
= NULL
;
3084 if (!parent
&& sym
->attr
.abstract
)
3086 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3087 sym
->name
, &expr
->where
);
3091 comp
= sym
->components
;
3092 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
3095 gfc_component
*this_comp
= NULL
;
3098 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
3101 comp_tail
->next
= gfc_get_structure_ctor_component ();
3102 comp_tail
= comp_tail
->next
;
3106 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
3107 " constructor with named arguments at %C"))
3110 comp_tail
->name
= xstrdup (actual
->name
);
3111 last_name
= comp_tail
->name
;
3116 /* Components without name are not allowed after the first named
3117 component initializer! */
3118 if (!comp
|| comp
->attr
.artificial
)
3121 gfc_error ("Component initializer without name after component"
3122 " named %s at %L", last_name
,
3123 actual
->expr
? &actual
->expr
->where
3124 : &gfc_current_locus
);
3126 gfc_error ("Too many components in structure constructor at "
3127 "%L", actual
->expr
? &actual
->expr
->where
3128 : &gfc_current_locus
);
3132 comp_tail
->name
= xstrdup (comp
->name
);
3135 /* Find the current component in the structure definition and check
3136 its access is not private. */
3138 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
3141 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
3142 false, false, NULL
);
3143 comp
= NULL
; /* Reset needed! */
3146 /* Here we can check if a component name is given which does not
3147 correspond to any component of the defined structure. */
3151 /* For a constant string constructor, make sure the length is
3152 correct; truncate of fill with blanks if needed. */
3153 if (this_comp
->ts
.type
== BT_CHARACTER
&& !this_comp
->attr
.allocatable
3154 && this_comp
->ts
.u
.cl
&& this_comp
->ts
.u
.cl
->length
3155 && this_comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3156 && actual
->expr
->ts
.type
== BT_CHARACTER
3157 && actual
->expr
->expr_type
== EXPR_CONSTANT
)
3160 c
= gfc_mpz_get_hwi (this_comp
->ts
.u
.cl
->length
->value
.integer
);
3161 e1
= actual
->expr
->value
.character
.length
;
3167 dest
= gfc_get_wide_string (c
+ 1);
3169 to
= e1
< c
? e1
: c
;
3170 for (i
= 0; i
< to
; i
++)
3171 dest
[i
] = actual
->expr
->value
.character
.string
[i
];
3173 for (i
= e1
; i
< c
; i
++)
3177 free (actual
->expr
->value
.character
.string
);
3179 actual
->expr
->value
.character
.length
= c
;
3180 actual
->expr
->value
.character
.string
= dest
;
3182 if (warn_line_truncation
&& c
< e1
)
3183 gfc_warning_now (OPT_Wcharacter_truncation
,
3184 "CHARACTER expression will be truncated "
3185 "in constructor (%ld/%ld) at %L", (long int) c
,
3186 (long int) e1
, &actual
->expr
->where
);
3190 comp_tail
->val
= actual
->expr
;
3191 if (actual
->expr
!= NULL
)
3192 comp_tail
->where
= actual
->expr
->where
;
3193 actual
->expr
= NULL
;
3195 /* Check if this component is already given a value. */
3196 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
3197 comp_iter
= comp_iter
->next
)
3199 gcc_assert (comp_iter
);
3200 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
3202 gfc_error ("Component %qs is initialized twice in the structure"
3203 " constructor at %L", comp_tail
->name
,
3204 comp_tail
->val
? &comp_tail
->where
3205 : &gfc_current_locus
);
3210 /* F2008, R457/C725, for PURE C1283. */
3211 if (this_comp
->attr
.pointer
&& comp_tail
->val
3212 && gfc_is_coindexed (comp_tail
->val
))
3214 gfc_error ("Coindexed expression to pointer component %qs in "
3215 "structure constructor at %L", comp_tail
->name
,
3220 /* If not explicitly a parent constructor, gather up the components
3222 if (comp
&& comp
== sym
->components
3223 && sym
->attr
.extension
3225 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
3227 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
3230 gfc_actual_arglist
*arg_null
= NULL
;
3232 actual
->expr
= comp_tail
->val
;
3233 comp_tail
->val
= NULL
;
3235 m
= gfc_convert_to_structure_constructor (NULL
,
3236 comp
->ts
.u
.derived
, &comp_tail
->val
,
3237 comp
->ts
.u
.derived
->attr
.zero_comp
3238 ? &arg_null
: &actual
, true);
3242 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
3251 if (parent
&& !comp
)
3255 actual
= actual
->next
;
3258 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
3261 /* No component should be left, as this should have caused an error in the
3262 loop constructing the component-list (name that does not correspond to any
3263 component in the structure definition). */
3264 if (comp_head
&& sym
->attr
.extension
)
3266 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3268 gfc_error ("component %qs at %L has already been set by a "
3269 "parent derived type constructor", comp_iter
->name
,
3275 gcc_assert (!comp_head
);
3279 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
3280 expr
->ts
.u
.derived
= sym
;
3281 expr
->value
.constructor
= ctor_head
;
3286 expr
->ts
.u
.derived
= sym
;
3288 expr
->ts
.type
= BT_DERIVED
;
3289 expr
->value
.constructor
= ctor_head
;
3290 expr
->expr_type
= EXPR_STRUCTURE
;
3293 gfc_current_locus
= old_locus
;
3299 gfc_current_locus
= old_locus
;
3301 for (comp_iter
= comp_head
; comp_iter
; )
3303 gfc_structure_ctor_component
*next
= comp_iter
->next
;
3304 gfc_free_structure_ctor_component (comp_iter
);
3307 gfc_constructor_free (ctor_head
);
3314 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
3318 gfc_symtree
*symtree
;
3320 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
3322 e
= gfc_get_expr ();
3323 e
->symtree
= symtree
;
3324 e
->expr_type
= EXPR_FUNCTION
;
3325 e
->where
= gfc_current_locus
;
3327 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
3328 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
3329 e
->value
.function
.esym
= sym
;
3330 e
->symtree
->n
.sym
->attr
.generic
= 1;
3332 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3339 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
3345 /* If a structure constructor is in a DATA statement, then each entity
3346 in the structure constructor must be a constant. Try to reduce the
3348 if (gfc_in_match_data ())
3349 gfc_reduce_init_expr (e
);
3356 /* If the symbol is an implicit do loop index and implicitly typed,
3357 it should not be host associated. Provide a symtree from the
3358 current namespace. */
3360 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
3362 if ((*sym
)->attr
.flavor
== FL_VARIABLE
3363 && (*sym
)->ns
!= gfc_current_ns
3364 && (*sym
)->attr
.implied_index
3365 && (*sym
)->attr
.implicit_type
3366 && !(*sym
)->attr
.use_assoc
)
3369 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
3372 *sym
= (*st
)->n
.sym
;
3378 /* Procedure pointer as function result: Replace the function symbol by the
3379 auto-generated hidden result variable named "ppr@". */
3382 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
3384 /* Check for procedure pointer result variable. */
3385 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
3386 && (*sym
)->result
&& (*sym
)->result
!= *sym
3387 && (*sym
)->result
->attr
.proc_pointer
3388 && (*sym
) == gfc_current_ns
->proc_name
3389 && (*sym
) == (*sym
)->result
->ns
->proc_name
3390 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3392 /* Automatic replacement with "hidden" result variable. */
3393 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3394 *sym
= (*sym
)->result
;
3395 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3402 /* Matches a variable name followed by anything that might follow it--
3403 array reference, argument list of a function, etc. */
3406 gfc_match_rvalue (gfc_expr
**result
)
3408 gfc_actual_arglist
*actual_arglist
;
3409 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3412 gfc_symtree
*symtree
;
3413 locus where
, old_loc
;
3421 m
= gfc_match ("%%loc");
3424 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3426 strncpy (name
, "loc", 4);
3431 m
= gfc_match_name (name
);
3436 /* Check if the symbol exists. */
3437 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3440 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3441 type. For derived types we create a generic symbol which links to the
3442 derived type symbol; STRUCTUREs are simpler and must not conflict with
3445 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3447 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3449 if (gfc_find_state (COMP_INTERFACE
)
3450 && !gfc_current_ns
->has_import_set
)
3451 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3453 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3459 sym
= symtree
->n
.sym
;
3461 where
= gfc_current_locus
;
3463 replace_hidden_procptr_result (&sym
, &symtree
);
3465 /* If this is an implicit do loop index and implicitly typed,
3466 it should not be host associated. */
3467 m
= check_for_implicit_index (&symtree
, &sym
);
3471 gfc_set_sym_referenced (sym
);
3472 sym
->attr
.implied_index
= 0;
3474 if (sym
->attr
.function
&& sym
->result
== sym
)
3476 /* See if this is a directly recursive function call. */
3477 gfc_gobble_whitespace ();
3478 if (sym
->attr
.recursive
3479 && gfc_peek_ascii_char () == '('
3480 && gfc_current_ns
->proc_name
== sym
3481 && !sym
->attr
.dimension
)
3483 gfc_error ("%qs at %C is the name of a recursive function "
3484 "and so refers to the result variable. Use an "
3485 "explicit RESULT variable for direct recursion "
3486 "(12.5.2.1)", sym
->name
);
3490 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3494 && (sym
->ns
== gfc_current_ns
3495 || sym
->ns
== gfc_current_ns
->parent
))
3497 gfc_entry_list
*el
= NULL
;
3499 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3505 if (gfc_matching_procptr_assignment
)
3507 /* It can be a procedure or a derived-type procedure or a not-yet-known
3509 if (sym
->attr
.flavor
!= FL_UNKNOWN
3510 && sym
->attr
.flavor
!= FL_PROCEDURE
3511 && sym
->attr
.flavor
!= FL_PARAMETER
3512 && sym
->attr
.flavor
!= FL_VARIABLE
)
3514 gfc_error ("Symbol at %C is not appropriate for an expression");
3520 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3523 if (sym
->attr
.generic
)
3524 goto generic_function
;
3526 switch (sym
->attr
.flavor
)
3530 e
= gfc_get_expr ();
3532 e
->expr_type
= EXPR_VARIABLE
;
3533 e
->symtree
= symtree
;
3535 m
= gfc_match_varspec (e
, 0, false, true);
3539 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3540 end up here. Unfortunately, sym->value->expr_type is set to
3541 EXPR_CONSTANT, and so the if () branch would be followed without
3542 the !sym->as check. */
3543 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3544 e
= gfc_copy_expr (sym
->value
);
3547 e
= gfc_get_expr ();
3548 e
->expr_type
= EXPR_VARIABLE
;
3551 e
->symtree
= symtree
;
3552 m
= gfc_match_varspec (e
, 0, false, true);
3554 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3557 /* Variable array references to derived type parameters cause
3558 all sorts of headaches in simplification. Treating such
3559 expressions as variable works just fine for all array
3561 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3563 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3564 if (ref
->type
== REF_ARRAY
)
3567 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3573 e
= gfc_get_expr ();
3574 e
->expr_type
= EXPR_VARIABLE
;
3575 e
->symtree
= symtree
;
3583 sym
= gfc_use_derived (sym
);
3587 goto generic_function
;
3590 /* If we're here, then the name is known to be the name of a
3591 procedure, yet it is not sure to be the name of a function. */
3594 /* Procedure Pointer Assignments. */
3596 if (gfc_matching_procptr_assignment
)
3598 gfc_gobble_whitespace ();
3599 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3600 /* Parse functions returning a procptr. */
3603 e
= gfc_get_expr ();
3604 e
->expr_type
= EXPR_VARIABLE
;
3605 e
->symtree
= symtree
;
3606 m
= gfc_match_varspec (e
, 0, false, true);
3607 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3608 && sym
->ts
.type
== BT_UNKNOWN
3609 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3617 if (sym
->attr
.subroutine
)
3619 gfc_error ("Unexpected use of subroutine name %qs at %C",
3625 /* At this point, the name has to be a non-statement function.
3626 If the name is the same as the current function being
3627 compiled, then we have a variable reference (to the function
3628 result) if the name is non-recursive. */
3630 st
= gfc_enclosing_unit (NULL
);
3633 && st
->state
== COMP_FUNCTION
3635 && !sym
->attr
.recursive
)
3637 e
= gfc_get_expr ();
3638 e
->symtree
= symtree
;
3639 e
->expr_type
= EXPR_VARIABLE
;
3641 m
= gfc_match_varspec (e
, 0, false, true);
3645 /* Match a function reference. */
3647 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3650 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3651 gfc_error ("Statement function %qs requires argument list at %C",
3654 gfc_error ("Function %qs requires an argument list at %C",
3667 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3668 sym
= symtree
->n
.sym
;
3670 replace_hidden_procptr_result (&sym
, &symtree
);
3672 e
= gfc_get_expr ();
3673 e
->symtree
= symtree
;
3674 e
->expr_type
= EXPR_FUNCTION
;
3675 e
->value
.function
.actual
= actual_arglist
;
3676 e
->where
= gfc_current_locus
;
3678 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3679 && CLASS_DATA (sym
)->as
)
3680 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3681 else if (sym
->as
!= NULL
)
3682 e
->rank
= sym
->as
->rank
;
3684 if (!sym
->attr
.function
3685 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3691 /* Check here for the existence of at least one argument for the
3692 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3693 argument(s) given will be checked in gfc_iso_c_func_interface,
3694 during resolution of the function call. */
3695 if (sym
->attr
.is_iso_c
== 1
3696 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3697 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3698 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3699 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3701 /* make sure we were given a param */
3702 if (actual_arglist
== NULL
)
3704 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3710 if (sym
->result
== NULL
)
3713 gfc_gobble_whitespace ();
3715 if (gfc_peek_ascii_char() == '%')
3717 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3718 "function reference at %C");
3728 /* Special case for derived type variables that get their types
3729 via an IMPLICIT statement. This can't wait for the
3730 resolution phase. */
3732 old_loc
= gfc_current_locus
;
3733 if (gfc_match_member_sep (sym
) == MATCH_YES
3734 && sym
->ts
.type
== BT_UNKNOWN
3735 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3736 gfc_set_default_type (sym
, 0, sym
->ns
);
3737 gfc_current_locus
= old_loc
;
3739 /* If the symbol has a (co)dimension attribute, the expression is a
3742 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3744 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3750 e
= gfc_get_expr ();
3751 e
->symtree
= symtree
;
3752 e
->expr_type
= EXPR_VARIABLE
;
3753 m
= gfc_match_varspec (e
, 0, false, true);
3757 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3758 && (CLASS_DATA (sym
)->attr
.dimension
3759 || CLASS_DATA (sym
)->attr
.codimension
))
3761 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3767 e
= gfc_get_expr ();
3768 e
->symtree
= symtree
;
3769 e
->expr_type
= EXPR_VARIABLE
;
3770 m
= gfc_match_varspec (e
, 0, false, true);
3774 /* Name is not an array, so we peek to see if a '(' implies a
3775 function call or a substring reference. Otherwise the
3776 variable is just a scalar. */
3778 gfc_gobble_whitespace ();
3779 if (gfc_peek_ascii_char () != '(')
3781 /* Assume a scalar variable */
3782 e
= gfc_get_expr ();
3783 e
->symtree
= symtree
;
3784 e
->expr_type
= EXPR_VARIABLE
;
3786 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3792 /*FIXME:??? gfc_match_varspec does set this for us: */
3794 m
= gfc_match_varspec (e
, 0, false, true);
3798 /* See if this is a function reference with a keyword argument
3799 as first argument. We do this because otherwise a spurious
3800 symbol would end up in the symbol table. */
3802 old_loc
= gfc_current_locus
;
3803 m2
= gfc_match (" ( %n =", argname
);
3804 gfc_current_locus
= old_loc
;
3806 e
= gfc_get_expr ();
3807 e
->symtree
= symtree
;
3809 if (m2
!= MATCH_YES
)
3811 /* Try to figure out whether we're dealing with a character type.
3812 We're peeking ahead here, because we don't want to call
3813 match_substring if we're dealing with an implicitly typed
3814 non-character variable. */
3815 implicit_char
= false;
3816 if (sym
->ts
.type
== BT_UNKNOWN
)
3818 ts
= gfc_get_default_type (sym
->name
, NULL
);
3819 if (ts
->type
== BT_CHARACTER
)
3820 implicit_char
= true;
3823 /* See if this could possibly be a substring reference of a name
3824 that we're not sure is a variable yet. */
3826 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3827 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3830 e
->expr_type
= EXPR_VARIABLE
;
3832 if (sym
->attr
.flavor
!= FL_VARIABLE
3833 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3840 if (sym
->ts
.type
== BT_UNKNOWN
3841 && !gfc_set_default_type (sym
, 1, NULL
))
3855 /* Give up, assume we have a function. */
3857 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3858 sym
= symtree
->n
.sym
;
3859 e
->expr_type
= EXPR_FUNCTION
;
3861 if (!sym
->attr
.function
3862 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3870 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3872 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3880 /* If our new function returns a character, array or structure
3881 type, it might have subsequent references. */
3883 m
= gfc_match_varspec (e
, 0, false, true);
3890 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3891 specially. Creates a generic symbol for derived types. */
3892 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3894 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3895 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3896 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3898 e
= gfc_get_expr ();
3899 e
->symtree
= symtree
;
3900 e
->expr_type
= EXPR_FUNCTION
;
3902 if (gfc_fl_struct (sym
->attr
.flavor
))
3904 e
->value
.function
.esym
= sym
;
3905 e
->symtree
->n
.sym
->attr
.generic
= 1;
3908 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3916 gfc_error ("Symbol at %C is not appropriate for an expression");
3932 /* Match a variable, i.e. something that can be assigned to. This
3933 starts as a symbol, can be a structure component or an array
3934 reference. It can be a function if the function doesn't have a
3935 separate RESULT variable. If the symbol has not been previously
3936 seen, we assume it is a variable.
3938 This function is called by two interface functions:
3939 gfc_match_variable, which has host_flag = 1, and
3940 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3941 match of the symbol to the local scope. */
3944 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3946 gfc_symbol
*sym
, *dt_sym
;
3949 locus where
, old_loc
;
3952 /* Since nothing has any business being an lvalue in a module
3953 specification block, an interface block or a contains section,
3954 we force the changed_symbols mechanism to work by setting
3955 host_flag to 0. This prevents valid symbols that have the name
3956 of keywords, such as 'end', being turned into variables by
3957 failed matching to assignments for, e.g., END INTERFACE. */
3958 if (gfc_current_state () == COMP_MODULE
3959 || gfc_current_state () == COMP_SUBMODULE
3960 || gfc_current_state () == COMP_INTERFACE
3961 || gfc_current_state () == COMP_CONTAINS
)
3964 where
= gfc_current_locus
;
3965 m
= gfc_match_sym_tree (&st
, host_flag
);
3971 /* If this is an implicit do loop index and implicitly typed,
3972 it should not be host associated. */
3973 m
= check_for_implicit_index (&st
, &sym
);
3977 sym
->attr
.implied_index
= 0;
3979 gfc_set_sym_referenced (sym
);
3981 /* STRUCTUREs may share names with variables, but derived types may not. */
3982 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3983 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3985 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3986 gfc_error ("Derived type %qs cannot be used as a variable at %C",
3991 switch (sym
->attr
.flavor
)
3994 /* Everything is alright. */
3999 sym_flavor flavor
= FL_UNKNOWN
;
4001 gfc_gobble_whitespace ();
4003 if (sym
->attr
.external
|| sym
->attr
.procedure
4004 || sym
->attr
.function
|| sym
->attr
.subroutine
)
4005 flavor
= FL_PROCEDURE
;
4007 /* If it is not a procedure, is not typed and is host associated,
4008 we cannot give it a flavor yet. */
4009 else if (sym
->ns
== gfc_current_ns
->parent
4010 && sym
->ts
.type
== BT_UNKNOWN
)
4013 /* These are definitive indicators that this is a variable. */
4014 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
4015 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
4016 flavor
= FL_VARIABLE
;
4018 if (flavor
!= FL_UNKNOWN
4019 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
4027 gfc_error ("Named constant at %C in an EQUIVALENCE");
4030 /* Otherwise this is checked for and an error given in the
4031 variable definition context checks. */
4035 /* Check for a nonrecursive function result variable. */
4036 if (sym
->attr
.function
4037 && !sym
->attr
.external
4038 && sym
->result
== sym
4039 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
4041 && sym
->ns
== gfc_current_ns
)
4043 && sym
->ns
== gfc_current_ns
->parent
)))
4045 /* If a function result is a derived type, then the derived
4046 type may still have to be resolved. */
4048 if (sym
->ts
.type
== BT_DERIVED
4049 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
4054 if (sym
->attr
.proc_pointer
4055 || replace_hidden_procptr_result (&sym
, &st
))
4058 /* Fall through to error */
4062 gfc_error ("%qs at %C is not a variable", sym
->name
);
4066 /* Special case for derived type variables that get their types
4067 via an IMPLICIT statement. This can't wait for the
4068 resolution phase. */
4071 gfc_namespace
* implicit_ns
;
4073 if (gfc_current_ns
->proc_name
== sym
)
4074 implicit_ns
= gfc_current_ns
;
4076 implicit_ns
= sym
->ns
;
4078 old_loc
= gfc_current_locus
;
4079 if (gfc_match_member_sep (sym
) == MATCH_YES
4080 && sym
->ts
.type
== BT_UNKNOWN
4081 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
4082 gfc_set_default_type (sym
, 0, implicit_ns
);
4083 gfc_current_locus
= old_loc
;
4086 expr
= gfc_get_expr ();
4088 expr
->expr_type
= EXPR_VARIABLE
;
4091 expr
->where
= where
;
4093 /* Now see if we have to do more. */
4094 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
4097 gfc_free_expr (expr
);
4107 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
4109 return match_variable (result
, equiv_flag
, 1);
4114 gfc_match_equiv_variable (gfc_expr
**result
)
4116 return match_variable (result
, 1, 0);