1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
32 int matching_actual_arglist
= 0;
34 /* Matches a kind-parameter expression, which is either a named
35 symbolic constant or a nonnegative integer constant. If
36 successful, sets the kind value to the correct integer.
37 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
38 symbol like e.g. 'c_int'. */
41 match_kind_param (int *kind
, int *is_iso_c
)
43 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
50 m
= gfc_match_small_literal_int (kind
, NULL
);
54 m
= gfc_match_name (name
);
58 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
64 *is_iso_c
= sym
->attr
.is_iso_c
;
66 if (sym
->attr
.flavor
!= FL_PARAMETER
)
69 if (sym
->value
== NULL
)
72 p
= gfc_extract_int (sym
->value
, kind
);
76 gfc_set_sym_referenced (sym
);
85 /* Get a trailing kind-specification for non-character variables.
87 * the integer kind value or
88 * -1 if an error was generated,
89 * -2 if no kind was found.
90 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
91 symbol like e.g. 'c_int'. */
94 get_kind (int *is_iso_c
)
101 if (gfc_match_char ('_') != MATCH_YES
)
104 m
= match_kind_param (&kind
, is_iso_c
);
106 gfc_error ("Missing kind-parameter at %C");
108 return (m
== MATCH_YES
) ? kind
: -1;
112 /* Given a character and a radix, see if the character is a valid
113 digit in that radix. */
116 gfc_check_digit (char c
, int radix
)
123 r
= ('0' <= c
&& c
<= '1');
127 r
= ('0' <= c
&& c
<= '7');
131 r
= ('0' <= c
&& c
<= '9');
139 gfc_internal_error ("gfc_check_digit(): bad radix");
146 /* Match the digit string part of an integer if signflag is not set,
147 the signed digit string part if signflag is set. If the buffer
148 is NULL, we just count characters for the resolution pass. Returns
149 the number of characters matched, -1 for no match. */
152 match_digits (int signflag
, int radix
, char *buffer
)
159 c
= gfc_next_ascii_char ();
161 if (signflag
&& (c
== '+' || c
== '-'))
165 gfc_gobble_whitespace ();
166 c
= gfc_next_ascii_char ();
170 if (!gfc_check_digit (c
, radix
))
179 old_loc
= gfc_current_locus
;
180 c
= gfc_next_ascii_char ();
182 if (!gfc_check_digit (c
, radix
))
190 gfc_current_locus
= old_loc
;
196 /* Match an integer (digit string and optional kind).
197 A sign will be accepted if signflag is set. */
200 match_integer_constant (gfc_expr
**result
, int signflag
)
202 int length
, kind
, is_iso_c
;
207 old_loc
= gfc_current_locus
;
208 gfc_gobble_whitespace ();
210 length
= match_digits (signflag
, 10, NULL
);
211 gfc_current_locus
= old_loc
;
215 buffer
= (char *) alloca (length
+ 1);
216 memset (buffer
, '\0', length
+ 1);
218 gfc_gobble_whitespace ();
220 match_digits (signflag
, 10, buffer
);
222 kind
= get_kind (&is_iso_c
);
224 kind
= gfc_default_integer_kind
;
228 if (kind
== 4 && gfc_option
.flag_integer4_kind
== 8)
231 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
233 gfc_error ("Integer kind %d at %C not available", kind
);
237 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
238 e
->ts
.is_c_interop
= is_iso_c
;
240 if (gfc_range_check (e
) != ARITH_OK
)
242 gfc_error ("Integer too big for its kind at %C. This check can be "
243 "disabled with the option -fno-range-check");
254 /* Match a Hollerith constant. */
257 match_hollerith_constant (gfc_expr
**result
)
265 old_loc
= gfc_current_locus
;
266 gfc_gobble_whitespace ();
268 if (match_integer_constant (&e
, 0) == MATCH_YES
269 && gfc_match_char ('h') == MATCH_YES
)
271 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Hollerith constant "
275 msg
= gfc_extract_int (e
, &num
);
283 gfc_error ("Invalid Hollerith constant: %L must contain at least "
284 "one character", &old_loc
);
287 if (e
->ts
.kind
!= gfc_default_integer_kind
)
289 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
290 "should be default", &old_loc
);
296 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
299 /* Calculate padding needed to fit default integer memory. */
300 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
302 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
304 for (i
= 0; i
< num
; i
++)
306 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
307 if (! gfc_wide_fits_in_byte (c
))
309 gfc_error ("Invalid Hollerith constant at %L contains a "
310 "wide character", &old_loc
);
314 e
->representation
.string
[i
] = (unsigned char) c
;
317 /* Now pad with blanks and end with a null char. */
318 for (i
= 0; i
< pad
; i
++)
319 e
->representation
.string
[num
+ i
] = ' ';
321 e
->representation
.string
[num
+ i
] = '\0';
322 e
->representation
.length
= num
+ pad
;
331 gfc_current_locus
= old_loc
;
340 /* Match a binary, octal or hexadecimal constant that can be found in
341 a DATA statement. The standard permits b'010...', o'73...', and
342 z'a1...' where b, o, and z can be capital letters. This function
343 also accepts postfixed forms of the constants: '01...'b, '73...'o,
344 and 'a1...'z. An additional extension is the use of x for z. */
347 match_boz_constant (gfc_expr
**result
)
349 int radix
, length
, x_hex
, kind
;
350 locus old_loc
, start_loc
;
351 char *buffer
, post
, delim
;
354 start_loc
= old_loc
= gfc_current_locus
;
355 gfc_gobble_whitespace ();
358 switch (post
= gfc_next_ascii_char ())
380 radix
= 16; /* Set to accept any valid digit string. */
386 /* No whitespace allowed here. */
389 delim
= gfc_next_ascii_char ();
391 if (delim
!= '\'' && delim
!= '\"')
395 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
396 "constant at %C uses non-standard syntax")
400 old_loc
= gfc_current_locus
;
402 length
= match_digits (0, radix
, NULL
);
405 gfc_error ("Empty set of digits in BOZ constant at %C");
409 if (gfc_next_ascii_char () != delim
)
411 gfc_error ("Illegal character in BOZ constant at %C");
417 switch (gfc_next_ascii_char ())
434 if (gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ constant "
435 "at %C uses non-standard postfix syntax")
440 gfc_current_locus
= old_loc
;
442 buffer
= (char *) alloca (length
+ 1);
443 memset (buffer
, '\0', length
+ 1);
445 match_digits (0, radix
, buffer
);
446 gfc_next_ascii_char (); /* Eat delimiter. */
448 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
450 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
451 "If a data-stmt-constant is a boz-literal-constant, the corresponding
452 variable shall be of type integer. The boz-literal-constant is treated
453 as if it were an int-literal-constant with a kind-param that specifies
454 the representation method with the largest decimal exponent range
455 supported by the processor." */
457 kind
= gfc_max_integer_kind
;
458 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
460 /* Mark as boz variable. */
463 if (gfc_range_check (e
) != ARITH_OK
)
465 gfc_error ("Integer too big for integer kind %i at %C", kind
);
470 if (!gfc_in_match_data ()
471 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BOZ used outside a DATA "
480 gfc_current_locus
= start_loc
;
485 /* Match a real constant of some sort. Allow a signed constant if signflag
489 match_real_constant (gfc_expr
**result
, int signflag
)
491 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
;
492 locus old_loc
, temp_loc
;
493 char *p
, *buffer
, c
, exp_char
;
497 old_loc
= gfc_current_locus
;
498 gfc_gobble_whitespace ();
508 c
= gfc_next_ascii_char ();
509 if (signflag
&& (c
== '+' || c
== '-'))
514 gfc_gobble_whitespace ();
515 c
= gfc_next_ascii_char ();
518 /* Scan significand. */
519 for (;; c
= gfc_next_ascii_char (), count
++)
526 /* Check to see if "." goes with a following operator like
528 temp_loc
= gfc_current_locus
;
529 c
= gfc_next_ascii_char ();
531 if (c
== 'e' || c
== 'd' || c
== 'q')
533 c
= gfc_next_ascii_char ();
535 goto done
; /* Operator named .e. or .d. */
539 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
541 gfc_current_locus
= temp_loc
;
555 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
562 if (gfc_notify_std (GFC_STD_GNU
, "Extension: exponent-letter 'q' in "
563 "real-literal-constant at %C") == FAILURE
)
565 else if (gfc_option
.warn_real_q_constant
)
566 gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
571 c
= gfc_next_ascii_char ();
574 if (c
== '+' || c
== '-')
575 { /* optional sign */
576 c
= gfc_next_ascii_char ();
582 gfc_error ("Missing exponent in real number at %C");
588 c
= gfc_next_ascii_char ();
593 /* Check that we have a numeric constant. */
594 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
596 gfc_current_locus
= old_loc
;
600 /* Convert the number. */
601 gfc_current_locus
= old_loc
;
602 gfc_gobble_whitespace ();
604 buffer
= (char *) alloca (count
+ 1);
605 memset (buffer
, '\0', count
+ 1);
608 c
= gfc_next_ascii_char ();
609 if (c
== '+' || c
== '-')
611 gfc_gobble_whitespace ();
612 c
= gfc_next_ascii_char ();
615 /* Hack for mpfr_set_str(). */
618 if (c
== 'd' || c
== 'q')
626 c
= gfc_next_ascii_char ();
629 kind
= get_kind (&is_iso_c
);
638 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
642 kind
= gfc_default_double_kind
;
646 if (gfc_option
.flag_real4_kind
== 8)
648 if (gfc_option
.flag_real4_kind
== 10)
650 if (gfc_option
.flag_real4_kind
== 16)
656 if (gfc_option
.flag_real8_kind
== 4)
658 if (gfc_option
.flag_real8_kind
== 10)
660 if (gfc_option
.flag_real8_kind
== 16)
668 gfc_error ("Real number at %C has a 'q' exponent and an explicit "
673 /* The maximum possible real kind type parameter is 16. First, try
674 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
675 extended precision. If neither value works, just given up. */
677 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
680 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
682 gfc_error ("Invalid exponent-letter 'q' in "
683 "real-literal-constant at %C");
691 kind
= gfc_default_real_kind
;
695 if (gfc_option
.flag_real4_kind
== 8)
697 if (gfc_option
.flag_real4_kind
== 10)
699 if (gfc_option
.flag_real4_kind
== 16)
705 if (gfc_option
.flag_real8_kind
== 4)
707 if (gfc_option
.flag_real8_kind
== 10)
709 if (gfc_option
.flag_real8_kind
== 16)
713 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
715 gfc_error ("Invalid real kind %d at %C", kind
);
720 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
722 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
723 e
->ts
.is_c_interop
= is_iso_c
;
725 switch (gfc_range_check (e
))
730 gfc_error ("Real constant overflows its kind at %C");
733 case ARITH_UNDERFLOW
:
734 if (gfc_option
.warn_underflow
)
735 gfc_warning ("Real constant underflows its kind at %C");
736 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
740 gfc_internal_error ("gfc_range_check() returned bad value");
752 /* Match a substring reference. */
755 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
757 gfc_expr
*start
, *end
;
765 old_loc
= gfc_current_locus
;
767 m
= gfc_match_char ('(');
771 if (gfc_match_char (':') != MATCH_YES
)
774 m
= gfc_match_init_expr (&start
);
776 m
= gfc_match_expr (&start
);
784 m
= gfc_match_char (':');
789 if (gfc_match_char (')') != MATCH_YES
)
792 m
= gfc_match_init_expr (&end
);
794 m
= gfc_match_expr (&end
);
798 if (m
== MATCH_ERROR
)
801 m
= gfc_match_char (')');
806 /* Optimize away the (:) reference. */
807 if (start
== NULL
&& end
== NULL
)
811 ref
= gfc_get_ref ();
813 ref
->type
= REF_SUBSTRING
;
815 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
816 ref
->u
.ss
.start
= start
;
817 if (end
== NULL
&& cl
)
818 end
= gfc_copy_expr (cl
->length
);
820 ref
->u
.ss
.length
= cl
;
827 gfc_error ("Syntax error in SUBSTRING specification at %C");
831 gfc_free_expr (start
);
834 gfc_current_locus
= old_loc
;
839 /* Reads the next character of a string constant, taking care to
840 return doubled delimiters on the input as a single instance of
843 Special return values for "ret" argument are:
844 -1 End of the string, as determined by the delimiter
845 -2 Unterminated string detected
847 Backslash codes are also expanded at this time. */
850 next_string_char (gfc_char_t delimiter
, int *ret
)
855 c
= gfc_next_char_literal (INSTRING_WARN
);
864 if (gfc_option
.flag_backslash
&& c
== '\\')
866 old_locus
= gfc_current_locus
;
868 if (gfc_match_special_char (&c
) == MATCH_NO
)
869 gfc_current_locus
= old_locus
;
871 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
872 gfc_warning ("Extension: backslash character at %C");
878 old_locus
= gfc_current_locus
;
879 c
= gfc_next_char_literal (NONSTRING
);
883 gfc_current_locus
= old_locus
;
890 /* Special case of gfc_match_name() that matches a parameter kind name
891 before a string constant. This takes case of the weird but legal
896 where kind____ is a parameter. gfc_match_name() will happily slurp
897 up all the underscores, which leads to problems. If we return
898 MATCH_YES, the parse pointer points to the final underscore, which
899 is not part of the name. We never return MATCH_ERROR-- errors in
900 the name will be detected later. */
903 match_charkind_name (char *name
)
909 gfc_gobble_whitespace ();
910 c
= gfc_next_ascii_char ();
919 old_loc
= gfc_current_locus
;
920 c
= gfc_next_ascii_char ();
924 peek
= gfc_peek_ascii_char ();
926 if (peek
== '\'' || peek
== '\"')
928 gfc_current_locus
= old_loc
;
936 && (c
!= '$' || !gfc_option
.flag_dollar_ok
))
940 if (++len
> GFC_MAX_SYMBOL_LEN
)
948 /* See if the current input matches a character constant. Lots of
949 contortions have to be done to match the kind parameter which comes
950 before the actual string. The main consideration is that we don't
951 want to error out too quickly. For example, we don't actually do
952 any validation of the kinds until we have actually seen a legal
953 delimiter. Using match_kind_param() generates errors too quickly. */
956 match_string_constant (gfc_expr
**result
)
958 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
959 int i
, kind
, length
, warn_ampersand
, ret
;
960 locus old_locus
, start_locus
;
965 gfc_char_t c
, delimiter
, *p
;
967 old_locus
= gfc_current_locus
;
969 gfc_gobble_whitespace ();
971 c
= gfc_next_char ();
972 if (c
== '\'' || c
== '"')
974 kind
= gfc_default_character_kind
;
975 start_locus
= gfc_current_locus
;
979 if (gfc_wide_is_digit (c
))
983 while (gfc_wide_is_digit (c
))
985 kind
= kind
* 10 + c
- '0';
988 c
= gfc_next_char ();
994 gfc_current_locus
= old_locus
;
996 m
= match_charkind_name (name
);
1000 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1002 || sym
->attr
.flavor
!= FL_PARAMETER
)
1006 c
= gfc_next_char ();
1011 gfc_gobble_whitespace ();
1012 c
= gfc_next_char ();
1018 gfc_gobble_whitespace ();
1020 c
= gfc_next_char ();
1021 if (c
!= '\'' && c
!= '"')
1024 start_locus
= gfc_current_locus
;
1028 q
= gfc_extract_int (sym
->value
, &kind
);
1034 gfc_set_sym_referenced (sym
);
1037 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1039 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1044 /* Scan the string into a block of memory by first figuring out how
1045 long it is, allocating the structure, then re-reading it. This
1046 isn't particularly efficient, but string constants aren't that
1047 common in most code. TODO: Use obstacks? */
1054 c
= next_string_char (delimiter
, &ret
);
1059 gfc_current_locus
= start_locus
;
1060 gfc_error ("Unterminated character constant beginning at %C");
1067 /* Peek at the next character to see if it is a b, o, z, or x for the
1068 postfixed BOZ literal constants. */
1069 peek
= gfc_peek_ascii_char ();
1070 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1073 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1075 gfc_current_locus
= start_locus
;
1077 /* We disable the warning for the following loop as the warning has already
1078 been printed in the loop above. */
1079 warn_ampersand
= gfc_option
.warn_ampersand
;
1080 gfc_option
.warn_ampersand
= 0;
1082 p
= e
->value
.character
.string
;
1083 for (i
= 0; i
< length
; i
++)
1085 c
= next_string_char (delimiter
, &ret
);
1087 if (!gfc_check_character_range (c
, kind
))
1089 gfc_error ("Character '%s' in string at %C is not representable "
1090 "in character kind %d", gfc_print_wide_char (c
), kind
);
1097 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1098 gfc_option
.warn_ampersand
= warn_ampersand
;
1100 next_string_char (delimiter
, &ret
);
1102 gfc_internal_error ("match_string_constant(): Delimiter not found");
1104 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1105 e
->expr_type
= EXPR_SUBSTRING
;
1112 gfc_current_locus
= old_locus
;
1117 /* Match a .true. or .false. Returns 1 if a .true. was found,
1118 0 if a .false. was found, and -1 otherwise. */
1120 match_logical_constant_string (void)
1122 locus orig_loc
= gfc_current_locus
;
1124 gfc_gobble_whitespace ();
1125 if (gfc_next_ascii_char () == '.')
1127 char ch
= gfc_next_ascii_char ();
1130 if (gfc_next_ascii_char () == 'a'
1131 && gfc_next_ascii_char () == 'l'
1132 && gfc_next_ascii_char () == 's'
1133 && gfc_next_ascii_char () == 'e'
1134 && gfc_next_ascii_char () == '.')
1135 /* Matched ".false.". */
1140 if (gfc_next_ascii_char () == 'r'
1141 && gfc_next_ascii_char () == 'u'
1142 && gfc_next_ascii_char () == 'e'
1143 && gfc_next_ascii_char () == '.')
1144 /* Matched ".true.". */
1148 gfc_current_locus
= orig_loc
;
1152 /* Match a .true. or .false. */
1155 match_logical_constant (gfc_expr
**result
)
1158 int i
, kind
, is_iso_c
;
1160 i
= match_logical_constant_string ();
1164 kind
= get_kind (&is_iso_c
);
1168 kind
= gfc_default_logical_kind
;
1170 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1172 gfc_error ("Bad kind for logical constant at %C");
1176 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1177 e
->ts
.is_c_interop
= is_iso_c
;
1184 /* Match a real or imaginary part of a complex constant that is a
1185 symbolic constant. */
1188 match_sym_complex_part (gfc_expr
**result
)
1190 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1195 m
= gfc_match_name (name
);
1199 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1202 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1204 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1208 if (!gfc_numeric_ts (&sym
->value
->ts
))
1210 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1214 if (sym
->value
->rank
!= 0)
1216 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1220 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PARAMETER symbol in "
1221 "complex constant at %C") == FAILURE
)
1224 switch (sym
->value
->ts
.type
)
1227 e
= gfc_copy_expr (sym
->value
);
1231 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1237 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1243 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1246 *result
= e
; /* e is a scalar, real, constant expression. */
1250 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1255 /* Match a real or imaginary part of a complex number. */
1258 match_complex_part (gfc_expr
**result
)
1262 m
= match_sym_complex_part (result
);
1266 m
= match_real_constant (result
, 1);
1270 return match_integer_constant (result
, 1);
1274 /* Try to match a complex constant. */
1277 match_complex_constant (gfc_expr
**result
)
1279 gfc_expr
*e
, *real
, *imag
;
1280 gfc_error_buf old_error
;
1281 gfc_typespec target
;
1286 old_loc
= gfc_current_locus
;
1287 real
= imag
= e
= NULL
;
1289 m
= gfc_match_char ('(');
1293 gfc_push_error (&old_error
);
1295 m
= match_complex_part (&real
);
1298 gfc_free_error (&old_error
);
1302 if (gfc_match_char (',') == MATCH_NO
)
1304 gfc_pop_error (&old_error
);
1309 /* If m is error, then something was wrong with the real part and we
1310 assume we have a complex constant because we've seen the ','. An
1311 ambiguous case here is the start of an iterator list of some
1312 sort. These sort of lists are matched prior to coming here. */
1314 if (m
== MATCH_ERROR
)
1316 gfc_free_error (&old_error
);
1319 gfc_pop_error (&old_error
);
1321 m
= match_complex_part (&imag
);
1324 if (m
== MATCH_ERROR
)
1327 m
= gfc_match_char (')');
1330 /* Give the matcher for implied do-loops a chance to run. This
1331 yields a much saner error message for (/ (i, 4=i, 6) /). */
1332 if (gfc_peek_ascii_char () == '=')
1341 if (m
== MATCH_ERROR
)
1344 /* Decide on the kind of this complex number. */
1345 if (real
->ts
.type
== BT_REAL
)
1347 if (imag
->ts
.type
== BT_REAL
)
1348 kind
= gfc_kind_max (real
, imag
);
1350 kind
= real
->ts
.kind
;
1354 if (imag
->ts
.type
== BT_REAL
)
1355 kind
= imag
->ts
.kind
;
1357 kind
= gfc_default_real_kind
;
1359 gfc_clear_ts (&target
);
1360 target
.type
= BT_REAL
;
1363 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1364 gfc_convert_type (real
, &target
, 2);
1365 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1366 gfc_convert_type (imag
, &target
, 2);
1368 e
= gfc_convert_complex (real
, imag
, kind
);
1369 e
->where
= gfc_current_locus
;
1371 gfc_free_expr (real
);
1372 gfc_free_expr (imag
);
1378 gfc_error ("Syntax error in COMPLEX constant at %C");
1383 gfc_free_expr (real
);
1384 gfc_free_expr (imag
);
1385 gfc_current_locus
= old_loc
;
1391 /* Match constants in any of several forms. Returns nonzero for a
1392 match, zero for no match. */
1395 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1399 m
= match_complex_constant (result
);
1403 m
= match_string_constant (result
);
1407 m
= match_boz_constant (result
);
1411 m
= match_real_constant (result
, signflag
);
1415 m
= match_hollerith_constant (result
);
1419 m
= match_integer_constant (result
, signflag
);
1423 m
= match_logical_constant (result
);
1431 /* This checks if a symbol is the return value of an encompassing function.
1432 Function nesting can be maximally two levels deep, but we may have
1433 additional local namespaces like BLOCK etc. */
1436 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1438 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1442 if (ns
->proc_name
== sym
)
1450 /* Match a single actual argument value. An actual argument is
1451 usually an expression, but can also be a procedure name. If the
1452 argument is a single name, it is not always possible to tell
1453 whether the name is a dummy procedure or not. We treat these cases
1454 by creating an argument that looks like a dummy procedure and
1455 fixing things later during resolution. */
1458 match_actual_arg (gfc_expr
**result
)
1460 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1461 gfc_symtree
*symtree
;
1466 gfc_gobble_whitespace ();
1467 where
= gfc_current_locus
;
1469 switch (gfc_match_name (name
))
1478 w
= gfc_current_locus
;
1479 gfc_gobble_whitespace ();
1480 c
= gfc_next_ascii_char ();
1481 gfc_current_locus
= w
;
1483 if (c
!= ',' && c
!= ')')
1486 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1488 /* Handle error elsewhere. */
1490 /* Eliminate a couple of common cases where we know we don't
1491 have a function argument. */
1492 if (symtree
== NULL
)
1494 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1495 gfc_set_sym_referenced (symtree
->n
.sym
);
1501 sym
= symtree
->n
.sym
;
1502 gfc_set_sym_referenced (sym
);
1503 if (sym
->attr
.flavor
!= FL_PROCEDURE
1504 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1507 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1509 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
,
1514 /* If the symbol is a function with itself as the result and
1515 is being defined, then we have a variable. */
1516 if (sym
->attr
.function
&& sym
->result
== sym
)
1518 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1522 && (sym
->ns
== gfc_current_ns
1523 || sym
->ns
== gfc_current_ns
->parent
))
1525 gfc_entry_list
*el
= NULL
;
1527 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1537 e
= gfc_get_expr (); /* Leave it unknown for now */
1538 e
->symtree
= symtree
;
1539 e
->expr_type
= EXPR_VARIABLE
;
1540 e
->ts
.type
= BT_PROCEDURE
;
1547 gfc_current_locus
= where
;
1548 return gfc_match_expr (result
);
1552 /* Match a keyword argument. */
1555 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1557 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1558 gfc_actual_arglist
*a
;
1562 name_locus
= gfc_current_locus
;
1563 m
= gfc_match_name (name
);
1567 if (gfc_match_char ('=') != MATCH_YES
)
1573 m
= match_actual_arg (&actual
->expr
);
1577 /* Make sure this name has not appeared yet. */
1579 if (name
[0] != '\0')
1581 for (a
= base
; a
; a
= a
->next
)
1582 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1584 gfc_error ("Keyword '%s' at %C has already appeared in the "
1585 "current argument list", name
);
1590 actual
->name
= gfc_get_string (name
);
1594 gfc_current_locus
= name_locus
;
1599 /* Match an argument list function, such as %VAL. */
1602 match_arg_list_function (gfc_actual_arglist
*result
)
1604 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1608 old_locus
= gfc_current_locus
;
1610 if (gfc_match_char ('%') != MATCH_YES
)
1616 m
= gfc_match ("%n (", name
);
1620 if (name
[0] != '\0')
1625 if (strncmp (name
, "loc", 3) == 0)
1627 result
->name
= "%LOC";
1631 if (strncmp (name
, "ref", 3) == 0)
1633 result
->name
= "%REF";
1637 if (strncmp (name
, "val", 3) == 0)
1639 result
->name
= "%VAL";
1648 if (gfc_notify_std (GFC_STD_GNU
, "Extension: argument list "
1649 "function at %C") == FAILURE
)
1655 m
= match_actual_arg (&result
->expr
);
1659 if (gfc_match_char (')') != MATCH_YES
)
1668 gfc_current_locus
= old_locus
;
1673 /* Matches an actual argument list of a function or subroutine, from
1674 the opening parenthesis to the closing parenthesis. The argument
1675 list is assumed to allow keyword arguments because we don't know if
1676 the symbol associated with the procedure has an implicit interface
1677 or not. We make sure keywords are unique. If sub_flag is set,
1678 we're matching the argument list of a subroutine. */
1681 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1683 gfc_actual_arglist
*head
, *tail
;
1685 gfc_st_label
*label
;
1689 *argp
= tail
= NULL
;
1690 old_loc
= gfc_current_locus
;
1694 if (gfc_match_char ('(') == MATCH_NO
)
1695 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1697 if (gfc_match_char (')') == MATCH_YES
)
1701 matching_actual_arglist
++;
1706 head
= tail
= gfc_get_actual_arglist ();
1709 tail
->next
= gfc_get_actual_arglist ();
1713 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1715 m
= gfc_match_st_label (&label
);
1717 gfc_error ("Expected alternate return label at %C");
1721 tail
->label
= label
;
1725 /* After the first keyword argument is seen, the following
1726 arguments must also have keywords. */
1729 m
= match_keyword_arg (tail
, head
);
1731 if (m
== MATCH_ERROR
)
1735 gfc_error ("Missing keyword name in actual argument list at %C");
1742 /* Try an argument list function, like %VAL. */
1743 m
= match_arg_list_function (tail
);
1744 if (m
== MATCH_ERROR
)
1747 /* See if we have the first keyword argument. */
1750 m
= match_keyword_arg (tail
, head
);
1753 if (m
== MATCH_ERROR
)
1759 /* Try for a non-keyword argument. */
1760 m
= match_actual_arg (&tail
->expr
);
1761 if (m
== MATCH_ERROR
)
1770 if (gfc_match_char (')') == MATCH_YES
)
1772 if (gfc_match_char (',') != MATCH_YES
)
1777 matching_actual_arglist
--;
1781 gfc_error ("Syntax error in argument list at %C");
1784 gfc_free_actual_arglist (head
);
1785 gfc_current_locus
= old_loc
;
1786 matching_actual_arglist
--;
1791 /* Used by gfc_match_varspec() to extend the reference list by one
1795 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1797 if (primary
->ref
== NULL
)
1798 primary
->ref
= tail
= gfc_get_ref ();
1802 gfc_internal_error ("extend_ref(): Bad tail");
1803 tail
->next
= gfc_get_ref ();
1811 /* Match any additional specifications associated with the current
1812 variable like member references or substrings. If equiv_flag is
1813 set we only match stuff that is allowed inside an EQUIVALENCE
1814 statement. sub_flag tells whether we expect a type-bound procedure found
1815 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1816 components, 'ppc_arg' determines whether the PPC may be called (with an
1817 argument list), or whether it may just be referred to as a pointer. */
1820 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1823 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1824 gfc_ref
*substring
, *tail
;
1825 gfc_component
*component
;
1826 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1832 gfc_gobble_whitespace ();
1834 if (gfc_peek_ascii_char () == '[')
1836 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1837 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1838 && CLASS_DATA (sym
)->attr
.dimension
))
1840 gfc_error ("Array section designator, e.g. '(:)', is required "
1841 "besides the coarray designator '[...]' at %C");
1844 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1845 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1846 && !CLASS_DATA (sym
)->attr
.codimension
))
1848 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1854 /* For associate names, we may not yet know whether they are arrays or not.
1855 Thus if we have one and parentheses follow, we have to assume that it
1856 actually is one for now. The final decision will be made at
1857 resolution time, of course. */
1858 if (sym
->assoc
&& gfc_peek_ascii_char () == '(')
1859 sym
->attr
.dimension
= 1;
1861 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1862 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1863 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1864 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
, NULL
)
1865 && !(gfc_matching_procptr_assignment
1866 && sym
->attr
.flavor
== FL_PROCEDURE
))
1867 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1868 && (CLASS_DATA (sym
)->attr
.dimension
1869 || CLASS_DATA (sym
)->attr
.codimension
)))
1873 tail
= extend_ref (primary
, tail
);
1874 tail
->type
= REF_ARRAY
;
1876 /* In EQUIVALENCE, we don't know yet whether we are seeing
1877 an array, character variable or array of character
1878 variables. We'll leave the decision till resolve time. */
1882 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1883 as
= CLASS_DATA (sym
)->as
;
1887 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1888 as
? as
->corank
: 0);
1892 gfc_gobble_whitespace ();
1893 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1895 tail
= extend_ref (primary
, tail
);
1896 tail
->type
= REF_ARRAY
;
1898 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1904 primary
->ts
= sym
->ts
;
1909 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1910 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1911 gfc_set_default_type (sym
, 0, sym
->ns
);
1913 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_match_char ('%') == MATCH_YES
)
1915 gfc_error ("Symbol '%s' at %C has no IMPLICIT type", sym
->name
);
1918 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1919 && gfc_match_char ('%') == MATCH_YES
)
1921 gfc_error ("Unexpected '%%' for nonderived-type variable '%s' at %C",
1926 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1927 || gfc_match_char ('%') != MATCH_YES
)
1928 goto check_substring
;
1930 sym
= sym
->ts
.u
.derived
;
1937 m
= gfc_match_name (name
);
1939 gfc_error ("Expected structure component name at %C");
1943 if (sym
->f2k_derived
)
1944 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1950 gfc_symbol
* tbp_sym
;
1955 gcc_assert (!tail
|| !tail
->next
);
1956 gcc_assert (primary
->expr_type
== EXPR_VARIABLE
1957 || (primary
->expr_type
== EXPR_STRUCTURE
1958 && primary
->symtree
&& primary
->symtree
->n
.sym
1959 && primary
->symtree
->n
.sym
->attr
.flavor
));
1961 if (tbp
->n
.tb
->is_generic
)
1964 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1966 primary
->expr_type
= EXPR_COMPCALL
;
1967 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1968 primary
->value
.compcall
.name
= tbp
->name
;
1969 primary
->value
.compcall
.ignore_pass
= 0;
1970 primary
->value
.compcall
.assign
= 0;
1971 primary
->value
.compcall
.base_object
= NULL
;
1972 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1974 primary
->ts
= tbp_sym
->ts
;
1976 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1977 &primary
->value
.compcall
.actual
);
1978 if (m
== MATCH_ERROR
)
1983 primary
->value
.compcall
.actual
= NULL
;
1986 gfc_error ("Expected argument list at %C");
1994 component
= gfc_find_component (sym
, name
, false, false);
1995 if (component
== NULL
)
1998 tail
= extend_ref (primary
, tail
);
1999 tail
->type
= REF_COMPONENT
;
2001 tail
->u
.c
.component
= component
;
2002 tail
->u
.c
.sym
= sym
;
2004 primary
->ts
= component
->ts
;
2006 if (component
->attr
.proc_pointer
&& ppc_arg
2007 && !gfc_matching_procptr_assignment
)
2009 /* Procedure pointer component call: Look for argument list. */
2010 m
= gfc_match_actual_arglist (sub_flag
,
2011 &primary
->value
.compcall
.actual
);
2012 if (m
== MATCH_ERROR
)
2015 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2016 && !matching_actual_arglist
)
2018 gfc_error ("Procedure pointer component '%s' requires an "
2019 "argument list at %C", component
->name
);
2024 primary
->expr_type
= EXPR_PPC
;
2029 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2031 tail
= extend_ref (primary
, tail
);
2032 tail
->type
= REF_ARRAY
;
2034 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2035 component
->as
->corank
);
2039 else if (component
->ts
.type
== BT_CLASS
2040 && CLASS_DATA (component
)->as
!= NULL
2041 && !component
->attr
.proc_pointer
)
2043 tail
= extend_ref (primary
, tail
);
2044 tail
->type
= REF_ARRAY
;
2046 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2048 CLASS_DATA (component
)->as
->corank
);
2053 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2054 || gfc_match_char ('%') != MATCH_YES
)
2057 sym
= component
->ts
.u
.derived
;
2062 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
2064 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2066 gfc_set_default_type (sym
, 0, sym
->ns
);
2067 primary
->ts
= sym
->ts
;
2072 if (primary
->ts
.type
== BT_CHARACTER
)
2074 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
2078 primary
->ref
= substring
;
2080 tail
->next
= substring
;
2082 if (primary
->expr_type
== EXPR_CONSTANT
)
2083 primary
->expr_type
= EXPR_SUBSTRING
;
2086 primary
->ts
.u
.cl
= NULL
;
2093 gfc_clear_ts (&primary
->ts
);
2094 gfc_clear_ts (&sym
->ts
);
2104 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2106 gfc_error ("Coindexed procedure-pointer component at %C");
2114 /* Given an expression that is a variable, figure out what the
2115 ultimate variable's type and attribute is, traversing the reference
2116 structures if necessary.
2118 This subroutine is trickier than it looks. We start at the base
2119 symbol and store the attribute. Component references load a
2120 completely new attribute.
2122 A couple of rules come into play. Subobjects of targets are always
2123 targets themselves. If we see a component that goes through a
2124 pointer, then the expression must also be a target, since the
2125 pointer is associated with something (if it isn't core will soon be
2126 dumped). If we see a full part or section of an array, the
2127 expression is also an array.
2129 We can have at most one full array reference. */
2132 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2134 int dimension
, pointer
, allocatable
, target
;
2135 symbol_attribute attr
;
2138 gfc_component
*comp
;
2140 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2141 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2143 sym
= expr
->symtree
->n
.sym
;
2146 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2148 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2149 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2150 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2154 dimension
= attr
.dimension
;
2155 pointer
= attr
.pointer
;
2156 allocatable
= attr
.allocatable
;
2159 target
= attr
.target
;
2160 if (pointer
|| attr
.proc_pointer
)
2163 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2166 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2171 switch (ref
->u
.ar
.type
)
2178 allocatable
= pointer
= 0;
2183 /* Handle coarrays. */
2184 if (ref
->u
.ar
.dimen
> 0)
2185 allocatable
= pointer
= 0;
2189 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2195 comp
= ref
->u
.c
.component
;
2200 /* Don't set the string length if a substring reference
2202 if (ts
->type
== BT_CHARACTER
2203 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2207 if (comp
->ts
.type
== BT_CLASS
)
2209 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2210 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2214 pointer
= comp
->attr
.pointer
;
2215 allocatable
= comp
->attr
.allocatable
;
2217 if (pointer
|| attr
.proc_pointer
)
2223 allocatable
= pointer
= 0;
2227 attr
.dimension
= dimension
;
2228 attr
.pointer
= pointer
;
2229 attr
.allocatable
= allocatable
;
2230 attr
.target
= target
;
2231 attr
.save
= sym
->attr
.save
;
2237 /* Return the attribute from a general expression. */
2240 gfc_expr_attr (gfc_expr
*e
)
2242 symbol_attribute attr
;
2244 switch (e
->expr_type
)
2247 attr
= gfc_variable_attr (e
, NULL
);
2251 gfc_clear_attr (&attr
);
2253 if (e
->value
.function
.esym
!= NULL
)
2255 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2257 if (sym
->ts
.type
== BT_CLASS
)
2259 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2260 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2261 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2265 attr
= gfc_variable_attr (e
, NULL
);
2267 /* TODO: NULL() returns pointers. May have to take care of this
2273 gfc_clear_attr (&attr
);
2281 /* Match a structure constructor. The initial symbol has already been
2284 typedef struct gfc_structure_ctor_component
2289 struct gfc_structure_ctor_component
* next
;
2291 gfc_structure_ctor_component
;
2293 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2296 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2299 gfc_free_expr (comp
->val
);
2304 /* Translate the component list into the actual constructor by sorting it in
2305 the order required; this also checks along the way that each and every
2306 component actually has an initializer and handles default initializers
2307 for components without explicit value given. */
2309 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2310 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2312 gfc_structure_ctor_component
*comp_iter
;
2313 gfc_component
*comp
;
2315 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2317 gfc_structure_ctor_component
**next_ptr
;
2318 gfc_expr
*value
= NULL
;
2320 /* Try to find the initializer for the current component by name. */
2321 next_ptr
= comp_head
;
2322 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2324 if (!strcmp (comp_iter
->name
, comp
->name
))
2326 next_ptr
= &comp_iter
->next
;
2329 /* If an extension, try building the parent derived type by building
2330 a value expression for the parent derived type and calling self. */
2331 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2333 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2335 &gfc_current_locus
);
2336 value
->ts
= comp
->ts
;
2338 if (build_actual_constructor (comp_head
, &value
->value
.constructor
,
2339 comp
->ts
.u
.derived
) == FAILURE
)
2341 gfc_free_expr (value
);
2345 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2349 /* If it was not found, try the default initializer if there's any;
2350 otherwise, it's an error. */
2353 if (comp
->initializer
)
2355 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2356 " constructor with missing optional arguments"
2357 " at %C") == FAILURE
)
2359 value
= gfc_copy_expr (comp
->initializer
);
2363 gfc_error ("No initializer for component '%s' given in the"
2364 " structure constructor at %C!", comp
->name
);
2369 value
= comp_iter
->val
;
2371 /* Add the value to the constructor chain built. */
2372 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2374 /* Remove the entry from the component list. We don't want the expression
2375 value to be free'd, so set it to NULL. */
2378 *next_ptr
= comp_iter
->next
;
2379 comp_iter
->val
= NULL
;
2380 gfc_free_structure_ctor_component (comp_iter
);
2388 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2389 gfc_actual_arglist
**arglist
,
2392 gfc_actual_arglist
*actual
;
2393 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2394 gfc_constructor_base ctor_head
= NULL
;
2395 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2396 const char* last_name
= NULL
;
2400 expr
= parent
? *cexpr
: e
;
2401 old_locus
= gfc_current_locus
;
2403 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2405 gfc_current_locus
= expr
->where
;
2407 comp_tail
= comp_head
= NULL
;
2409 if (!parent
&& sym
->attr
.abstract
)
2411 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2412 sym
->name
, &expr
->where
);
2416 comp
= sym
->components
;
2417 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2420 gfc_component
*this_comp
= NULL
;
2423 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2426 comp_tail
->next
= gfc_get_structure_ctor_component ();
2427 comp_tail
= comp_tail
->next
;
2431 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2432 " constructor with named arguments at %C")
2436 comp_tail
->name
= xstrdup (actual
->name
);
2437 last_name
= comp_tail
->name
;
2442 /* Components without name are not allowed after the first named
2443 component initializer! */
2447 gfc_error ("Component initializer without name after component"
2448 " named %s at %L!", last_name
,
2449 actual
->expr
? &actual
->expr
->where
2450 : &gfc_current_locus
);
2452 gfc_error ("Too many components in structure constructor at "
2453 "%L!", actual
->expr
? &actual
->expr
->where
2454 : &gfc_current_locus
);
2458 comp_tail
->name
= xstrdup (comp
->name
);
2461 /* Find the current component in the structure definition and check
2462 its access is not private. */
2464 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2467 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2469 comp
= NULL
; /* Reset needed! */
2472 /* Here we can check if a component name is given which does not
2473 correspond to any component of the defined structure. */
2477 comp_tail
->val
= actual
->expr
;
2478 if (actual
->expr
!= NULL
)
2479 comp_tail
->where
= actual
->expr
->where
;
2480 actual
->expr
= NULL
;
2482 /* Check if this component is already given a value. */
2483 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2484 comp_iter
= comp_iter
->next
)
2486 gcc_assert (comp_iter
);
2487 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2489 gfc_error ("Component '%s' is initialized twice in the structure"
2490 " constructor at %L!", comp_tail
->name
,
2491 comp_tail
->val
? &comp_tail
->where
2492 : &gfc_current_locus
);
2497 /* F2008, R457/C725, for PURE C1283. */
2498 if (this_comp
->attr
.pointer
&& comp_tail
->val
2499 && gfc_is_coindexed (comp_tail
->val
))
2501 gfc_error ("Coindexed expression to pointer component '%s' in "
2502 "structure constructor at %L!", comp_tail
->name
,
2507 /* If not explicitly a parent constructor, gather up the components
2509 if (comp
&& comp
== sym
->components
2510 && sym
->attr
.extension
2512 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2514 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2517 gfc_actual_arglist
*arg_null
= NULL
;
2519 actual
->expr
= comp_tail
->val
;
2520 comp_tail
->val
= NULL
;
2522 m
= gfc_convert_to_structure_constructor (NULL
,
2523 comp
->ts
.u
.derived
, &comp_tail
->val
,
2524 comp
->ts
.u
.derived
->attr
.zero_comp
2525 ? &arg_null
: &actual
, true);
2529 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2538 if (parent
&& !comp
)
2541 actual
= actual
->next
;
2544 if (build_actual_constructor (&comp_head
, &ctor_head
, sym
) == FAILURE
)
2547 /* No component should be left, as this should have caused an error in the
2548 loop constructing the component-list (name that does not correspond to any
2549 component in the structure definition). */
2550 if (comp_head
&& sym
->attr
.extension
)
2552 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2554 gfc_error ("component '%s' at %L has already been set by a "
2555 "parent derived type constructor", comp_iter
->name
,
2561 gcc_assert (!comp_head
);
2565 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2566 expr
->ts
.u
.derived
= sym
;
2567 expr
->value
.constructor
= ctor_head
;
2572 expr
->ts
.u
.derived
= sym
;
2574 expr
->ts
.type
= BT_DERIVED
;
2575 expr
->value
.constructor
= ctor_head
;
2576 expr
->expr_type
= EXPR_STRUCTURE
;
2579 gfc_current_locus
= old_locus
;
2585 gfc_current_locus
= old_locus
;
2587 for (comp_iter
= comp_head
; comp_iter
; )
2589 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2590 gfc_free_structure_ctor_component (comp_iter
);
2593 gfc_constructor_free (ctor_head
);
2600 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2604 gfc_symtree
*symtree
;
2606 gfc_get_sym_tree (sym
->name
, NULL
, &symtree
, false); /* Can't fail */
2608 e
= gfc_get_expr ();
2609 e
->symtree
= symtree
;
2610 e
->expr_type
= EXPR_FUNCTION
;
2612 gcc_assert (sym
->attr
.flavor
== FL_DERIVED
2613 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2614 e
->value
.function
.esym
= sym
;
2615 e
->symtree
->n
.sym
->attr
.generic
= 1;
2617 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2624 if (gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false)
2636 /* If the symbol is an implicit do loop index and implicitly typed,
2637 it should not be host associated. Provide a symtree from the
2638 current namespace. */
2640 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2642 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2643 && (*sym
)->ns
!= gfc_current_ns
2644 && (*sym
)->attr
.implied_index
2645 && (*sym
)->attr
.implicit_type
2646 && !(*sym
)->attr
.use_assoc
)
2649 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2652 *sym
= (*st
)->n
.sym
;
2658 /* Procedure pointer as function result: Replace the function symbol by the
2659 auto-generated hidden result variable named "ppr@". */
2662 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2664 /* Check for procedure pointer result variable. */
2665 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2666 && (*sym
)->result
&& (*sym
)->result
!= *sym
2667 && (*sym
)->result
->attr
.proc_pointer
2668 && (*sym
) == gfc_current_ns
->proc_name
2669 && (*sym
) == (*sym
)->result
->ns
->proc_name
2670 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2672 /* Automatic replacement with "hidden" result variable. */
2673 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2674 *sym
= (*sym
)->result
;
2675 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2682 /* Matches a variable name followed by anything that might follow it--
2683 array reference, argument list of a function, etc. */
2686 gfc_match_rvalue (gfc_expr
**result
)
2688 gfc_actual_arglist
*actual_arglist
;
2689 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2692 gfc_symtree
*symtree
;
2693 locus where
, old_loc
;
2701 m
= gfc_match_name (name
);
2705 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2706 && !gfc_current_ns
->has_import_set
)
2707 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2709 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2714 sym
= symtree
->n
.sym
;
2716 where
= gfc_current_locus
;
2718 replace_hidden_procptr_result (&sym
, &symtree
);
2720 /* If this is an implicit do loop index and implicitly typed,
2721 it should not be host associated. */
2722 m
= check_for_implicit_index (&symtree
, &sym
);
2726 gfc_set_sym_referenced (sym
);
2727 sym
->attr
.implied_index
= 0;
2729 if (sym
->attr
.function
&& sym
->result
== sym
)
2731 /* See if this is a directly recursive function call. */
2732 gfc_gobble_whitespace ();
2733 if (sym
->attr
.recursive
2734 && gfc_peek_ascii_char () == '('
2735 && gfc_current_ns
->proc_name
== sym
2736 && !sym
->attr
.dimension
)
2738 gfc_error ("'%s' at %C is the name of a recursive function "
2739 "and so refers to the result variable. Use an "
2740 "explicit RESULT variable for direct recursion "
2741 "(12.5.2.1)", sym
->name
);
2745 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2749 && (sym
->ns
== gfc_current_ns
2750 || sym
->ns
== gfc_current_ns
->parent
))
2752 gfc_entry_list
*el
= NULL
;
2754 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2760 if (gfc_matching_procptr_assignment
)
2763 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2766 if (sym
->attr
.generic
)
2767 goto generic_function
;
2769 switch (sym
->attr
.flavor
)
2773 e
= gfc_get_expr ();
2775 e
->expr_type
= EXPR_VARIABLE
;
2776 e
->symtree
= symtree
;
2778 m
= gfc_match_varspec (e
, 0, false, true);
2782 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2783 end up here. Unfortunately, sym->value->expr_type is set to
2784 EXPR_CONSTANT, and so the if () branch would be followed without
2785 the !sym->as check. */
2786 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2787 e
= gfc_copy_expr (sym
->value
);
2790 e
= gfc_get_expr ();
2791 e
->expr_type
= EXPR_VARIABLE
;
2794 e
->symtree
= symtree
;
2795 m
= gfc_match_varspec (e
, 0, false, true);
2797 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2800 /* Variable array references to derived type parameters cause
2801 all sorts of headaches in simplification. Treating such
2802 expressions as variable works just fine for all array
2804 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2806 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2807 if (ref
->type
== REF_ARRAY
)
2810 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2816 e
= gfc_get_expr ();
2817 e
->expr_type
= EXPR_VARIABLE
;
2818 e
->symtree
= symtree
;
2825 sym
= gfc_use_derived (sym
);
2829 goto generic_function
;
2832 /* If we're here, then the name is known to be the name of a
2833 procedure, yet it is not sure to be the name of a function. */
2836 /* Procedure Pointer Assignments. */
2838 if (gfc_matching_procptr_assignment
)
2840 gfc_gobble_whitespace ();
2841 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2842 /* Parse functions returning a procptr. */
2845 if (gfc_is_intrinsic (sym
, 0, gfc_current_locus
)
2846 || gfc_is_intrinsic (sym
, 1, gfc_current_locus
))
2847 sym
->attr
.intrinsic
= 1;
2848 e
= gfc_get_expr ();
2849 e
->expr_type
= EXPR_VARIABLE
;
2850 e
->symtree
= symtree
;
2851 m
= gfc_match_varspec (e
, 0, false, true);
2855 if (sym
->attr
.subroutine
)
2857 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2863 /* At this point, the name has to be a non-statement function.
2864 If the name is the same as the current function being
2865 compiled, then we have a variable reference (to the function
2866 result) if the name is non-recursive. */
2868 st
= gfc_enclosing_unit (NULL
);
2870 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2872 && !sym
->attr
.recursive
)
2874 e
= gfc_get_expr ();
2875 e
->symtree
= symtree
;
2876 e
->expr_type
= EXPR_VARIABLE
;
2878 m
= gfc_match_varspec (e
, 0, false, true);
2882 /* Match a function reference. */
2884 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2887 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2888 gfc_error ("Statement function '%s' requires argument list at %C",
2891 gfc_error ("Function '%s' requires an argument list at %C",
2904 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2905 sym
= symtree
->n
.sym
;
2907 replace_hidden_procptr_result (&sym
, &symtree
);
2909 e
= gfc_get_expr ();
2910 e
->symtree
= symtree
;
2911 e
->expr_type
= EXPR_FUNCTION
;
2912 e
->value
.function
.actual
= actual_arglist
;
2913 e
->where
= gfc_current_locus
;
2915 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2916 && CLASS_DATA (sym
)->as
)
2917 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
2918 else if (sym
->as
!= NULL
)
2919 e
->rank
= sym
->as
->rank
;
2921 if (!sym
->attr
.function
2922 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2928 /* Check here for the existence of at least one argument for the
2929 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2930 argument(s) given will be checked in gfc_iso_c_func_interface,
2931 during resolution of the function call. */
2932 if (sym
->attr
.is_iso_c
== 1
2933 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2934 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2935 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2936 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2938 /* make sure we were given a param */
2939 if (actual_arglist
== NULL
)
2941 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2947 if (sym
->result
== NULL
)
2955 /* Special case for derived type variables that get their types
2956 via an IMPLICIT statement. This can't wait for the
2957 resolution phase. */
2959 if (gfc_peek_ascii_char () == '%'
2960 && sym
->ts
.type
== BT_UNKNOWN
2961 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2962 gfc_set_default_type (sym
, 0, sym
->ns
);
2964 /* If the symbol has a (co)dimension attribute, the expression is a
2967 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2969 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2970 sym
->name
, NULL
) == FAILURE
)
2976 e
= gfc_get_expr ();
2977 e
->symtree
= symtree
;
2978 e
->expr_type
= EXPR_VARIABLE
;
2979 m
= gfc_match_varspec (e
, 0, false, true);
2983 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2984 && (CLASS_DATA (sym
)->attr
.dimension
2985 || CLASS_DATA (sym
)->attr
.codimension
))
2987 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2988 sym
->name
, NULL
) == FAILURE
)
2994 e
= gfc_get_expr ();
2995 e
->symtree
= symtree
;
2996 e
->expr_type
= EXPR_VARIABLE
;
2997 m
= gfc_match_varspec (e
, 0, false, true);
3001 /* Name is not an array, so we peek to see if a '(' implies a
3002 function call or a substring reference. Otherwise the
3003 variable is just a scalar. */
3005 gfc_gobble_whitespace ();
3006 if (gfc_peek_ascii_char () != '(')
3008 /* Assume a scalar variable */
3009 e
= gfc_get_expr ();
3010 e
->symtree
= symtree
;
3011 e
->expr_type
= EXPR_VARIABLE
;
3013 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3014 sym
->name
, NULL
) == FAILURE
)
3020 /*FIXME:??? gfc_match_varspec does set this for us: */
3022 m
= gfc_match_varspec (e
, 0, false, true);
3026 /* See if this is a function reference with a keyword argument
3027 as first argument. We do this because otherwise a spurious
3028 symbol would end up in the symbol table. */
3030 old_loc
= gfc_current_locus
;
3031 m2
= gfc_match (" ( %n =", argname
);
3032 gfc_current_locus
= old_loc
;
3034 e
= gfc_get_expr ();
3035 e
->symtree
= symtree
;
3037 if (m2
!= MATCH_YES
)
3039 /* Try to figure out whether we're dealing with a character type.
3040 We're peeking ahead here, because we don't want to call
3041 match_substring if we're dealing with an implicitly typed
3042 non-character variable. */
3043 implicit_char
= false;
3044 if (sym
->ts
.type
== BT_UNKNOWN
)
3046 ts
= gfc_get_default_type (sym
->name
, NULL
);
3047 if (ts
->type
== BT_CHARACTER
)
3048 implicit_char
= true;
3051 /* See if this could possibly be a substring reference of a name
3052 that we're not sure is a variable yet. */
3054 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3055 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
3058 e
->expr_type
= EXPR_VARIABLE
;
3060 if (sym
->attr
.flavor
!= FL_VARIABLE
3061 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3062 sym
->name
, NULL
) == FAILURE
)
3068 if (sym
->ts
.type
== BT_UNKNOWN
3069 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3083 /* Give up, assume we have a function. */
3085 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3086 sym
= symtree
->n
.sym
;
3087 e
->expr_type
= EXPR_FUNCTION
;
3089 if (!sym
->attr
.function
3090 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3098 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3100 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
3108 /* If our new function returns a character, array or structure
3109 type, it might have subsequent references. */
3111 m
= gfc_match_varspec (e
, 0, false, true);
3118 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3120 e
= gfc_get_expr ();
3121 e
->symtree
= symtree
;
3122 e
->expr_type
= EXPR_FUNCTION
;
3124 if (sym
->attr
.flavor
== FL_DERIVED
)
3126 e
->value
.function
.esym
= sym
;
3127 e
->symtree
->n
.sym
->attr
.generic
= 1;
3130 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3134 gfc_error ("Symbol at %C is not appropriate for an expression");
3150 /* Match a variable, i.e. something that can be assigned to. This
3151 starts as a symbol, can be a structure component or an array
3152 reference. It can be a function if the function doesn't have a
3153 separate RESULT variable. If the symbol has not been previously
3154 seen, we assume it is a variable.
3156 This function is called by two interface functions:
3157 gfc_match_variable, which has host_flag = 1, and
3158 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3159 match of the symbol to the local scope. */
3162 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3170 /* Since nothing has any business being an lvalue in a module
3171 specification block, an interface block or a contains section,
3172 we force the changed_symbols mechanism to work by setting
3173 host_flag to 0. This prevents valid symbols that have the name
3174 of keywords, such as 'end', being turned into variables by
3175 failed matching to assignments for, e.g., END INTERFACE. */
3176 if (gfc_current_state () == COMP_MODULE
3177 || gfc_current_state () == COMP_INTERFACE
3178 || gfc_current_state () == COMP_CONTAINS
)
3181 where
= gfc_current_locus
;
3182 m
= gfc_match_sym_tree (&st
, host_flag
);
3188 /* If this is an implicit do loop index and implicitly typed,
3189 it should not be host associated. */
3190 m
= check_for_implicit_index (&st
, &sym
);
3194 sym
->attr
.implied_index
= 0;
3196 gfc_set_sym_referenced (sym
);
3197 switch (sym
->attr
.flavor
)
3200 /* Everything is alright. */
3205 sym_flavor flavor
= FL_UNKNOWN
;
3207 gfc_gobble_whitespace ();
3209 if (sym
->attr
.external
|| sym
->attr
.procedure
3210 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3211 flavor
= FL_PROCEDURE
;
3213 /* If it is not a procedure, is not typed and is host associated,
3214 we cannot give it a flavor yet. */
3215 else if (sym
->ns
== gfc_current_ns
->parent
3216 && sym
->ts
.type
== BT_UNKNOWN
)
3219 /* These are definitive indicators that this is a variable. */
3220 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3221 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3222 flavor
= FL_VARIABLE
;
3224 if (flavor
!= FL_UNKNOWN
3225 && gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
) == FAILURE
)
3233 gfc_error ("Named constant at %C in an EQUIVALENCE");
3236 /* Otherwise this is checked for and an error given in the
3237 variable definition context checks. */
3241 /* Check for a nonrecursive function result variable. */
3242 if (sym
->attr
.function
3243 && !sym
->attr
.external
3244 && sym
->result
== sym
3245 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3247 && sym
->ns
== gfc_current_ns
)
3249 && sym
->ns
== gfc_current_ns
->parent
)))
3251 /* If a function result is a derived type, then the derived
3252 type may still have to be resolved. */
3254 if (sym
->ts
.type
== BT_DERIVED
3255 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3260 if (sym
->attr
.proc_pointer
3261 || replace_hidden_procptr_result (&sym
, &st
) == SUCCESS
)
3264 /* Fall through to error */
3267 gfc_error ("'%s' at %C is not a variable", sym
->name
);
3271 /* Special case for derived type variables that get their types
3272 via an IMPLICIT statement. This can't wait for the
3273 resolution phase. */
3276 gfc_namespace
* implicit_ns
;
3278 if (gfc_current_ns
->proc_name
== sym
)
3279 implicit_ns
= gfc_current_ns
;
3281 implicit_ns
= sym
->ns
;
3283 if (gfc_peek_ascii_char () == '%'
3284 && sym
->ts
.type
== BT_UNKNOWN
3285 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3286 gfc_set_default_type (sym
, 0, implicit_ns
);
3289 expr
= gfc_get_expr ();
3291 expr
->expr_type
= EXPR_VARIABLE
;
3294 expr
->where
= where
;
3296 /* Now see if we have to do more. */
3297 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3300 gfc_free_expr (expr
);
3310 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3312 return match_variable (result
, equiv_flag
, 1);
3317 gfc_match_equiv_variable (gfc_expr
**result
)
3319 return match_variable (result
, 1, 0);