1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 #include "constructor.h"
31 int matching_actual_arglist
= 0;
33 /* Matches a kind-parameter expression, which is either a named
34 symbolic constant or a nonnegative integer constant. If
35 successful, sets the kind value to the correct integer.
36 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
37 symbol like e.g. 'c_int'. */
40 match_kind_param (int *kind
, int *is_iso_c
)
42 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
49 m
= gfc_match_small_literal_int (kind
, NULL
);
53 m
= gfc_match_name (name
);
57 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
63 *is_iso_c
= sym
->attr
.is_iso_c
;
65 if (sym
->attr
.flavor
!= FL_PARAMETER
)
68 if (sym
->value
== NULL
)
71 p
= gfc_extract_int (sym
->value
, kind
);
75 gfc_set_sym_referenced (sym
);
84 /* Get a trailing kind-specification for non-character variables.
86 * the integer kind value or
87 * -1 if an error was generated,
88 * -2 if no kind was found.
89 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
90 symbol like e.g. 'c_int'. */
93 get_kind (int *is_iso_c
)
100 if (gfc_match_char ('_') != MATCH_YES
)
103 m
= match_kind_param (&kind
, is_iso_c
);
105 gfc_error ("Missing kind-parameter at %C");
107 return (m
== MATCH_YES
) ? kind
: -1;
111 /* Given a character and a radix, see if the character is a valid
112 digit in that radix. */
115 gfc_check_digit (char c
, int radix
)
122 r
= ('0' <= c
&& c
<= '1');
126 r
= ('0' <= c
&& c
<= '7');
130 r
= ('0' <= c
&& c
<= '9');
138 gfc_internal_error ("gfc_check_digit(): bad radix");
145 /* Match the digit string part of an integer if signflag is not set,
146 the signed digit string part if signflag is set. If the buffer
147 is NULL, we just count characters for the resolution pass. Returns
148 the number of characters matched, -1 for no match. */
151 match_digits (int signflag
, int radix
, char *buffer
)
158 c
= gfc_next_ascii_char ();
160 if (signflag
&& (c
== '+' || c
== '-'))
164 gfc_gobble_whitespace ();
165 c
= gfc_next_ascii_char ();
169 if (!gfc_check_digit (c
, radix
))
178 old_loc
= gfc_current_locus
;
179 c
= gfc_next_ascii_char ();
181 if (!gfc_check_digit (c
, radix
))
189 gfc_current_locus
= old_loc
;
195 /* Match an integer (digit string and optional kind).
196 A sign will be accepted if signflag is set. */
199 match_integer_constant (gfc_expr
**result
, int signflag
)
201 int length
, kind
, is_iso_c
;
206 old_loc
= gfc_current_locus
;
207 gfc_gobble_whitespace ();
209 length
= match_digits (signflag
, 10, NULL
);
210 gfc_current_locus
= old_loc
;
214 buffer
= (char *) alloca (length
+ 1);
215 memset (buffer
, '\0', length
+ 1);
217 gfc_gobble_whitespace ();
219 match_digits (signflag
, 10, buffer
);
221 kind
= get_kind (&is_iso_c
);
223 kind
= gfc_default_integer_kind
;
227 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
229 gfc_error ("Integer kind %d at %C not available", kind
);
233 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
234 e
->ts
.is_c_interop
= is_iso_c
;
236 if (gfc_range_check (e
) != ARITH_OK
)
238 gfc_error ("Integer too big for its kind at %C. This check can be "
239 "disabled with the option -fno-range-check");
250 /* Match a Hollerith constant. */
253 match_hollerith_constant (gfc_expr
**result
)
261 old_loc
= gfc_current_locus
;
262 gfc_gobble_whitespace ();
264 if (match_integer_constant (&e
, 0) == MATCH_YES
265 && gfc_match_char ('h') == MATCH_YES
)
267 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: Hollerith constant "
271 msg
= gfc_extract_int (e
, &num
);
279 gfc_error ("Invalid Hollerith constant: %L must contain at least "
280 "one character", &old_loc
);
283 if (e
->ts
.kind
!= gfc_default_integer_kind
)
285 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
286 "should be default", &old_loc
);
292 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
295 /* Calculate padding needed to fit default integer memory. */
296 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
298 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
300 for (i
= 0; i
< num
; i
++)
302 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
303 if (! gfc_wide_fits_in_byte (c
))
305 gfc_error ("Invalid Hollerith constant at %L contains a "
306 "wide character", &old_loc
);
310 e
->representation
.string
[i
] = (unsigned char) c
;
313 /* Now pad with blanks and end with a null char. */
314 for (i
= 0; i
< pad
; i
++)
315 e
->representation
.string
[num
+ i
] = ' ';
317 e
->representation
.string
[num
+ i
] = '\0';
318 e
->representation
.length
= num
+ pad
;
327 gfc_current_locus
= old_loc
;
336 /* Match a binary, octal or hexadecimal constant that can be found in
337 a DATA statement. The standard permits b'010...', o'73...', and
338 z'a1...' where b, o, and z can be capital letters. This function
339 also accepts postfixed forms of the constants: '01...'b, '73...'o,
340 and 'a1...'z. An additional extension is the use of x for z. */
343 match_boz_constant (gfc_expr
**result
)
345 int radix
, length
, x_hex
, kind
;
346 locus old_loc
, start_loc
;
347 char *buffer
, post
, delim
;
350 start_loc
= old_loc
= gfc_current_locus
;
351 gfc_gobble_whitespace ();
354 switch (post
= gfc_next_ascii_char ())
376 radix
= 16; /* Set to accept any valid digit string. */
382 /* No whitespace allowed here. */
385 delim
= gfc_next_ascii_char ();
387 if (delim
!= '\'' && delim
!= '\"')
391 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
392 "constant at %C uses non-standard syntax")
396 old_loc
= gfc_current_locus
;
398 length
= match_digits (0, radix
, NULL
);
401 gfc_error ("Empty set of digits in BOZ constant at %C");
405 if (gfc_next_ascii_char () != delim
)
407 gfc_error ("Illegal character in BOZ constant at %C");
413 switch (gfc_next_ascii_char ())
430 if (gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ constant "
431 "at %C uses non-standard postfix syntax")
436 gfc_current_locus
= old_loc
;
438 buffer
= (char *) alloca (length
+ 1);
439 memset (buffer
, '\0', length
+ 1);
441 match_digits (0, radix
, buffer
);
442 gfc_next_ascii_char (); /* Eat delimiter. */
444 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
446 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
447 "If a data-stmt-constant is a boz-literal-constant, the corresponding
448 variable shall be of type integer. The boz-literal-constant is treated
449 as if it were an int-literal-constant with a kind-param that specifies
450 the representation method with the largest decimal exponent range
451 supported by the processor." */
453 kind
= gfc_max_integer_kind
;
454 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
456 /* Mark as boz variable. */
459 if (gfc_range_check (e
) != ARITH_OK
)
461 gfc_error ("Integer too big for integer kind %i at %C", kind
);
466 if (!gfc_in_match_data ()
467 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: BOZ used outside a DATA "
476 gfc_current_locus
= start_loc
;
481 /* Match a real constant of some sort. Allow a signed constant if signflag
485 match_real_constant (gfc_expr
**result
, int signflag
)
487 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
;
488 locus old_loc
, temp_loc
;
489 char *p
, *buffer
, c
, exp_char
;
493 old_loc
= gfc_current_locus
;
494 gfc_gobble_whitespace ();
504 c
= gfc_next_ascii_char ();
505 if (signflag
&& (c
== '+' || c
== '-'))
510 gfc_gobble_whitespace ();
511 c
= gfc_next_ascii_char ();
514 /* Scan significand. */
515 for (;; c
= gfc_next_ascii_char (), count
++)
522 /* Check to see if "." goes with a following operator like
524 temp_loc
= gfc_current_locus
;
525 c
= gfc_next_ascii_char ();
527 if (c
== 'e' || c
== 'd' || c
== 'q')
529 c
= gfc_next_ascii_char ();
531 goto done
; /* Operator named .e. or .d. */
535 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
537 gfc_current_locus
= temp_loc
;
551 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
558 if (gfc_notify_std (GFC_STD_GNU
, "Extension: exponent-letter 'q' in "
559 "real-literal-constant at %C") == FAILURE
)
561 else if (gfc_option
.warn_real_q_constant
)
562 gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
567 c
= gfc_next_ascii_char ();
570 if (c
== '+' || c
== '-')
571 { /* optional sign */
572 c
= gfc_next_ascii_char ();
578 gfc_error ("Missing exponent in real number at %C");
584 c
= gfc_next_ascii_char ();
589 /* Check that we have a numeric constant. */
590 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
592 gfc_current_locus
= old_loc
;
596 /* Convert the number. */
597 gfc_current_locus
= old_loc
;
598 gfc_gobble_whitespace ();
600 buffer
= (char *) alloca (count
+ 1);
601 memset (buffer
, '\0', count
+ 1);
604 c
= gfc_next_ascii_char ();
605 if (c
== '+' || c
== '-')
607 gfc_gobble_whitespace ();
608 c
= gfc_next_ascii_char ();
611 /* Hack for mpfr_set_str(). */
614 if (c
== 'd' || c
== 'q')
622 c
= gfc_next_ascii_char ();
625 kind
= get_kind (&is_iso_c
);
634 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
638 kind
= gfc_default_double_kind
;
644 gfc_error ("Real number at %C has a 'q' exponent and an explicit "
649 /* The maximum possible real kind type parameter is 16. First, try
650 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
651 extended precision. If neither value works, just given up. */
653 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
656 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
658 gfc_error ("Invalid exponent-letter 'q' in "
659 "real-literal-constant at %C");
667 kind
= gfc_default_real_kind
;
669 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
671 gfc_error ("Invalid real kind %d at %C", kind
);
676 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
678 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
679 e
->ts
.is_c_interop
= is_iso_c
;
681 switch (gfc_range_check (e
))
686 gfc_error ("Real constant overflows its kind at %C");
689 case ARITH_UNDERFLOW
:
690 if (gfc_option
.warn_underflow
)
691 gfc_warning ("Real constant underflows its kind at %C");
692 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
696 gfc_internal_error ("gfc_range_check() returned bad value");
708 /* Match a substring reference. */
711 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
)
713 gfc_expr
*start
, *end
;
721 old_loc
= gfc_current_locus
;
723 m
= gfc_match_char ('(');
727 if (gfc_match_char (':') != MATCH_YES
)
730 m
= gfc_match_init_expr (&start
);
732 m
= gfc_match_expr (&start
);
740 m
= gfc_match_char (':');
745 if (gfc_match_char (')') != MATCH_YES
)
748 m
= gfc_match_init_expr (&end
);
750 m
= gfc_match_expr (&end
);
754 if (m
== MATCH_ERROR
)
757 m
= gfc_match_char (')');
762 /* Optimize away the (:) reference. */
763 if (start
== NULL
&& end
== NULL
)
767 ref
= gfc_get_ref ();
769 ref
->type
= REF_SUBSTRING
;
771 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
772 ref
->u
.ss
.start
= start
;
773 if (end
== NULL
&& cl
)
774 end
= gfc_copy_expr (cl
->length
);
776 ref
->u
.ss
.length
= cl
;
783 gfc_error ("Syntax error in SUBSTRING specification at %C");
787 gfc_free_expr (start
);
790 gfc_current_locus
= old_loc
;
795 /* Reads the next character of a string constant, taking care to
796 return doubled delimiters on the input as a single instance of
799 Special return values for "ret" argument are:
800 -1 End of the string, as determined by the delimiter
801 -2 Unterminated string detected
803 Backslash codes are also expanded at this time. */
806 next_string_char (gfc_char_t delimiter
, int *ret
)
811 c
= gfc_next_char_literal (INSTRING_WARN
);
820 if (gfc_option
.flag_backslash
&& c
== '\\')
822 old_locus
= gfc_current_locus
;
824 if (gfc_match_special_char (&c
) == MATCH_NO
)
825 gfc_current_locus
= old_locus
;
827 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
828 gfc_warning ("Extension: backslash character at %C");
834 old_locus
= gfc_current_locus
;
835 c
= gfc_next_char_literal (NONSTRING
);
839 gfc_current_locus
= old_locus
;
846 /* Special case of gfc_match_name() that matches a parameter kind name
847 before a string constant. This takes case of the weird but legal
852 where kind____ is a parameter. gfc_match_name() will happily slurp
853 up all the underscores, which leads to problems. If we return
854 MATCH_YES, the parse pointer points to the final underscore, which
855 is not part of the name. We never return MATCH_ERROR-- errors in
856 the name will be detected later. */
859 match_charkind_name (char *name
)
865 gfc_gobble_whitespace ();
866 c
= gfc_next_ascii_char ();
875 old_loc
= gfc_current_locus
;
876 c
= gfc_next_ascii_char ();
880 peek
= gfc_peek_ascii_char ();
882 if (peek
== '\'' || peek
== '\"')
884 gfc_current_locus
= old_loc
;
892 && (c
!= '$' || !gfc_option
.flag_dollar_ok
))
896 if (++len
> GFC_MAX_SYMBOL_LEN
)
904 /* See if the current input matches a character constant. Lots of
905 contortions have to be done to match the kind parameter which comes
906 before the actual string. The main consideration is that we don't
907 want to error out too quickly. For example, we don't actually do
908 any validation of the kinds until we have actually seen a legal
909 delimiter. Using match_kind_param() generates errors too quickly. */
912 match_string_constant (gfc_expr
**result
)
914 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
915 int i
, kind
, length
, warn_ampersand
, ret
;
916 locus old_locus
, start_locus
;
921 gfc_char_t c
, delimiter
, *p
;
923 old_locus
= gfc_current_locus
;
925 gfc_gobble_whitespace ();
927 c
= gfc_next_char ();
928 if (c
== '\'' || c
== '"')
930 kind
= gfc_default_character_kind
;
931 start_locus
= gfc_current_locus
;
935 if (gfc_wide_is_digit (c
))
939 while (gfc_wide_is_digit (c
))
941 kind
= kind
* 10 + c
- '0';
944 c
= gfc_next_char ();
950 gfc_current_locus
= old_locus
;
952 m
= match_charkind_name (name
);
956 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
958 || sym
->attr
.flavor
!= FL_PARAMETER
)
962 c
= gfc_next_char ();
967 gfc_gobble_whitespace ();
968 c
= gfc_next_char ();
974 gfc_gobble_whitespace ();
976 c
= gfc_next_char ();
977 if (c
!= '\'' && c
!= '"')
980 start_locus
= gfc_current_locus
;
984 q
= gfc_extract_int (sym
->value
, &kind
);
990 gfc_set_sym_referenced (sym
);
993 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
995 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1000 /* Scan the string into a block of memory by first figuring out how
1001 long it is, allocating the structure, then re-reading it. This
1002 isn't particularly efficient, but string constants aren't that
1003 common in most code. TODO: Use obstacks? */
1010 c
= next_string_char (delimiter
, &ret
);
1015 gfc_current_locus
= start_locus
;
1016 gfc_error ("Unterminated character constant beginning at %C");
1023 /* Peek at the next character to see if it is a b, o, z, or x for the
1024 postfixed BOZ literal constants. */
1025 peek
= gfc_peek_ascii_char ();
1026 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1029 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1031 gfc_current_locus
= start_locus
;
1033 /* We disable the warning for the following loop as the warning has already
1034 been printed in the loop above. */
1035 warn_ampersand
= gfc_option
.warn_ampersand
;
1036 gfc_option
.warn_ampersand
= 0;
1038 p
= e
->value
.character
.string
;
1039 for (i
= 0; i
< length
; i
++)
1041 c
= next_string_char (delimiter
, &ret
);
1043 if (!gfc_check_character_range (c
, kind
))
1045 gfc_error ("Character '%s' in string at %C is not representable "
1046 "in character kind %d", gfc_print_wide_char (c
), kind
);
1053 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1054 gfc_option
.warn_ampersand
= warn_ampersand
;
1056 next_string_char (delimiter
, &ret
);
1058 gfc_internal_error ("match_string_constant(): Delimiter not found");
1060 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1061 e
->expr_type
= EXPR_SUBSTRING
;
1068 gfc_current_locus
= old_locus
;
1073 /* Match a .true. or .false. Returns 1 if a .true. was found,
1074 0 if a .false. was found, and -1 otherwise. */
1076 match_logical_constant_string (void)
1078 locus orig_loc
= gfc_current_locus
;
1080 gfc_gobble_whitespace ();
1081 if (gfc_next_ascii_char () == '.')
1083 char ch
= gfc_next_ascii_char ();
1086 if (gfc_next_ascii_char () == 'a'
1087 && gfc_next_ascii_char () == 'l'
1088 && gfc_next_ascii_char () == 's'
1089 && gfc_next_ascii_char () == 'e'
1090 && gfc_next_ascii_char () == '.')
1091 /* Matched ".false.". */
1096 if (gfc_next_ascii_char () == 'r'
1097 && gfc_next_ascii_char () == 'u'
1098 && gfc_next_ascii_char () == 'e'
1099 && gfc_next_ascii_char () == '.')
1100 /* Matched ".true.". */
1104 gfc_current_locus
= orig_loc
;
1108 /* Match a .true. or .false. */
1111 match_logical_constant (gfc_expr
**result
)
1114 int i
, kind
, is_iso_c
;
1116 i
= match_logical_constant_string ();
1120 kind
= get_kind (&is_iso_c
);
1124 kind
= gfc_default_logical_kind
;
1126 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1128 gfc_error ("Bad kind for logical constant at %C");
1132 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1133 e
->ts
.is_c_interop
= is_iso_c
;
1140 /* Match a real or imaginary part of a complex constant that is a
1141 symbolic constant. */
1144 match_sym_complex_part (gfc_expr
**result
)
1146 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1151 m
= gfc_match_name (name
);
1155 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1158 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1160 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1164 if (!gfc_numeric_ts (&sym
->value
->ts
))
1166 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1170 if (sym
->value
->rank
!= 0)
1172 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1176 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PARAMETER symbol in "
1177 "complex constant at %C") == FAILURE
)
1180 switch (sym
->value
->ts
.type
)
1183 e
= gfc_copy_expr (sym
->value
);
1187 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1193 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1199 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1202 *result
= e
; /* e is a scalar, real, constant expression. */
1206 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1211 /* Match a real or imaginary part of a complex number. */
1214 match_complex_part (gfc_expr
**result
)
1218 m
= match_sym_complex_part (result
);
1222 m
= match_real_constant (result
, 1);
1226 return match_integer_constant (result
, 1);
1230 /* Try to match a complex constant. */
1233 match_complex_constant (gfc_expr
**result
)
1235 gfc_expr
*e
, *real
, *imag
;
1236 gfc_error_buf old_error
;
1237 gfc_typespec target
;
1242 old_loc
= gfc_current_locus
;
1243 real
= imag
= e
= NULL
;
1245 m
= gfc_match_char ('(');
1249 gfc_push_error (&old_error
);
1251 m
= match_complex_part (&real
);
1254 gfc_free_error (&old_error
);
1258 if (gfc_match_char (',') == MATCH_NO
)
1260 gfc_pop_error (&old_error
);
1265 /* If m is error, then something was wrong with the real part and we
1266 assume we have a complex constant because we've seen the ','. An
1267 ambiguous case here is the start of an iterator list of some
1268 sort. These sort of lists are matched prior to coming here. */
1270 if (m
== MATCH_ERROR
)
1272 gfc_free_error (&old_error
);
1275 gfc_pop_error (&old_error
);
1277 m
= match_complex_part (&imag
);
1280 if (m
== MATCH_ERROR
)
1283 m
= gfc_match_char (')');
1286 /* Give the matcher for implied do-loops a chance to run. This
1287 yields a much saner error message for (/ (i, 4=i, 6) /). */
1288 if (gfc_peek_ascii_char () == '=')
1297 if (m
== MATCH_ERROR
)
1300 /* Decide on the kind of this complex number. */
1301 if (real
->ts
.type
== BT_REAL
)
1303 if (imag
->ts
.type
== BT_REAL
)
1304 kind
= gfc_kind_max (real
, imag
);
1306 kind
= real
->ts
.kind
;
1310 if (imag
->ts
.type
== BT_REAL
)
1311 kind
= imag
->ts
.kind
;
1313 kind
= gfc_default_real_kind
;
1315 gfc_clear_ts (&target
);
1316 target
.type
= BT_REAL
;
1319 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1320 gfc_convert_type (real
, &target
, 2);
1321 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1322 gfc_convert_type (imag
, &target
, 2);
1324 e
= gfc_convert_complex (real
, imag
, kind
);
1325 e
->where
= gfc_current_locus
;
1327 gfc_free_expr (real
);
1328 gfc_free_expr (imag
);
1334 gfc_error ("Syntax error in COMPLEX constant at %C");
1339 gfc_free_expr (real
);
1340 gfc_free_expr (imag
);
1341 gfc_current_locus
= old_loc
;
1347 /* Match constants in any of several forms. Returns nonzero for a
1348 match, zero for no match. */
1351 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1355 m
= match_complex_constant (result
);
1359 m
= match_string_constant (result
);
1363 m
= match_boz_constant (result
);
1367 m
= match_real_constant (result
, signflag
);
1371 m
= match_hollerith_constant (result
);
1375 m
= match_integer_constant (result
, signflag
);
1379 m
= match_logical_constant (result
);
1387 /* This checks if a symbol is the return value of an encompassing function.
1388 Function nesting can be maximally two levels deep, but we may have
1389 additional local namespaces like BLOCK etc. */
1392 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1394 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1398 if (ns
->proc_name
== sym
)
1406 /* Match a single actual argument value. An actual argument is
1407 usually an expression, but can also be a procedure name. If the
1408 argument is a single name, it is not always possible to tell
1409 whether the name is a dummy procedure or not. We treat these cases
1410 by creating an argument that looks like a dummy procedure and
1411 fixing things later during resolution. */
1414 match_actual_arg (gfc_expr
**result
)
1416 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1417 gfc_symtree
*symtree
;
1422 gfc_gobble_whitespace ();
1423 where
= gfc_current_locus
;
1425 switch (gfc_match_name (name
))
1434 w
= gfc_current_locus
;
1435 gfc_gobble_whitespace ();
1436 c
= gfc_next_ascii_char ();
1437 gfc_current_locus
= w
;
1439 if (c
!= ',' && c
!= ')')
1442 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1444 /* Handle error elsewhere. */
1446 /* Eliminate a couple of common cases where we know we don't
1447 have a function argument. */
1448 if (symtree
== NULL
)
1450 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1451 gfc_set_sym_referenced (symtree
->n
.sym
);
1457 sym
= symtree
->n
.sym
;
1458 gfc_set_sym_referenced (sym
);
1459 if (sym
->attr
.flavor
!= FL_PROCEDURE
1460 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1463 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1465 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
,
1470 /* If the symbol is a function with itself as the result and
1471 is being defined, then we have a variable. */
1472 if (sym
->attr
.function
&& sym
->result
== sym
)
1474 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1478 && (sym
->ns
== gfc_current_ns
1479 || sym
->ns
== gfc_current_ns
->parent
))
1481 gfc_entry_list
*el
= NULL
;
1483 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1493 e
= gfc_get_expr (); /* Leave it unknown for now */
1494 e
->symtree
= symtree
;
1495 e
->expr_type
= EXPR_VARIABLE
;
1496 e
->ts
.type
= BT_PROCEDURE
;
1503 gfc_current_locus
= where
;
1504 return gfc_match_expr (result
);
1508 /* Match a keyword argument. */
1511 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1513 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1514 gfc_actual_arglist
*a
;
1518 name_locus
= gfc_current_locus
;
1519 m
= gfc_match_name (name
);
1523 if (gfc_match_char ('=') != MATCH_YES
)
1529 m
= match_actual_arg (&actual
->expr
);
1533 /* Make sure this name has not appeared yet. */
1535 if (name
[0] != '\0')
1537 for (a
= base
; a
; a
= a
->next
)
1538 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1540 gfc_error ("Keyword '%s' at %C has already appeared in the "
1541 "current argument list", name
);
1546 actual
->name
= gfc_get_string (name
);
1550 gfc_current_locus
= name_locus
;
1555 /* Match an argument list function, such as %VAL. */
1558 match_arg_list_function (gfc_actual_arglist
*result
)
1560 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1564 old_locus
= gfc_current_locus
;
1566 if (gfc_match_char ('%') != MATCH_YES
)
1572 m
= gfc_match ("%n (", name
);
1576 if (name
[0] != '\0')
1581 if (strncmp (name
, "loc", 3) == 0)
1583 result
->name
= "%LOC";
1587 if (strncmp (name
, "ref", 3) == 0)
1589 result
->name
= "%REF";
1593 if (strncmp (name
, "val", 3) == 0)
1595 result
->name
= "%VAL";
1604 if (gfc_notify_std (GFC_STD_GNU
, "Extension: argument list "
1605 "function at %C") == FAILURE
)
1611 m
= match_actual_arg (&result
->expr
);
1615 if (gfc_match_char (')') != MATCH_YES
)
1624 gfc_current_locus
= old_locus
;
1629 /* Matches an actual argument list of a function or subroutine, from
1630 the opening parenthesis to the closing parenthesis. The argument
1631 list is assumed to allow keyword arguments because we don't know if
1632 the symbol associated with the procedure has an implicit interface
1633 or not. We make sure keywords are unique. If sub_flag is set,
1634 we're matching the argument list of a subroutine. */
1637 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1639 gfc_actual_arglist
*head
, *tail
;
1641 gfc_st_label
*label
;
1645 *argp
= tail
= NULL
;
1646 old_loc
= gfc_current_locus
;
1650 if (gfc_match_char ('(') == MATCH_NO
)
1651 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1653 if (gfc_match_char (')') == MATCH_YES
)
1657 matching_actual_arglist
++;
1662 head
= tail
= gfc_get_actual_arglist ();
1665 tail
->next
= gfc_get_actual_arglist ();
1669 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1671 m
= gfc_match_st_label (&label
);
1673 gfc_error ("Expected alternate return label at %C");
1677 tail
->label
= label
;
1681 /* After the first keyword argument is seen, the following
1682 arguments must also have keywords. */
1685 m
= match_keyword_arg (tail
, head
);
1687 if (m
== MATCH_ERROR
)
1691 gfc_error ("Missing keyword name in actual argument list at %C");
1698 /* Try an argument list function, like %VAL. */
1699 m
= match_arg_list_function (tail
);
1700 if (m
== MATCH_ERROR
)
1703 /* See if we have the first keyword argument. */
1706 m
= match_keyword_arg (tail
, head
);
1709 if (m
== MATCH_ERROR
)
1715 /* Try for a non-keyword argument. */
1716 m
= match_actual_arg (&tail
->expr
);
1717 if (m
== MATCH_ERROR
)
1726 if (gfc_match_char (')') == MATCH_YES
)
1728 if (gfc_match_char (',') != MATCH_YES
)
1733 matching_actual_arglist
--;
1737 gfc_error ("Syntax error in argument list at %C");
1740 gfc_free_actual_arglist (head
);
1741 gfc_current_locus
= old_loc
;
1742 matching_actual_arglist
--;
1747 /* Used by gfc_match_varspec() to extend the reference list by one
1751 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1753 if (primary
->ref
== NULL
)
1754 primary
->ref
= tail
= gfc_get_ref ();
1758 gfc_internal_error ("extend_ref(): Bad tail");
1759 tail
->next
= gfc_get_ref ();
1767 /* Match any additional specifications associated with the current
1768 variable like member references or substrings. If equiv_flag is
1769 set we only match stuff that is allowed inside an EQUIVALENCE
1770 statement. sub_flag tells whether we expect a type-bound procedure found
1771 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1772 components, 'ppc_arg' determines whether the PPC may be called (with an
1773 argument list), or whether it may just be referred to as a pointer. */
1776 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1779 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1780 gfc_ref
*substring
, *tail
;
1781 gfc_component
*component
;
1782 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1788 gfc_gobble_whitespace ();
1790 if (gfc_peek_ascii_char () == '[')
1792 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1793 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1794 && CLASS_DATA (sym
)->attr
.dimension
))
1796 gfc_error ("Array section designator, e.g. '(:)', is required "
1797 "besides the coarray designator '[...]' at %C");
1800 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1801 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1802 && !CLASS_DATA (sym
)->attr
.codimension
))
1804 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1810 /* For associate names, we may not yet know whether they are arrays or not.
1811 Thus if we have one and parentheses follow, we have to assume that it
1812 actually is one for now. The final decision will be made at
1813 resolution time, of course. */
1814 if (sym
->assoc
&& gfc_peek_ascii_char () == '(')
1815 sym
->attr
.dimension
= 1;
1817 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1818 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1819 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1820 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
, NULL
)
1821 && !(gfc_matching_procptr_assignment
1822 && sym
->attr
.flavor
== FL_PROCEDURE
))
1823 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1824 && (CLASS_DATA (sym
)->attr
.dimension
1825 || CLASS_DATA (sym
)->attr
.codimension
)))
1827 /* In EQUIVALENCE, we don't know yet whether we are seeing
1828 an array, character variable or array of character
1829 variables. We'll leave the decision till resolve time. */
1830 tail
= extend_ref (primary
, tail
);
1831 tail
->type
= REF_ARRAY
;
1833 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1835 sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1836 ? (CLASS_DATA (sym
)->as
1837 ? CLASS_DATA (sym
)->as
->corank
: 0)
1838 : (sym
->as
? sym
->as
->corank
: 0));
1842 gfc_gobble_whitespace ();
1843 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1845 tail
= extend_ref (primary
, tail
);
1846 tail
->type
= REF_ARRAY
;
1848 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1854 primary
->ts
= sym
->ts
;
1859 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_ascii_char () == '%'
1860 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1861 gfc_set_default_type (sym
, 0, sym
->ns
);
1863 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1864 || gfc_match_char ('%') != MATCH_YES
)
1865 goto check_substring
;
1867 sym
= sym
->ts
.u
.derived
;
1874 m
= gfc_match_name (name
);
1876 gfc_error ("Expected structure component name at %C");
1880 if (sym
->f2k_derived
)
1881 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
1887 gfc_symbol
* tbp_sym
;
1892 gcc_assert (!tail
|| !tail
->next
);
1893 gcc_assert (primary
->expr_type
== EXPR_VARIABLE
1894 || (primary
->expr_type
== EXPR_STRUCTURE
1895 && primary
->symtree
&& primary
->symtree
->n
.sym
1896 && primary
->symtree
->n
.sym
->attr
.flavor
));
1898 if (tbp
->n
.tb
->is_generic
)
1901 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
1903 primary
->expr_type
= EXPR_COMPCALL
;
1904 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
1905 primary
->value
.compcall
.name
= tbp
->name
;
1906 primary
->value
.compcall
.ignore_pass
= 0;
1907 primary
->value
.compcall
.assign
= 0;
1908 primary
->value
.compcall
.base_object
= NULL
;
1909 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
1911 primary
->ts
= tbp_sym
->ts
;
1913 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
1914 &primary
->value
.compcall
.actual
);
1915 if (m
== MATCH_ERROR
)
1920 primary
->value
.compcall
.actual
= NULL
;
1923 gfc_error ("Expected argument list at %C");
1931 component
= gfc_find_component (sym
, name
, false, false);
1932 if (component
== NULL
)
1935 tail
= extend_ref (primary
, tail
);
1936 tail
->type
= REF_COMPONENT
;
1938 tail
->u
.c
.component
= component
;
1939 tail
->u
.c
.sym
= sym
;
1941 primary
->ts
= component
->ts
;
1943 if (component
->attr
.proc_pointer
&& ppc_arg
1944 && !gfc_matching_procptr_assignment
)
1946 /* Procedure pointer component call: Look for argument list. */
1947 m
= gfc_match_actual_arglist (sub_flag
,
1948 &primary
->value
.compcall
.actual
);
1949 if (m
== MATCH_ERROR
)
1952 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
1953 && !matching_actual_arglist
)
1955 gfc_error ("Procedure pointer component '%s' requires an "
1956 "argument list at %C", component
->name
);
1961 primary
->expr_type
= EXPR_PPC
;
1966 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
1968 tail
= extend_ref (primary
, tail
);
1969 tail
->type
= REF_ARRAY
;
1971 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
1972 component
->as
->corank
);
1976 else if (component
->ts
.type
== BT_CLASS
1977 && CLASS_DATA (component
)->as
!= NULL
1978 && !component
->attr
.proc_pointer
)
1980 tail
= extend_ref (primary
, tail
);
1981 tail
->type
= REF_ARRAY
;
1983 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
1985 CLASS_DATA (component
)->as
->corank
);
1990 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
1991 || gfc_match_char ('%') != MATCH_YES
)
1994 sym
= component
->ts
.u
.derived
;
1999 if (primary
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.flavor
!= FL_DERIVED
)
2001 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2003 gfc_set_default_type (sym
, 0, sym
->ns
);
2004 primary
->ts
= sym
->ts
;
2009 if (primary
->ts
.type
== BT_CHARACTER
)
2011 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
))
2015 primary
->ref
= substring
;
2017 tail
->next
= substring
;
2019 if (primary
->expr_type
== EXPR_CONSTANT
)
2020 primary
->expr_type
= EXPR_SUBSTRING
;
2023 primary
->ts
.u
.cl
= NULL
;
2030 gfc_clear_ts (&primary
->ts
);
2031 gfc_clear_ts (&sym
->ts
);
2041 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2043 gfc_error ("Coindexed procedure-pointer component at %C");
2051 /* Given an expression that is a variable, figure out what the
2052 ultimate variable's type and attribute is, traversing the reference
2053 structures if necessary.
2055 This subroutine is trickier than it looks. We start at the base
2056 symbol and store the attribute. Component references load a
2057 completely new attribute.
2059 A couple of rules come into play. Subobjects of targets are always
2060 targets themselves. If we see a component that goes through a
2061 pointer, then the expression must also be a target, since the
2062 pointer is associated with something (if it isn't core will soon be
2063 dumped). If we see a full part or section of an array, the
2064 expression is also an array.
2066 We can have at most one full array reference. */
2069 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2071 int dimension
, pointer
, allocatable
, target
;
2072 symbol_attribute attr
;
2075 gfc_component
*comp
;
2077 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2078 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2080 sym
= expr
->symtree
->n
.sym
;
2083 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2085 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2086 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2087 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2091 dimension
= attr
.dimension
;
2092 pointer
= attr
.pointer
;
2093 allocatable
= attr
.allocatable
;
2096 target
= attr
.target
;
2097 if (pointer
|| attr
.proc_pointer
)
2100 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2103 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2108 switch (ref
->u
.ar
.type
)
2115 allocatable
= pointer
= 0;
2120 /* Handle coarrays. */
2121 if (ref
->u
.ar
.dimen
> 0)
2122 allocatable
= pointer
= 0;
2126 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2132 comp
= ref
->u
.c
.component
;
2137 /* Don't set the string length if a substring reference
2139 if (ts
->type
== BT_CHARACTER
2140 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2144 if (comp
->ts
.type
== BT_CLASS
)
2146 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2147 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2151 pointer
= comp
->attr
.pointer
;
2152 allocatable
= comp
->attr
.allocatable
;
2154 if (pointer
|| attr
.proc_pointer
)
2160 allocatable
= pointer
= 0;
2164 attr
.dimension
= dimension
;
2165 attr
.pointer
= pointer
;
2166 attr
.allocatable
= allocatable
;
2167 attr
.target
= target
;
2168 attr
.save
= sym
->attr
.save
;
2174 /* Return the attribute from a general expression. */
2177 gfc_expr_attr (gfc_expr
*e
)
2179 symbol_attribute attr
;
2181 switch (e
->expr_type
)
2184 attr
= gfc_variable_attr (e
, NULL
);
2188 gfc_clear_attr (&attr
);
2190 if (e
->value
.function
.esym
!= NULL
)
2192 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2194 if (sym
->ts
.type
== BT_CLASS
)
2196 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2197 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2198 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2202 attr
= gfc_variable_attr (e
, NULL
);
2204 /* TODO: NULL() returns pointers. May have to take care of this
2210 gfc_clear_attr (&attr
);
2218 /* Match a structure constructor. The initial symbol has already been
2221 typedef struct gfc_structure_ctor_component
2226 struct gfc_structure_ctor_component
* next
;
2228 gfc_structure_ctor_component
;
2230 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2233 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2236 gfc_free_expr (comp
->val
);
2241 /* Translate the component list into the actual constructor by sorting it in
2242 the order required; this also checks along the way that each and every
2243 component actually has an initializer and handles default initializers
2244 for components without explicit value given. */
2246 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2247 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2249 gfc_structure_ctor_component
*comp_iter
;
2250 gfc_component
*comp
;
2252 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2254 gfc_structure_ctor_component
**next_ptr
;
2255 gfc_expr
*value
= NULL
;
2257 /* Try to find the initializer for the current component by name. */
2258 next_ptr
= comp_head
;
2259 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2261 if (!strcmp (comp_iter
->name
, comp
->name
))
2263 next_ptr
= &comp_iter
->next
;
2266 /* If an extension, try building the parent derived type by building
2267 a value expression for the parent derived type and calling self. */
2268 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2270 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2272 &gfc_current_locus
);
2273 value
->ts
= comp
->ts
;
2275 if (build_actual_constructor (comp_head
, &value
->value
.constructor
,
2276 comp
->ts
.u
.derived
) == FAILURE
)
2278 gfc_free_expr (value
);
2282 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2286 /* If it was not found, try the default initializer if there's any;
2287 otherwise, it's an error. */
2290 if (comp
->initializer
)
2292 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2293 " constructor with missing optional arguments"
2294 " at %C") == FAILURE
)
2296 value
= gfc_copy_expr (comp
->initializer
);
2300 gfc_error ("No initializer for component '%s' given in the"
2301 " structure constructor at %C!", comp
->name
);
2306 value
= comp_iter
->val
;
2308 /* Add the value to the constructor chain built. */
2309 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2311 /* Remove the entry from the component list. We don't want the expression
2312 value to be free'd, so set it to NULL. */
2315 *next_ptr
= comp_iter
->next
;
2316 comp_iter
->val
= NULL
;
2317 gfc_free_structure_ctor_component (comp_iter
);
2325 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2326 gfc_actual_arglist
**arglist
,
2329 gfc_actual_arglist
*actual
;
2330 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2331 gfc_constructor_base ctor_head
= NULL
;
2332 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2333 const char* last_name
= NULL
;
2337 expr
= parent
? *cexpr
: e
;
2338 old_locus
= gfc_current_locus
;
2340 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2342 gfc_current_locus
= expr
->where
;
2344 comp_tail
= comp_head
= NULL
;
2346 if (!parent
&& sym
->attr
.abstract
)
2348 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2349 sym
->name
, &expr
->where
);
2353 comp
= sym
->components
;
2354 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2357 gfc_component
*this_comp
= NULL
;
2360 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2363 comp_tail
->next
= gfc_get_structure_ctor_component ();
2364 comp_tail
= comp_tail
->next
;
2368 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Structure"
2369 " constructor with named arguments at %C")
2373 comp_tail
->name
= xstrdup (actual
->name
);
2374 last_name
= comp_tail
->name
;
2379 /* Components without name are not allowed after the first named
2380 component initializer! */
2384 gfc_error ("Component initializer without name after component"
2385 " named %s at %L!", last_name
,
2386 actual
->expr
? &actual
->expr
->where
2387 : &gfc_current_locus
);
2389 gfc_error ("Too many components in structure constructor at "
2390 "%L!", actual
->expr
? &actual
->expr
->where
2391 : &gfc_current_locus
);
2395 comp_tail
->name
= xstrdup (comp
->name
);
2398 /* Find the current component in the structure definition and check
2399 its access is not private. */
2401 this_comp
= gfc_find_component (sym
, comp
->name
, false, false);
2404 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2406 comp
= NULL
; /* Reset needed! */
2409 /* Here we can check if a component name is given which does not
2410 correspond to any component of the defined structure. */
2414 comp_tail
->val
= actual
->expr
;
2415 if (actual
->expr
!= NULL
)
2416 comp_tail
->where
= actual
->expr
->where
;
2417 actual
->expr
= NULL
;
2419 /* Check if this component is already given a value. */
2420 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2421 comp_iter
= comp_iter
->next
)
2423 gcc_assert (comp_iter
);
2424 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2426 gfc_error ("Component '%s' is initialized twice in the structure"
2427 " constructor at %L!", comp_tail
->name
,
2428 comp_tail
->val
? &comp_tail
->where
2429 : &gfc_current_locus
);
2434 /* F2008, R457/C725, for PURE C1283. */
2435 if (this_comp
->attr
.pointer
&& comp_tail
->val
2436 && gfc_is_coindexed (comp_tail
->val
))
2438 gfc_error ("Coindexed expression to pointer component '%s' in "
2439 "structure constructor at %L!", comp_tail
->name
,
2444 /* If not explicitly a parent constructor, gather up the components
2446 if (comp
&& comp
== sym
->components
2447 && sym
->attr
.extension
2449 && (comp_tail
->val
->ts
.type
!= BT_DERIVED
2451 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2454 gfc_actual_arglist
*arg_null
= NULL
;
2456 actual
->expr
= comp_tail
->val
;
2457 comp_tail
->val
= NULL
;
2459 m
= gfc_convert_to_structure_constructor (NULL
,
2460 comp
->ts
.u
.derived
, &comp_tail
->val
,
2461 comp
->ts
.u
.derived
->attr
.zero_comp
2462 ? &arg_null
: &actual
, true);
2466 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2475 if (parent
&& !comp
)
2478 actual
= actual
->next
;
2481 if (build_actual_constructor (&comp_head
, &ctor_head
, sym
) == FAILURE
)
2484 /* No component should be left, as this should have caused an error in the
2485 loop constructing the component-list (name that does not correspond to any
2486 component in the structure definition). */
2487 if (comp_head
&& sym
->attr
.extension
)
2489 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2491 gfc_error ("component '%s' at %L has already been set by a "
2492 "parent derived type constructor", comp_iter
->name
,
2498 gcc_assert (!comp_head
);
2502 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2503 expr
->ts
.u
.derived
= sym
;
2504 expr
->value
.constructor
= ctor_head
;
2509 expr
->ts
.u
.derived
= sym
;
2511 expr
->ts
.type
= BT_DERIVED
;
2512 expr
->value
.constructor
= ctor_head
;
2513 expr
->expr_type
= EXPR_STRUCTURE
;
2516 gfc_current_locus
= old_locus
;
2522 gfc_current_locus
= old_locus
;
2524 for (comp_iter
= comp_head
; comp_iter
; )
2526 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2527 gfc_free_structure_ctor_component (comp_iter
);
2530 gfc_constructor_free (ctor_head
);
2537 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2541 gfc_symtree
*symtree
;
2543 gfc_get_sym_tree (sym
->name
, NULL
, &symtree
, false); /* Can't fail */
2545 e
= gfc_get_expr ();
2546 e
->symtree
= symtree
;
2547 e
->expr_type
= EXPR_FUNCTION
;
2549 gcc_assert (sym
->attr
.flavor
== FL_DERIVED
2550 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2551 e
->value
.function
.esym
= sym
;
2552 e
->symtree
->n
.sym
->attr
.generic
= 1;
2554 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2561 if (gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false)
2573 /* If the symbol is an implicit do loop index and implicitly typed,
2574 it should not be host associated. Provide a symtree from the
2575 current namespace. */
2577 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2579 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2580 && (*sym
)->ns
!= gfc_current_ns
2581 && (*sym
)->attr
.implied_index
2582 && (*sym
)->attr
.implicit_type
2583 && !(*sym
)->attr
.use_assoc
)
2586 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2589 *sym
= (*st
)->n
.sym
;
2595 /* Procedure pointer as function result: Replace the function symbol by the
2596 auto-generated hidden result variable named "ppr@". */
2599 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2601 /* Check for procedure pointer result variable. */
2602 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2603 && (*sym
)->result
&& (*sym
)->result
!= *sym
2604 && (*sym
)->result
->attr
.proc_pointer
2605 && (*sym
) == gfc_current_ns
->proc_name
2606 && (*sym
) == (*sym
)->result
->ns
->proc_name
2607 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2609 /* Automatic replacement with "hidden" result variable. */
2610 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2611 *sym
= (*sym
)->result
;
2612 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2619 /* Matches a variable name followed by anything that might follow it--
2620 array reference, argument list of a function, etc. */
2623 gfc_match_rvalue (gfc_expr
**result
)
2625 gfc_actual_arglist
*actual_arglist
;
2626 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2629 gfc_symtree
*symtree
;
2630 locus where
, old_loc
;
2638 m
= gfc_match_name (name
);
2642 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
2643 && !gfc_current_ns
->has_import_set
)
2644 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
2646 i
= gfc_get_ha_sym_tree (name
, &symtree
);
2651 sym
= symtree
->n
.sym
;
2653 where
= gfc_current_locus
;
2655 replace_hidden_procptr_result (&sym
, &symtree
);
2657 /* If this is an implicit do loop index and implicitly typed,
2658 it should not be host associated. */
2659 m
= check_for_implicit_index (&symtree
, &sym
);
2663 gfc_set_sym_referenced (sym
);
2664 sym
->attr
.implied_index
= 0;
2666 if (sym
->attr
.function
&& sym
->result
== sym
)
2668 /* See if this is a directly recursive function call. */
2669 gfc_gobble_whitespace ();
2670 if (sym
->attr
.recursive
2671 && gfc_peek_ascii_char () == '('
2672 && gfc_current_ns
->proc_name
== sym
2673 && !sym
->attr
.dimension
)
2675 gfc_error ("'%s' at %C is the name of a recursive function "
2676 "and so refers to the result variable. Use an "
2677 "explicit RESULT variable for direct recursion "
2678 "(12.5.2.1)", sym
->name
);
2682 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
2686 && (sym
->ns
== gfc_current_ns
2687 || sym
->ns
== gfc_current_ns
->parent
))
2689 gfc_entry_list
*el
= NULL
;
2691 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
2697 if (gfc_matching_procptr_assignment
)
2700 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
2703 if (sym
->attr
.generic
)
2704 goto generic_function
;
2706 switch (sym
->attr
.flavor
)
2710 e
= gfc_get_expr ();
2712 e
->expr_type
= EXPR_VARIABLE
;
2713 e
->symtree
= symtree
;
2715 m
= gfc_match_varspec (e
, 0, false, true);
2719 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2720 end up here. Unfortunately, sym->value->expr_type is set to
2721 EXPR_CONSTANT, and so the if () branch would be followed without
2722 the !sym->as check. */
2723 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
2724 e
= gfc_copy_expr (sym
->value
);
2727 e
= gfc_get_expr ();
2728 e
->expr_type
= EXPR_VARIABLE
;
2731 e
->symtree
= symtree
;
2732 m
= gfc_match_varspec (e
, 0, false, true);
2734 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
2737 /* Variable array references to derived type parameters cause
2738 all sorts of headaches in simplification. Treating such
2739 expressions as variable works just fine for all array
2741 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
2743 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2744 if (ref
->type
== REF_ARRAY
)
2747 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
2753 e
= gfc_get_expr ();
2754 e
->expr_type
= EXPR_VARIABLE
;
2755 e
->symtree
= symtree
;
2762 sym
= gfc_use_derived (sym
);
2766 goto generic_function
;
2769 /* If we're here, then the name is known to be the name of a
2770 procedure, yet it is not sure to be the name of a function. */
2773 /* Procedure Pointer Assignments. */
2775 if (gfc_matching_procptr_assignment
)
2777 gfc_gobble_whitespace ();
2778 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
2779 /* Parse functions returning a procptr. */
2782 if (gfc_is_intrinsic (sym
, 0, gfc_current_locus
)
2783 || gfc_is_intrinsic (sym
, 1, gfc_current_locus
))
2784 sym
->attr
.intrinsic
= 1;
2785 e
= gfc_get_expr ();
2786 e
->expr_type
= EXPR_VARIABLE
;
2787 e
->symtree
= symtree
;
2788 m
= gfc_match_varspec (e
, 0, false, true);
2792 if (sym
->attr
.subroutine
)
2794 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2800 /* At this point, the name has to be a non-statement function.
2801 If the name is the same as the current function being
2802 compiled, then we have a variable reference (to the function
2803 result) if the name is non-recursive. */
2805 st
= gfc_enclosing_unit (NULL
);
2807 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2809 && !sym
->attr
.recursive
)
2811 e
= gfc_get_expr ();
2812 e
->symtree
= symtree
;
2813 e
->expr_type
= EXPR_VARIABLE
;
2815 m
= gfc_match_varspec (e
, 0, false, true);
2819 /* Match a function reference. */
2821 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2824 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2825 gfc_error ("Statement function '%s' requires argument list at %C",
2828 gfc_error ("Function '%s' requires an argument list at %C",
2841 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2842 sym
= symtree
->n
.sym
;
2844 replace_hidden_procptr_result (&sym
, &symtree
);
2846 e
= gfc_get_expr ();
2847 e
->symtree
= symtree
;
2848 e
->expr_type
= EXPR_FUNCTION
;
2849 e
->value
.function
.actual
= actual_arglist
;
2850 e
->where
= gfc_current_locus
;
2852 if (sym
->as
!= NULL
)
2853 e
->rank
= sym
->as
->rank
;
2855 if (!sym
->attr
.function
2856 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2862 /* Check here for the existence of at least one argument for the
2863 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2864 argument(s) given will be checked in gfc_iso_c_func_interface,
2865 during resolution of the function call. */
2866 if (sym
->attr
.is_iso_c
== 1
2867 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
2868 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
2869 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
2870 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
2872 /* make sure we were given a param */
2873 if (actual_arglist
== NULL
)
2875 gfc_error ("Missing argument to '%s' at %C", sym
->name
);
2881 if (sym
->result
== NULL
)
2889 /* Special case for derived type variables that get their types
2890 via an IMPLICIT statement. This can't wait for the
2891 resolution phase. */
2893 if (gfc_peek_ascii_char () == '%'
2894 && sym
->ts
.type
== BT_UNKNOWN
2895 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2896 gfc_set_default_type (sym
, 0, sym
->ns
);
2898 /* If the symbol has a (co)dimension attribute, the expression is a
2901 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
2903 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2904 sym
->name
, NULL
) == FAILURE
)
2910 e
= gfc_get_expr ();
2911 e
->symtree
= symtree
;
2912 e
->expr_type
= EXPR_VARIABLE
;
2913 m
= gfc_match_varspec (e
, 0, false, true);
2917 if (sym
->ts
.type
== BT_CLASS
2918 && (CLASS_DATA (sym
)->attr
.dimension
2919 || CLASS_DATA (sym
)->attr
.codimension
))
2921 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2922 sym
->name
, NULL
) == FAILURE
)
2928 e
= gfc_get_expr ();
2929 e
->symtree
= symtree
;
2930 e
->expr_type
= EXPR_VARIABLE
;
2931 m
= gfc_match_varspec (e
, 0, false, true);
2935 /* Name is not an array, so we peek to see if a '(' implies a
2936 function call or a substring reference. Otherwise the
2937 variable is just a scalar. */
2939 gfc_gobble_whitespace ();
2940 if (gfc_peek_ascii_char () != '(')
2942 /* Assume a scalar variable */
2943 e
= gfc_get_expr ();
2944 e
->symtree
= symtree
;
2945 e
->expr_type
= EXPR_VARIABLE
;
2947 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2948 sym
->name
, NULL
) == FAILURE
)
2954 /*FIXME:??? gfc_match_varspec does set this for us: */
2956 m
= gfc_match_varspec (e
, 0, false, true);
2960 /* See if this is a function reference with a keyword argument
2961 as first argument. We do this because otherwise a spurious
2962 symbol would end up in the symbol table. */
2964 old_loc
= gfc_current_locus
;
2965 m2
= gfc_match (" ( %n =", argname
);
2966 gfc_current_locus
= old_loc
;
2968 e
= gfc_get_expr ();
2969 e
->symtree
= symtree
;
2971 if (m2
!= MATCH_YES
)
2973 /* Try to figure out whether we're dealing with a character type.
2974 We're peeking ahead here, because we don't want to call
2975 match_substring if we're dealing with an implicitly typed
2976 non-character variable. */
2977 implicit_char
= false;
2978 if (sym
->ts
.type
== BT_UNKNOWN
)
2980 ts
= gfc_get_default_type (sym
->name
, NULL
);
2981 if (ts
->type
== BT_CHARACTER
)
2982 implicit_char
= true;
2985 /* See if this could possibly be a substring reference of a name
2986 that we're not sure is a variable yet. */
2988 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
2989 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
) == MATCH_YES
)
2992 e
->expr_type
= EXPR_VARIABLE
;
2994 if (sym
->attr
.flavor
!= FL_VARIABLE
2995 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2996 sym
->name
, NULL
) == FAILURE
)
3002 if (sym
->ts
.type
== BT_UNKNOWN
3003 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3017 /* Give up, assume we have a function. */
3019 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3020 sym
= symtree
->n
.sym
;
3021 e
->expr_type
= EXPR_FUNCTION
;
3023 if (!sym
->attr
.function
3024 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3032 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3034 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
3042 /* If our new function returns a character, array or structure
3043 type, it might have subsequent references. */
3045 m
= gfc_match_varspec (e
, 0, false, true);
3052 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3054 e
= gfc_get_expr ();
3055 e
->symtree
= symtree
;
3056 e
->expr_type
= EXPR_FUNCTION
;
3058 if (sym
->attr
.flavor
== FL_DERIVED
)
3060 e
->value
.function
.esym
= sym
;
3061 e
->symtree
->n
.sym
->attr
.generic
= 1;
3064 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3068 gfc_error ("Symbol at %C is not appropriate for an expression");
3084 /* Match a variable, i.e. something that can be assigned to. This
3085 starts as a symbol, can be a structure component or an array
3086 reference. It can be a function if the function doesn't have a
3087 separate RESULT variable. If the symbol has not been previously
3088 seen, we assume it is a variable.
3090 This function is called by two interface functions:
3091 gfc_match_variable, which has host_flag = 1, and
3092 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3093 match of the symbol to the local scope. */
3096 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3104 /* Since nothing has any business being an lvalue in a module
3105 specification block, an interface block or a contains section,
3106 we force the changed_symbols mechanism to work by setting
3107 host_flag to 0. This prevents valid symbols that have the name
3108 of keywords, such as 'end', being turned into variables by
3109 failed matching to assignments for, e.g., END INTERFACE. */
3110 if (gfc_current_state () == COMP_MODULE
3111 || gfc_current_state () == COMP_INTERFACE
3112 || gfc_current_state () == COMP_CONTAINS
)
3115 where
= gfc_current_locus
;
3116 m
= gfc_match_sym_tree (&st
, host_flag
);
3122 /* If this is an implicit do loop index and implicitly typed,
3123 it should not be host associated. */
3124 m
= check_for_implicit_index (&st
, &sym
);
3128 sym
->attr
.implied_index
= 0;
3130 gfc_set_sym_referenced (sym
);
3131 switch (sym
->attr
.flavor
)
3134 /* Everything is alright. */
3139 sym_flavor flavor
= FL_UNKNOWN
;
3141 gfc_gobble_whitespace ();
3143 if (sym
->attr
.external
|| sym
->attr
.procedure
3144 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3145 flavor
= FL_PROCEDURE
;
3147 /* If it is not a procedure, is not typed and is host associated,
3148 we cannot give it a flavor yet. */
3149 else if (sym
->ns
== gfc_current_ns
->parent
3150 && sym
->ts
.type
== BT_UNKNOWN
)
3153 /* These are definitive indicators that this is a variable. */
3154 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3155 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3156 flavor
= FL_VARIABLE
;
3158 if (flavor
!= FL_UNKNOWN
3159 && gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
) == FAILURE
)
3167 gfc_error ("Named constant at %C in an EQUIVALENCE");
3170 /* Otherwise this is checked for and an error given in the
3171 variable definition context checks. */
3175 /* Check for a nonrecursive function result variable. */
3176 if (sym
->attr
.function
3177 && !sym
->attr
.external
3178 && sym
->result
== sym
3179 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3181 && sym
->ns
== gfc_current_ns
)
3183 && sym
->ns
== gfc_current_ns
->parent
)))
3185 /* If a function result is a derived type, then the derived
3186 type may still have to be resolved. */
3188 if (sym
->ts
.type
== BT_DERIVED
3189 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3194 if (sym
->attr
.proc_pointer
3195 || replace_hidden_procptr_result (&sym
, &st
) == SUCCESS
)
3198 /* Fall through to error */
3201 gfc_error ("'%s' at %C is not a variable", sym
->name
);
3205 /* Special case for derived type variables that get their types
3206 via an IMPLICIT statement. This can't wait for the
3207 resolution phase. */
3210 gfc_namespace
* implicit_ns
;
3212 if (gfc_current_ns
->proc_name
== sym
)
3213 implicit_ns
= gfc_current_ns
;
3215 implicit_ns
= sym
->ns
;
3217 if (gfc_peek_ascii_char () == '%'
3218 && sym
->ts
.type
== BT_UNKNOWN
3219 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3220 gfc_set_default_type (sym
, 0, implicit_ns
);
3223 expr
= gfc_get_expr ();
3225 expr
->expr_type
= EXPR_VARIABLE
;
3228 expr
->where
= where
;
3230 /* Now see if we have to do more. */
3231 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3234 gfc_free_expr (expr
);
3244 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3246 return match_variable (result
, equiv_flag
, 1);
3251 gfc_match_equiv_variable (gfc_expr
**result
)
3253 return match_variable (result
, 1, 0);