1 /* Primary expression subroutines
2 Copyright (C) 2000-2017 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
29 #include "constructor.h"
31 int matching_actual_arglist
= 0;
33 /* Matches a kind-parameter expression, which is either a named
34 symbolic constant or a nonnegative integer constant. If
35 successful, sets the kind value to the correct integer.
36 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
37 symbol like e.g. 'c_int'. */
40 match_kind_param (int *kind
, int *is_iso_c
)
42 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
48 m
= gfc_match_small_literal_int (kind
, NULL
);
52 m
= gfc_match_name (name
);
56 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
62 *is_iso_c
= sym
->attr
.is_iso_c
;
64 if (sym
->attr
.flavor
!= FL_PARAMETER
)
67 if (sym
->value
== NULL
)
70 if (gfc_extract_int (sym
->value
, kind
))
73 gfc_set_sym_referenced (sym
);
82 /* Get a trailing kind-specification for non-character variables.
84 * the integer kind value or
85 * -1 if an error was generated,
86 * -2 if no kind was found.
87 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
88 symbol like e.g. 'c_int'. */
91 get_kind (int *is_iso_c
)
98 if (gfc_match_char ('_') != MATCH_YES
)
101 m
= match_kind_param (&kind
, is_iso_c
);
103 gfc_error ("Missing kind-parameter at %C");
105 return (m
== MATCH_YES
) ? kind
: -1;
109 /* Given a character and a radix, see if the character is a valid
110 digit in that radix. */
113 gfc_check_digit (char c
, int radix
)
120 r
= ('0' <= c
&& c
<= '1');
124 r
= ('0' <= c
&& c
<= '7');
128 r
= ('0' <= c
&& c
<= '9');
136 gfc_internal_error ("gfc_check_digit(): bad radix");
143 /* Match the digit string part of an integer if signflag is not set,
144 the signed digit string part if signflag is set. If the buffer
145 is NULL, we just count characters for the resolution pass. Returns
146 the number of characters matched, -1 for no match. */
149 match_digits (int signflag
, int radix
, char *buffer
)
156 c
= gfc_next_ascii_char ();
158 if (signflag
&& (c
== '+' || c
== '-'))
162 gfc_gobble_whitespace ();
163 c
= gfc_next_ascii_char ();
167 if (!gfc_check_digit (c
, radix
))
176 old_loc
= gfc_current_locus
;
177 c
= gfc_next_ascii_char ();
179 if (!gfc_check_digit (c
, radix
))
187 gfc_current_locus
= old_loc
;
193 /* Match an integer (digit string and optional kind).
194 A sign will be accepted if signflag is set. */
197 match_integer_constant (gfc_expr
**result
, int signflag
)
199 int length
, kind
, is_iso_c
;
204 old_loc
= gfc_current_locus
;
205 gfc_gobble_whitespace ();
207 length
= match_digits (signflag
, 10, NULL
);
208 gfc_current_locus
= old_loc
;
212 buffer
= (char *) alloca (length
+ 1);
213 memset (buffer
, '\0', length
+ 1);
215 gfc_gobble_whitespace ();
217 match_digits (signflag
, 10, buffer
);
219 kind
= get_kind (&is_iso_c
);
221 kind
= gfc_default_integer_kind
;
225 if (kind
== 4 && flag_integer4_kind
== 8)
228 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
230 gfc_error ("Integer kind %d at %C not available", kind
);
234 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
235 e
->ts
.is_c_interop
= is_iso_c
;
237 if (gfc_range_check (e
) != ARITH_OK
)
239 gfc_error ("Integer too big for its kind at %C. This check can be "
240 "disabled with the option -fno-range-check");
251 /* Match a Hollerith constant. */
254 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
, "Hollerith constant at %C"))
270 if (gfc_extract_int (e
, &num
, 1))
274 gfc_error ("Invalid Hollerith constant: %L must contain at least "
275 "one character", &old_loc
);
278 if (e
->ts
.kind
!= gfc_default_integer_kind
)
280 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
281 "should be default", &old_loc
);
287 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
290 /* Calculate padding needed to fit default integer memory. */
291 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
293 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
295 for (i
= 0; i
< num
; i
++)
297 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
298 if (! gfc_wide_fits_in_byte (c
))
300 gfc_error ("Invalid Hollerith constant at %L contains a "
301 "wide character", &old_loc
);
305 e
->representation
.string
[i
] = (unsigned char) c
;
308 /* Now pad with blanks and end with a null char. */
309 for (i
= 0; i
< pad
; i
++)
310 e
->representation
.string
[num
+ i
] = ' ';
312 e
->representation
.string
[num
+ i
] = '\0';
313 e
->representation
.length
= num
+ pad
;
322 gfc_current_locus
= old_loc
;
331 /* Match a binary, octal or hexadecimal constant that can be found in
332 a DATA statement. The standard permits b'010...', o'73...', and
333 z'a1...' where b, o, and z can be capital letters. This function
334 also accepts postfixed forms of the constants: '01...'b, '73...'o,
335 and 'a1...'z. An additional extension is the use of x for z. */
338 match_boz_constant (gfc_expr
**result
)
340 int radix
, length
, x_hex
, kind
;
341 locus old_loc
, start_loc
;
342 char *buffer
, post
, delim
;
345 start_loc
= old_loc
= gfc_current_locus
;
346 gfc_gobble_whitespace ();
349 switch (post
= gfc_next_ascii_char ())
371 radix
= 16; /* Set to accept any valid digit string. */
377 /* No whitespace allowed here. */
380 delim
= gfc_next_ascii_char ();
382 if (delim
!= '\'' && delim
!= '\"')
386 && (!gfc_notify_std(GFC_STD_GNU
, "Hexadecimal "
387 "constant at %C uses non-standard syntax")))
390 old_loc
= gfc_current_locus
;
392 length
= match_digits (0, radix
, NULL
);
395 gfc_error ("Empty set of digits in BOZ constant at %C");
399 if (gfc_next_ascii_char () != delim
)
401 gfc_error ("Illegal character in BOZ constant at %C");
407 switch (gfc_next_ascii_char ())
424 if (!gfc_notify_std (GFC_STD_GNU
, "BOZ constant "
425 "at %C uses non-standard postfix syntax"))
429 gfc_current_locus
= old_loc
;
431 buffer
= (char *) alloca (length
+ 1);
432 memset (buffer
, '\0', length
+ 1);
434 match_digits (0, radix
, buffer
);
435 gfc_next_ascii_char (); /* Eat delimiter. */
437 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
439 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
440 "If a data-stmt-constant is a boz-literal-constant, the corresponding
441 variable shall be of type integer. The boz-literal-constant is treated
442 as if it were an int-literal-constant with a kind-param that specifies
443 the representation method with the largest decimal exponent range
444 supported by the processor." */
446 kind
= gfc_max_integer_kind
;
447 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
449 /* Mark as boz variable. */
452 if (gfc_range_check (e
) != ARITH_OK
)
454 gfc_error ("Integer too big for integer kind %i at %C", kind
);
459 if (!gfc_in_match_data ()
460 && (!gfc_notify_std(GFC_STD_F2003
, "BOZ used outside a DATA "
468 gfc_current_locus
= start_loc
;
473 /* Match a real constant of some sort. Allow a signed constant if signflag
477 match_real_constant (gfc_expr
**result
, int signflag
)
479 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
, default_exponent
;
480 locus old_loc
, temp_loc
;
481 char *p
, *buffer
, c
, exp_char
;
485 old_loc
= gfc_current_locus
;
486 gfc_gobble_whitespace ();
490 default_exponent
= 0;
497 c
= gfc_next_ascii_char ();
498 if (signflag
&& (c
== '+' || c
== '-'))
503 gfc_gobble_whitespace ();
504 c
= gfc_next_ascii_char ();
507 /* Scan significand. */
508 for (;; c
= gfc_next_ascii_char (), count
++)
515 /* Check to see if "." goes with a following operator like
517 temp_loc
= gfc_current_locus
;
518 c
= gfc_next_ascii_char ();
520 if (c
== 'e' || c
== 'd' || c
== 'q')
522 c
= gfc_next_ascii_char ();
524 goto done
; /* Operator named .e. or .d. */
528 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
530 gfc_current_locus
= temp_loc
;
544 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
551 if (!gfc_notify_std (GFC_STD_GNU
, "exponent-letter 'q' in "
552 "real-literal-constant at %C"))
554 else if (warn_real_q_constant
)
555 gfc_warning (OPT_Wreal_q_constant
,
556 "Extension: exponent-letter %<q%> in real-literal-constant "
561 c
= gfc_next_ascii_char ();
564 if (c
== '+' || c
== '-')
565 { /* optional sign */
566 c
= gfc_next_ascii_char ();
572 /* With -fdec, default exponent to 0 instead of complaining. */
574 default_exponent
= 1;
577 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
+ default_exponent
+ 1);
601 memset (buffer
, '\0', count
+ default_exponent
+ 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 ();
624 if (default_exponent
)
627 kind
= get_kind (&is_iso_c
);
636 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
640 kind
= gfc_default_double_kind
;
644 if (flag_real4_kind
== 8)
646 if (flag_real4_kind
== 10)
648 if (flag_real4_kind
== 16)
654 if (flag_real8_kind
== 4)
656 if (flag_real8_kind
== 10)
658 if (flag_real8_kind
== 16)
666 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
671 /* The maximum possible real kind type parameter is 16. First, try
672 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
673 extended precision. If neither value works, just given up. */
675 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
678 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
680 gfc_error ("Invalid exponent-letter %<q%> in "
681 "real-literal-constant at %C");
689 kind
= gfc_default_real_kind
;
693 if (flag_real4_kind
== 8)
695 if (flag_real4_kind
== 10)
697 if (flag_real4_kind
== 16)
703 if (flag_real8_kind
== 4)
705 if (flag_real8_kind
== 10)
707 if (flag_real8_kind
== 16)
711 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
713 gfc_error ("Invalid real kind %d at %C", kind
);
718 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
720 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
721 e
->ts
.is_c_interop
= is_iso_c
;
723 switch (gfc_range_check (e
))
728 gfc_error ("Real constant overflows its kind at %C");
731 case ARITH_UNDERFLOW
:
733 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
734 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
738 gfc_internal_error ("gfc_range_check() returned bad value");
741 /* Warn about trailing digits which suggest the user added too many
742 trailing digits, which may cause the appearance of higher pecision
743 than the kind kan support.
745 This is done by replacing the rightmost non-zero digit with zero
746 and comparing with the original value. If these are equal, we
747 assume the user supplied more digits than intended (or forgot to
748 convert to the correct kind).
751 if (warn_conversion_extra
)
757 c
= strchr (buffer
, 'e');
759 c
= buffer
+ strlen(buffer
);
762 for (p
= c
- 1; p
>= buffer
; p
--)
778 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
780 mpfr_neg (r
, r
, GFC_RND_MODE
);
782 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
784 if (mpfr_cmp_ui (r
, 0) == 0)
785 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
786 "in %qs number at %C, maybe incorrect KIND",
787 gfc_typename (&e
->ts
));
802 /* Match a substring reference. */
805 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
, bool deferred
)
807 gfc_expr
*start
, *end
;
815 old_loc
= gfc_current_locus
;
817 m
= gfc_match_char ('(');
821 if (gfc_match_char (':') != MATCH_YES
)
824 m
= gfc_match_init_expr (&start
);
826 m
= gfc_match_expr (&start
);
834 m
= gfc_match_char (':');
839 if (gfc_match_char (')') != MATCH_YES
)
842 m
= gfc_match_init_expr (&end
);
844 m
= gfc_match_expr (&end
);
848 if (m
== MATCH_ERROR
)
851 m
= gfc_match_char (')');
856 /* Optimize away the (:) reference. */
857 if (start
== NULL
&& end
== NULL
&& !deferred
)
861 ref
= gfc_get_ref ();
863 ref
->type
= REF_SUBSTRING
;
865 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
866 ref
->u
.ss
.start
= start
;
867 if (end
== NULL
&& cl
)
868 end
= gfc_copy_expr (cl
->length
);
870 ref
->u
.ss
.length
= cl
;
877 gfc_error ("Syntax error in SUBSTRING specification at %C");
881 gfc_free_expr (start
);
884 gfc_current_locus
= old_loc
;
889 /* Reads the next character of a string constant, taking care to
890 return doubled delimiters on the input as a single instance of
893 Special return values for "ret" argument are:
894 -1 End of the string, as determined by the delimiter
895 -2 Unterminated string detected
897 Backslash codes are also expanded at this time. */
900 next_string_char (gfc_char_t delimiter
, int *ret
)
905 c
= gfc_next_char_literal (INSTRING_WARN
);
914 if (flag_backslash
&& c
== '\\')
916 old_locus
= gfc_current_locus
;
918 if (gfc_match_special_char (&c
) == MATCH_NO
)
919 gfc_current_locus
= old_locus
;
921 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
922 gfc_warning (0, "Extension: backslash character at %C");
928 old_locus
= gfc_current_locus
;
929 c
= gfc_next_char_literal (NONSTRING
);
933 gfc_current_locus
= old_locus
;
940 /* Special case of gfc_match_name() that matches a parameter kind name
941 before a string constant. This takes case of the weird but legal
946 where kind____ is a parameter. gfc_match_name() will happily slurp
947 up all the underscores, which leads to problems. If we return
948 MATCH_YES, the parse pointer points to the final underscore, which
949 is not part of the name. We never return MATCH_ERROR-- errors in
950 the name will be detected later. */
953 match_charkind_name (char *name
)
959 gfc_gobble_whitespace ();
960 c
= gfc_next_ascii_char ();
969 old_loc
= gfc_current_locus
;
970 c
= gfc_next_ascii_char ();
974 peek
= gfc_peek_ascii_char ();
976 if (peek
== '\'' || peek
== '\"')
978 gfc_current_locus
= old_loc
;
986 && (c
!= '$' || !flag_dollar_ok
))
990 if (++len
> GFC_MAX_SYMBOL_LEN
)
998 /* See if the current input matches a character constant. Lots of
999 contortions have to be done to match the kind parameter which comes
1000 before the actual string. The main consideration is that we don't
1001 want to error out too quickly. For example, we don't actually do
1002 any validation of the kinds until we have actually seen a legal
1003 delimiter. Using match_kind_param() generates errors too quickly. */
1006 match_string_constant (gfc_expr
**result
)
1008 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1009 int i
, kind
, length
, save_warn_ampersand
, ret
;
1010 locus old_locus
, start_locus
;
1014 gfc_char_t c
, delimiter
, *p
;
1016 old_locus
= gfc_current_locus
;
1018 gfc_gobble_whitespace ();
1020 c
= gfc_next_char ();
1021 if (c
== '\'' || c
== '"')
1023 kind
= gfc_default_character_kind
;
1024 start_locus
= gfc_current_locus
;
1028 if (gfc_wide_is_digit (c
))
1032 while (gfc_wide_is_digit (c
))
1034 kind
= kind
* 10 + c
- '0';
1037 c
= gfc_next_char ();
1043 gfc_current_locus
= old_locus
;
1045 m
= match_charkind_name (name
);
1049 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1051 || sym
->attr
.flavor
!= FL_PARAMETER
)
1055 c
= gfc_next_char ();
1060 gfc_gobble_whitespace ();
1061 c
= gfc_next_char ();
1067 gfc_gobble_whitespace ();
1069 c
= gfc_next_char ();
1070 if (c
!= '\'' && c
!= '"')
1073 start_locus
= gfc_current_locus
;
1077 if (gfc_extract_int (sym
->value
, &kind
, 1))
1079 gfc_set_sym_referenced (sym
);
1082 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1084 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1089 /* Scan the string into a block of memory by first figuring out how
1090 long it is, allocating the structure, then re-reading it. This
1091 isn't particularly efficient, but string constants aren't that
1092 common in most code. TODO: Use obstacks? */
1099 c
= next_string_char (delimiter
, &ret
);
1104 gfc_current_locus
= start_locus
;
1105 gfc_error ("Unterminated character constant beginning at %C");
1112 /* Peek at the next character to see if it is a b, o, z, or x for the
1113 postfixed BOZ literal constants. */
1114 peek
= gfc_peek_ascii_char ();
1115 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1118 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1120 gfc_current_locus
= start_locus
;
1122 /* We disable the warning for the following loop as the warning has already
1123 been printed in the loop above. */
1124 save_warn_ampersand
= warn_ampersand
;
1125 warn_ampersand
= false;
1127 p
= e
->value
.character
.string
;
1128 for (i
= 0; i
< length
; i
++)
1130 c
= next_string_char (delimiter
, &ret
);
1132 if (!gfc_check_character_range (c
, kind
))
1135 gfc_error ("Character %qs in string at %C is not representable "
1136 "in character kind %d", gfc_print_wide_char (c
), kind
);
1143 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1144 warn_ampersand
= save_warn_ampersand
;
1146 next_string_char (delimiter
, &ret
);
1148 gfc_internal_error ("match_string_constant(): Delimiter not found");
1150 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1151 e
->expr_type
= EXPR_SUBSTRING
;
1158 gfc_current_locus
= old_locus
;
1163 /* Match a .true. or .false. Returns 1 if a .true. was found,
1164 0 if a .false. was found, and -1 otherwise. */
1166 match_logical_constant_string (void)
1168 locus orig_loc
= gfc_current_locus
;
1170 gfc_gobble_whitespace ();
1171 if (gfc_next_ascii_char () == '.')
1173 char ch
= gfc_next_ascii_char ();
1176 if (gfc_next_ascii_char () == 'a'
1177 && gfc_next_ascii_char () == 'l'
1178 && gfc_next_ascii_char () == 's'
1179 && gfc_next_ascii_char () == 'e'
1180 && gfc_next_ascii_char () == '.')
1181 /* Matched ".false.". */
1186 if (gfc_next_ascii_char () == 'r'
1187 && gfc_next_ascii_char () == 'u'
1188 && gfc_next_ascii_char () == 'e'
1189 && gfc_next_ascii_char () == '.')
1190 /* Matched ".true.". */
1194 gfc_current_locus
= orig_loc
;
1198 /* Match a .true. or .false. */
1201 match_logical_constant (gfc_expr
**result
)
1204 int i
, kind
, is_iso_c
;
1206 i
= match_logical_constant_string ();
1210 kind
= get_kind (&is_iso_c
);
1214 kind
= gfc_default_logical_kind
;
1216 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1218 gfc_error ("Bad kind for logical constant at %C");
1222 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1223 e
->ts
.is_c_interop
= is_iso_c
;
1230 /* Match a real or imaginary part of a complex constant that is a
1231 symbolic constant. */
1234 match_sym_complex_part (gfc_expr
**result
)
1236 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1241 m
= gfc_match_name (name
);
1245 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1248 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1250 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1257 if (!gfc_numeric_ts (&sym
->value
->ts
))
1259 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1263 if (sym
->value
->rank
!= 0)
1265 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1269 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1270 "complex constant at %C"))
1273 switch (sym
->value
->ts
.type
)
1276 e
= gfc_copy_expr (sym
->value
);
1280 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1286 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1292 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1295 *result
= e
; /* e is a scalar, real, constant expression. */
1299 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1304 /* Match a real or imaginary part of a complex number. */
1307 match_complex_part (gfc_expr
**result
)
1311 m
= match_sym_complex_part (result
);
1315 m
= match_real_constant (result
, 1);
1319 return match_integer_constant (result
, 1);
1323 /* Try to match a complex constant. */
1326 match_complex_constant (gfc_expr
**result
)
1328 gfc_expr
*e
, *real
, *imag
;
1329 gfc_error_buffer old_error
;
1330 gfc_typespec target
;
1335 old_loc
= gfc_current_locus
;
1336 real
= imag
= e
= NULL
;
1338 m
= gfc_match_char ('(');
1342 gfc_push_error (&old_error
);
1344 m
= match_complex_part (&real
);
1347 gfc_free_error (&old_error
);
1351 if (gfc_match_char (',') == MATCH_NO
)
1353 /* It is possible that gfc_int2real issued a warning when
1354 converting an integer to real. Throw this away here. */
1356 gfc_clear_warning ();
1357 gfc_pop_error (&old_error
);
1362 /* If m is error, then something was wrong with the real part and we
1363 assume we have a complex constant because we've seen the ','. An
1364 ambiguous case here is the start of an iterator list of some
1365 sort. These sort of lists are matched prior to coming here. */
1367 if (m
== MATCH_ERROR
)
1369 gfc_free_error (&old_error
);
1372 gfc_pop_error (&old_error
);
1374 m
= match_complex_part (&imag
);
1377 if (m
== MATCH_ERROR
)
1380 m
= gfc_match_char (')');
1383 /* Give the matcher for implied do-loops a chance to run. This
1384 yields a much saner error message for (/ (i, 4=i, 6) /). */
1385 if (gfc_peek_ascii_char () == '=')
1394 if (m
== MATCH_ERROR
)
1397 /* Decide on the kind of this complex number. */
1398 if (real
->ts
.type
== BT_REAL
)
1400 if (imag
->ts
.type
== BT_REAL
)
1401 kind
= gfc_kind_max (real
, imag
);
1403 kind
= real
->ts
.kind
;
1407 if (imag
->ts
.type
== BT_REAL
)
1408 kind
= imag
->ts
.kind
;
1410 kind
= gfc_default_real_kind
;
1412 gfc_clear_ts (&target
);
1413 target
.type
= BT_REAL
;
1416 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1417 gfc_convert_type (real
, &target
, 2);
1418 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1419 gfc_convert_type (imag
, &target
, 2);
1421 e
= gfc_convert_complex (real
, imag
, kind
);
1422 e
->where
= gfc_current_locus
;
1424 gfc_free_expr (real
);
1425 gfc_free_expr (imag
);
1431 gfc_error ("Syntax error in COMPLEX constant at %C");
1436 gfc_free_expr (real
);
1437 gfc_free_expr (imag
);
1438 gfc_current_locus
= old_loc
;
1444 /* Match constants in any of several forms. Returns nonzero for a
1445 match, zero for no match. */
1448 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1452 m
= match_complex_constant (result
);
1456 m
= match_string_constant (result
);
1460 m
= match_boz_constant (result
);
1464 m
= match_real_constant (result
, signflag
);
1468 m
= match_hollerith_constant (result
);
1472 m
= match_integer_constant (result
, signflag
);
1476 m
= match_logical_constant (result
);
1484 /* This checks if a symbol is the return value of an encompassing function.
1485 Function nesting can be maximally two levels deep, but we may have
1486 additional local namespaces like BLOCK etc. */
1489 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1491 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1495 if (ns
->proc_name
== sym
)
1503 /* Match a single actual argument value. An actual argument is
1504 usually an expression, but can also be a procedure name. If the
1505 argument is a single name, it is not always possible to tell
1506 whether the name is a dummy procedure or not. We treat these cases
1507 by creating an argument that looks like a dummy procedure and
1508 fixing things later during resolution. */
1511 match_actual_arg (gfc_expr
**result
)
1513 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1514 gfc_symtree
*symtree
;
1519 gfc_gobble_whitespace ();
1520 where
= gfc_current_locus
;
1522 switch (gfc_match_name (name
))
1531 w
= gfc_current_locus
;
1532 gfc_gobble_whitespace ();
1533 c
= gfc_next_ascii_char ();
1534 gfc_current_locus
= w
;
1536 if (c
!= ',' && c
!= ')')
1539 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1541 /* Handle error elsewhere. */
1543 /* Eliminate a couple of common cases where we know we don't
1544 have a function argument. */
1545 if (symtree
== NULL
)
1547 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1548 gfc_set_sym_referenced (symtree
->n
.sym
);
1554 sym
= symtree
->n
.sym
;
1555 gfc_set_sym_referenced (sym
);
1556 if (sym
->attr
.flavor
== FL_NAMELIST
)
1558 gfc_error ("Namelist '%s' can not be an argument at %L",
1562 if (sym
->attr
.flavor
!= FL_PROCEDURE
1563 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1566 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1568 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1569 sym
->name
, &sym
->declared_at
))
1574 /* If the symbol is a function with itself as the result and
1575 is being defined, then we have a variable. */
1576 if (sym
->attr
.function
&& sym
->result
== sym
)
1578 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1582 && (sym
->ns
== gfc_current_ns
1583 || sym
->ns
== gfc_current_ns
->parent
))
1585 gfc_entry_list
*el
= NULL
;
1587 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1597 e
= gfc_get_expr (); /* Leave it unknown for now */
1598 e
->symtree
= symtree
;
1599 e
->expr_type
= EXPR_VARIABLE
;
1600 e
->ts
.type
= BT_PROCEDURE
;
1607 gfc_current_locus
= where
;
1608 return gfc_match_expr (result
);
1612 /* Match a keyword argument. */
1615 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1617 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1618 gfc_actual_arglist
*a
;
1622 name_locus
= gfc_current_locus
;
1623 m
= gfc_match_name (name
);
1627 if (gfc_match_char ('=') != MATCH_YES
)
1633 m
= match_actual_arg (&actual
->expr
);
1637 /* Make sure this name has not appeared yet. */
1639 if (name
[0] != '\0')
1641 for (a
= base
; a
; a
= a
->next
)
1642 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1644 gfc_error ("Keyword %qs at %C has already appeared in the "
1645 "current argument list", name
);
1650 actual
->name
= gfc_get_string ("%s", name
);
1654 gfc_current_locus
= name_locus
;
1659 /* Match an argument list function, such as %VAL. */
1662 match_arg_list_function (gfc_actual_arglist
*result
)
1664 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1668 old_locus
= gfc_current_locus
;
1670 if (gfc_match_char ('%') != MATCH_YES
)
1676 m
= gfc_match ("%n (", name
);
1680 if (name
[0] != '\0')
1685 if (strncmp (name
, "loc", 3) == 0)
1687 result
->name
= "%LOC";
1692 if (strncmp (name
, "ref", 3) == 0)
1694 result
->name
= "%REF";
1699 if (strncmp (name
, "val", 3) == 0)
1701 result
->name
= "%VAL";
1711 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1717 m
= match_actual_arg (&result
->expr
);
1721 if (gfc_match_char (')') != MATCH_YES
)
1730 gfc_current_locus
= old_locus
;
1735 /* Matches an actual argument list of a function or subroutine, from
1736 the opening parenthesis to the closing parenthesis. The argument
1737 list is assumed to allow keyword arguments because we don't know if
1738 the symbol associated with the procedure has an implicit interface
1739 or not. We make sure keywords are unique. If sub_flag is set,
1740 we're matching the argument list of a subroutine. */
1743 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1745 gfc_actual_arglist
*head
, *tail
;
1747 gfc_st_label
*label
;
1751 *argp
= tail
= NULL
;
1752 old_loc
= gfc_current_locus
;
1756 if (gfc_match_char ('(') == MATCH_NO
)
1757 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1759 if (gfc_match_char (')') == MATCH_YES
)
1763 matching_actual_arglist
++;
1768 head
= tail
= gfc_get_actual_arglist ();
1771 tail
->next
= gfc_get_actual_arglist ();
1775 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1777 m
= gfc_match_st_label (&label
);
1779 gfc_error ("Expected alternate return label at %C");
1783 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1787 tail
->label
= label
;
1791 /* After the first keyword argument is seen, the following
1792 arguments must also have keywords. */
1795 m
= match_keyword_arg (tail
, head
);
1797 if (m
== MATCH_ERROR
)
1801 gfc_error ("Missing keyword name in actual argument list at %C");
1808 /* Try an argument list function, like %VAL. */
1809 m
= match_arg_list_function (tail
);
1810 if (m
== MATCH_ERROR
)
1813 /* See if we have the first keyword argument. */
1816 m
= match_keyword_arg (tail
, head
);
1819 if (m
== MATCH_ERROR
)
1825 /* Try for a non-keyword argument. */
1826 m
= match_actual_arg (&tail
->expr
);
1827 if (m
== MATCH_ERROR
)
1836 if (gfc_match_char (')') == MATCH_YES
)
1838 if (gfc_match_char (',') != MATCH_YES
)
1843 matching_actual_arglist
--;
1847 gfc_error ("Syntax error in argument list at %C");
1850 gfc_free_actual_arglist (head
);
1851 gfc_current_locus
= old_loc
;
1852 matching_actual_arglist
--;
1857 /* Used by gfc_match_varspec() to extend the reference list by one
1861 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1863 if (primary
->ref
== NULL
)
1864 primary
->ref
= tail
= gfc_get_ref ();
1868 gfc_internal_error ("extend_ref(): Bad tail");
1869 tail
->next
= gfc_get_ref ();
1877 /* Match any additional specifications associated with the current
1878 variable like member references or substrings. If equiv_flag is
1879 set we only match stuff that is allowed inside an EQUIVALENCE
1880 statement. sub_flag tells whether we expect a type-bound procedure found
1881 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1882 components, 'ppc_arg' determines whether the PPC may be called (with an
1883 argument list), or whether it may just be referred to as a pointer. */
1886 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1889 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1890 gfc_ref
*substring
, *tail
, *tmp
;
1891 gfc_component
*component
;
1892 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1899 gfc_gobble_whitespace ();
1901 if (gfc_peek_ascii_char () == '[')
1903 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1904 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1905 && CLASS_DATA (sym
)->attr
.dimension
))
1907 gfc_error ("Array section designator, e.g. '(:)', is required "
1908 "besides the coarray designator '[...]' at %C");
1911 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1912 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1913 && !CLASS_DATA (sym
)->attr
.codimension
))
1915 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1921 /* For associate names, we may not yet know whether they are arrays or not.
1922 If the selector expression is unambiguously an array; eg. a full array
1923 or an array section, then the associate name must be an array and we can
1924 fix it now. Otherwise, if parentheses follow and it is not a character
1925 type, we have to assume that it actually is one for now. The final
1926 decision will be made at resolution, of course. */
1928 && gfc_peek_ascii_char () == '('
1929 && sym
->ts
.type
!= BT_CLASS
1930 && !sym
->attr
.dimension
)
1932 if ((!sym
->assoc
->dangling
1933 && sym
->assoc
->target
1934 && sym
->assoc
->target
->ref
1935 && sym
->assoc
->target
->ref
->type
== REF_ARRAY
1936 && (sym
->assoc
->target
->ref
->u
.ar
.type
== AR_FULL
1937 || sym
->assoc
->target
->ref
->u
.ar
.type
== AR_SECTION
))
1939 (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
1941 && sym
->assoc
->st
->n
.sym
1942 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
1944 sym
->attr
.dimension
= 1;
1945 if (sym
->as
== NULL
&& sym
->assoc
1947 && sym
->assoc
->st
->n
.sym
1948 && sym
->assoc
->st
->n
.sym
->as
)
1949 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
1953 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1954 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1955 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1956 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1957 && !(gfc_matching_procptr_assignment
1958 && sym
->attr
.flavor
== FL_PROCEDURE
))
1959 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1960 && (CLASS_DATA (sym
)->attr
.dimension
1961 || CLASS_DATA (sym
)->attr
.codimension
)))
1965 tail
= extend_ref (primary
, tail
);
1966 tail
->type
= REF_ARRAY
;
1968 /* In EQUIVALENCE, we don't know yet whether we are seeing
1969 an array, character variable or array of character
1970 variables. We'll leave the decision till resolve time. */
1974 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1975 as
= CLASS_DATA (sym
)->as
;
1979 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1980 as
? as
->corank
: 0);
1984 gfc_gobble_whitespace ();
1985 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1987 tail
= extend_ref (primary
, tail
);
1988 tail
->type
= REF_ARRAY
;
1990 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1996 primary
->ts
= sym
->ts
;
2001 /* With DEC extensions, member separator may be '.' or '%'. */
2002 sep
= gfc_peek_ascii_char ();
2003 m
= gfc_match_member_sep (sym
);
2004 if (m
== MATCH_ERROR
)
2007 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2008 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2009 gfc_set_default_type (sym
, 0, sym
->ns
);
2011 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2013 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2016 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2019 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2024 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2026 goto check_substring
;
2028 sym
= sym
->ts
.u
.derived
;
2035 m
= gfc_match_name (name
);
2037 gfc_error ("Expected structure component name at %C");
2041 if (sym
&& sym
->f2k_derived
)
2042 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2048 gfc_symbol
* tbp_sym
;
2053 gcc_assert (!tail
|| !tail
->next
);
2055 if (!(primary
->expr_type
== EXPR_VARIABLE
2056 || (primary
->expr_type
== EXPR_STRUCTURE
2057 && primary
->symtree
&& primary
->symtree
->n
.sym
2058 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2061 if (tbp
->n
.tb
->is_generic
)
2064 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2066 primary
->expr_type
= EXPR_COMPCALL
;
2067 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2068 primary
->value
.compcall
.name
= tbp
->name
;
2069 primary
->value
.compcall
.ignore_pass
= 0;
2070 primary
->value
.compcall
.assign
= 0;
2071 primary
->value
.compcall
.base_object
= NULL
;
2072 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2074 primary
->ts
= tbp_sym
->ts
;
2076 gfc_clear_ts (&primary
->ts
);
2078 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2079 &primary
->value
.compcall
.actual
);
2080 if (m
== MATCH_ERROR
)
2085 primary
->value
.compcall
.actual
= NULL
;
2088 gfc_error ("Expected argument list at %C");
2096 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2097 if (component
== NULL
)
2100 /* Extend the reference chain determined by gfc_find_component. */
2101 if (primary
->ref
== NULL
)
2105 /* Set by the for loop below for the last component ref. */
2106 gcc_assert (tail
!= NULL
);
2110 /* The reference chain may be longer than one hop for union
2111 subcomponents; find the new tail. */
2112 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2115 primary
->ts
= component
->ts
;
2117 if (component
->attr
.proc_pointer
&& ppc_arg
)
2119 /* Procedure pointer component call: Look for argument list. */
2120 m
= gfc_match_actual_arglist (sub_flag
,
2121 &primary
->value
.compcall
.actual
);
2122 if (m
== MATCH_ERROR
)
2125 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2126 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2128 gfc_error ("Procedure pointer component %qs requires an "
2129 "argument list at %C", component
->name
);
2134 primary
->expr_type
= EXPR_PPC
;
2139 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2141 tail
= extend_ref (primary
, tail
);
2142 tail
->type
= REF_ARRAY
;
2144 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2145 component
->as
->corank
);
2149 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2150 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2152 tail
= extend_ref (primary
, tail
);
2153 tail
->type
= REF_ARRAY
;
2155 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2157 CLASS_DATA (component
)->as
->corank
);
2162 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2163 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2166 sym
= component
->ts
.u
.derived
;
2171 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2173 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2175 gfc_set_default_type (sym
, 0, sym
->ns
);
2176 primary
->ts
= sym
->ts
;
2181 if (primary
->ts
.type
== BT_CHARACTER
)
2183 bool def
= primary
->ts
.deferred
== 1;
2184 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2188 primary
->ref
= substring
;
2190 tail
->next
= substring
;
2192 if (primary
->expr_type
== EXPR_CONSTANT
)
2193 primary
->expr_type
= EXPR_SUBSTRING
;
2196 primary
->ts
.u
.cl
= NULL
;
2203 gfc_clear_ts (&primary
->ts
);
2204 gfc_clear_ts (&sym
->ts
);
2214 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2215 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2217 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2222 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2224 gfc_error ("Coindexed procedure-pointer component at %C");
2232 /* Given an expression that is a variable, figure out what the
2233 ultimate variable's type and attribute is, traversing the reference
2234 structures if necessary.
2236 This subroutine is trickier than it looks. We start at the base
2237 symbol and store the attribute. Component references load a
2238 completely new attribute.
2240 A couple of rules come into play. Subobjects of targets are always
2241 targets themselves. If we see a component that goes through a
2242 pointer, then the expression must also be a target, since the
2243 pointer is associated with something (if it isn't core will soon be
2244 dumped). If we see a full part or section of an array, the
2245 expression is also an array.
2247 We can have at most one full array reference. */
2250 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2252 int dimension
, codimension
, pointer
, allocatable
, target
;
2253 symbol_attribute attr
;
2256 gfc_component
*comp
;
2258 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2259 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2261 sym
= expr
->symtree
->n
.sym
;
2264 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2266 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2267 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2268 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2269 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2273 dimension
= attr
.dimension
;
2274 codimension
= attr
.codimension
;
2275 pointer
= attr
.pointer
;
2276 allocatable
= attr
.allocatable
;
2279 target
= attr
.target
;
2280 if (pointer
|| attr
.proc_pointer
)
2283 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2286 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2291 switch (ref
->u
.ar
.type
)
2298 allocatable
= pointer
= 0;
2303 /* Handle coarrays. */
2304 if (ref
->u
.ar
.dimen
> 0)
2305 allocatable
= pointer
= 0;
2309 /* If any of start, end or stride is not integer, there will
2310 already have been an error issued. */
2312 gfc_get_errors (NULL
, &errors
);
2314 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2320 comp
= ref
->u
.c
.component
;
2325 /* Don't set the string length if a substring reference
2327 if (ts
->type
== BT_CHARACTER
2328 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2332 if (comp
->ts
.type
== BT_CLASS
)
2334 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2335 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2336 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2340 codimension
= comp
->attr
.codimension
;
2341 pointer
= comp
->attr
.pointer
;
2342 allocatable
= comp
->attr
.allocatable
;
2344 if (pointer
|| attr
.proc_pointer
)
2350 allocatable
= pointer
= 0;
2354 attr
.dimension
= dimension
;
2355 attr
.codimension
= codimension
;
2356 attr
.pointer
= pointer
;
2357 attr
.allocatable
= allocatable
;
2358 attr
.target
= target
;
2359 attr
.save
= sym
->attr
.save
;
2365 /* Return the attribute from a general expression. */
2368 gfc_expr_attr (gfc_expr
*e
)
2370 symbol_attribute attr
;
2372 switch (e
->expr_type
)
2375 attr
= gfc_variable_attr (e
, NULL
);
2379 gfc_clear_attr (&attr
);
2381 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2383 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2385 if (sym
->ts
.type
== BT_CLASS
)
2387 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2388 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2389 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2392 else if (e
->value
.function
.isym
2393 && e
->value
.function
.isym
->transformational
2394 && e
->ts
.type
== BT_CLASS
)
2395 attr
= CLASS_DATA (e
)->attr
;
2397 attr
= gfc_variable_attr (e
, NULL
);
2399 /* TODO: NULL() returns pointers. May have to take care of this
2405 gfc_clear_attr (&attr
);
2413 /* Given an expression, figure out what the ultimate expression
2414 attribute is. This routine is similar to gfc_variable_attr with
2415 parts of gfc_expr_attr, but focuses more on the needs of
2416 coarrays. For coarrays a codimension attribute is kind of
2417 "infectious" being propagated once set and never cleared.
2418 The coarray_comp is only set, when the expression refs a coarray
2419 component. REFS_COMP is set when present to true only, when this EXPR
2420 refs a (non-_data) component. To check whether EXPR refs an allocatable
2421 component in a derived type coarray *refs_comp needs to be set and
2422 coarray_comp has to false. */
2424 static symbol_attribute
2425 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2427 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2428 symbol_attribute attr
;
2431 gfc_component
*comp
;
2433 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2434 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2436 sym
= expr
->symtree
->n
.sym
;
2437 gfc_clear_attr (&attr
);
2442 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2444 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2445 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2446 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2447 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2448 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2449 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2453 dimension
= sym
->attr
.dimension
;
2454 codimension
= sym
->attr
.codimension
;
2455 pointer
= sym
->attr
.pointer
;
2456 allocatable
= sym
->attr
.allocatable
;
2457 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2458 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2459 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2460 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2463 target
= coarray_comp
= 0;
2464 if (pointer
|| attr
.proc_pointer
)
2467 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2472 switch (ref
->u
.ar
.type
)
2480 /* Handle coarrays. */
2481 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2482 allocatable
= pointer
= 0;
2486 /* If any of start, end or stride is not integer, there will
2487 already have been an error issued. */
2489 gfc_get_errors (NULL
, &errors
);
2491 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2497 comp
= ref
->u
.c
.component
;
2499 if (comp
->ts
.type
== BT_CLASS
)
2501 /* Set coarray_comp only, when this component introduces the
2503 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2504 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2505 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2506 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2510 /* Set coarray_comp only, when this component introduces the
2512 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2513 codimension
|= comp
->attr
.codimension
;
2514 pointer
= comp
->attr
.pointer
;
2515 allocatable
= comp
->attr
.allocatable
;
2518 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2519 && (ref
->next
== NULL
2520 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2523 if (pointer
|| attr
.proc_pointer
)
2529 allocatable
= pointer
= 0;
2533 attr
.dimension
= dimension
;
2534 attr
.codimension
= codimension
;
2535 attr
.pointer
= pointer
;
2536 attr
.allocatable
= allocatable
;
2537 attr
.target
= target
;
2538 attr
.save
= sym
->attr
.save
;
2539 attr
.coarray_comp
= coarray_comp
;
2546 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2548 symbol_attribute attr
;
2550 switch (e
->expr_type
)
2553 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2557 gfc_clear_attr (&attr
);
2559 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2561 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2563 if (sym
->ts
.type
== BT_CLASS
)
2565 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2566 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2567 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2568 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2569 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2570 ->attr
.pointer_comp
;
2573 else if (e
->symtree
)
2574 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2576 gfc_clear_attr (&attr
);
2580 gfc_clear_attr (&attr
);
2588 /* Match a structure constructor. The initial symbol has already been
2591 typedef struct gfc_structure_ctor_component
2596 struct gfc_structure_ctor_component
* next
;
2598 gfc_structure_ctor_component
;
2600 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2603 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2606 gfc_free_expr (comp
->val
);
2611 /* Translate the component list into the actual constructor by sorting it in
2612 the order required; this also checks along the way that each and every
2613 component actually has an initializer and handles default initializers
2614 for components without explicit value given. */
2616 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2617 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2619 gfc_structure_ctor_component
*comp_iter
;
2620 gfc_component
*comp
;
2622 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2624 gfc_structure_ctor_component
**next_ptr
;
2625 gfc_expr
*value
= NULL
;
2627 /* Try to find the initializer for the current component by name. */
2628 next_ptr
= comp_head
;
2629 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2631 if (!strcmp (comp_iter
->name
, comp
->name
))
2633 next_ptr
= &comp_iter
->next
;
2636 /* If an extension, try building the parent derived type by building
2637 a value expression for the parent derived type and calling self. */
2638 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2640 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2642 &gfc_current_locus
);
2643 value
->ts
= comp
->ts
;
2645 if (!build_actual_constructor (comp_head
,
2646 &value
->value
.constructor
,
2647 comp
->ts
.u
.derived
))
2649 gfc_free_expr (value
);
2653 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2657 /* If it was not found, try the default initializer if there's any;
2658 otherwise, it's an error unless this is a deferred parameter. */
2661 if (comp
->initializer
)
2663 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2664 "with missing optional arguments at %C"))
2666 value
= gfc_copy_expr (comp
->initializer
);
2668 else if (comp
->attr
.allocatable
2669 || (comp
->ts
.type
== BT_CLASS
2670 && CLASS_DATA (comp
)->attr
.allocatable
))
2672 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2673 "allocatable component '%qs' given in the "
2674 "structure constructor at %C", comp
->name
))
2677 else if (!comp
->attr
.artificial
)
2679 gfc_error ("No initializer for component %qs given in the"
2680 " structure constructor at %C!", comp
->name
);
2685 value
= comp_iter
->val
;
2687 /* Add the value to the constructor chain built. */
2688 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2690 /* Remove the entry from the component list. We don't want the expression
2691 value to be free'd, so set it to NULL. */
2694 *next_ptr
= comp_iter
->next
;
2695 comp_iter
->val
= NULL
;
2696 gfc_free_structure_ctor_component (comp_iter
);
2704 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2705 gfc_actual_arglist
**arglist
,
2708 gfc_actual_arglist
*actual
;
2709 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2710 gfc_constructor_base ctor_head
= NULL
;
2711 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2712 const char* last_name
= NULL
;
2716 expr
= parent
? *cexpr
: e
;
2717 old_locus
= gfc_current_locus
;
2719 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2721 gfc_current_locus
= expr
->where
;
2723 comp_tail
= comp_head
= NULL
;
2725 if (!parent
&& sym
->attr
.abstract
)
2727 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2728 sym
->name
, &expr
->where
);
2732 comp
= sym
->components
;
2733 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2736 gfc_component
*this_comp
= NULL
;
2739 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2742 comp_tail
->next
= gfc_get_structure_ctor_component ();
2743 comp_tail
= comp_tail
->next
;
2747 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2748 " constructor with named arguments at %C"))
2751 comp_tail
->name
= xstrdup (actual
->name
);
2752 last_name
= comp_tail
->name
;
2757 /* Components without name are not allowed after the first named
2758 component initializer! */
2759 if (!comp
|| comp
->attr
.artificial
)
2762 gfc_error ("Component initializer without name after component"
2763 " named %s at %L!", last_name
,
2764 actual
->expr
? &actual
->expr
->where
2765 : &gfc_current_locus
);
2767 gfc_error ("Too many components in structure constructor at "
2768 "%L!", actual
->expr
? &actual
->expr
->where
2769 : &gfc_current_locus
);
2773 comp_tail
->name
= xstrdup (comp
->name
);
2776 /* Find the current component in the structure definition and check
2777 its access is not private. */
2779 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
2782 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2783 false, false, NULL
);
2784 comp
= NULL
; /* Reset needed! */
2787 /* Here we can check if a component name is given which does not
2788 correspond to any component of the defined structure. */
2792 comp_tail
->val
= actual
->expr
;
2793 if (actual
->expr
!= NULL
)
2794 comp_tail
->where
= actual
->expr
->where
;
2795 actual
->expr
= NULL
;
2797 /* Check if this component is already given a value. */
2798 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2799 comp_iter
= comp_iter
->next
)
2801 gcc_assert (comp_iter
);
2802 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2804 gfc_error ("Component %qs is initialized twice in the structure"
2805 " constructor at %L!", comp_tail
->name
,
2806 comp_tail
->val
? &comp_tail
->where
2807 : &gfc_current_locus
);
2812 /* F2008, R457/C725, for PURE C1283. */
2813 if (this_comp
->attr
.pointer
&& comp_tail
->val
2814 && gfc_is_coindexed (comp_tail
->val
))
2816 gfc_error ("Coindexed expression to pointer component %qs in "
2817 "structure constructor at %L!", comp_tail
->name
,
2822 /* If not explicitly a parent constructor, gather up the components
2824 if (comp
&& comp
== sym
->components
2825 && sym
->attr
.extension
2827 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
2829 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2832 gfc_actual_arglist
*arg_null
= NULL
;
2834 actual
->expr
= comp_tail
->val
;
2835 comp_tail
->val
= NULL
;
2837 m
= gfc_convert_to_structure_constructor (NULL
,
2838 comp
->ts
.u
.derived
, &comp_tail
->val
,
2839 comp
->ts
.u
.derived
->attr
.zero_comp
2840 ? &arg_null
: &actual
, true);
2844 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2853 if (parent
&& !comp
)
2857 actual
= actual
->next
;
2860 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2863 /* No component should be left, as this should have caused an error in the
2864 loop constructing the component-list (name that does not correspond to any
2865 component in the structure definition). */
2866 if (comp_head
&& sym
->attr
.extension
)
2868 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2870 gfc_error ("component %qs at %L has already been set by a "
2871 "parent derived type constructor", comp_iter
->name
,
2877 gcc_assert (!comp_head
);
2881 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2882 expr
->ts
.u
.derived
= sym
;
2883 expr
->value
.constructor
= ctor_head
;
2888 expr
->ts
.u
.derived
= sym
;
2890 expr
->ts
.type
= BT_DERIVED
;
2891 expr
->value
.constructor
= ctor_head
;
2892 expr
->expr_type
= EXPR_STRUCTURE
;
2895 gfc_current_locus
= old_locus
;
2901 gfc_current_locus
= old_locus
;
2903 for (comp_iter
= comp_head
; comp_iter
; )
2905 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2906 gfc_free_structure_ctor_component (comp_iter
);
2909 gfc_constructor_free (ctor_head
);
2916 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2920 gfc_symtree
*symtree
;
2922 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
2924 e
= gfc_get_expr ();
2925 e
->symtree
= symtree
;
2926 e
->expr_type
= EXPR_FUNCTION
;
2928 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
2929 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2930 e
->value
.function
.esym
= sym
;
2931 e
->symtree
->n
.sym
->attr
.generic
= 1;
2933 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2940 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
2946 /* If a structure constructor is in a DATA statement, then each entity
2947 in the structure constructor must be a constant. Try to reduce the
2949 if (gfc_in_match_data ())
2950 gfc_reduce_init_expr (e
);
2957 /* If the symbol is an implicit do loop index and implicitly typed,
2958 it should not be host associated. Provide a symtree from the
2959 current namespace. */
2961 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2963 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2964 && (*sym
)->ns
!= gfc_current_ns
2965 && (*sym
)->attr
.implied_index
2966 && (*sym
)->attr
.implicit_type
2967 && !(*sym
)->attr
.use_assoc
)
2970 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2973 *sym
= (*st
)->n
.sym
;
2979 /* Procedure pointer as function result: Replace the function symbol by the
2980 auto-generated hidden result variable named "ppr@". */
2983 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2985 /* Check for procedure pointer result variable. */
2986 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2987 && (*sym
)->result
&& (*sym
)->result
!= *sym
2988 && (*sym
)->result
->attr
.proc_pointer
2989 && (*sym
) == gfc_current_ns
->proc_name
2990 && (*sym
) == (*sym
)->result
->ns
->proc_name
2991 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2993 /* Automatic replacement with "hidden" result variable. */
2994 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2995 *sym
= (*sym
)->result
;
2996 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3003 /* Matches a variable name followed by anything that might follow it--
3004 array reference, argument list of a function, etc. */
3007 gfc_match_rvalue (gfc_expr
**result
)
3009 gfc_actual_arglist
*actual_arglist
;
3010 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3013 gfc_symtree
*symtree
;
3014 locus where
, old_loc
;
3022 m
= gfc_match ("%%loc");
3025 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3027 strncpy (name
, "loc", 4);
3032 m
= gfc_match_name (name
);
3037 /* Check if the symbol exists. */
3038 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3041 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3042 type. For derived types we create a generic symbol which links to the
3043 derived type symbol; STRUCTUREs are simpler and must not conflict with
3046 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3048 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3050 if (gfc_find_state (COMP_INTERFACE
)
3051 && !gfc_current_ns
->has_import_set
)
3052 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3054 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3060 sym
= symtree
->n
.sym
;
3062 where
= gfc_current_locus
;
3064 replace_hidden_procptr_result (&sym
, &symtree
);
3066 /* If this is an implicit do loop index and implicitly typed,
3067 it should not be host associated. */
3068 m
= check_for_implicit_index (&symtree
, &sym
);
3072 gfc_set_sym_referenced (sym
);
3073 sym
->attr
.implied_index
= 0;
3075 if (sym
->attr
.function
&& sym
->result
== sym
)
3077 /* See if this is a directly recursive function call. */
3078 gfc_gobble_whitespace ();
3079 if (sym
->attr
.recursive
3080 && gfc_peek_ascii_char () == '('
3081 && gfc_current_ns
->proc_name
== sym
3082 && !sym
->attr
.dimension
)
3084 gfc_error ("%qs at %C is the name of a recursive function "
3085 "and so refers to the result variable. Use an "
3086 "explicit RESULT variable for direct recursion "
3087 "(12.5.2.1)", sym
->name
);
3091 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3095 && (sym
->ns
== gfc_current_ns
3096 || sym
->ns
== gfc_current_ns
->parent
))
3098 gfc_entry_list
*el
= NULL
;
3100 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3106 if (gfc_matching_procptr_assignment
)
3109 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3112 if (sym
->attr
.generic
)
3113 goto generic_function
;
3115 switch (sym
->attr
.flavor
)
3119 e
= gfc_get_expr ();
3121 e
->expr_type
= EXPR_VARIABLE
;
3122 e
->symtree
= symtree
;
3124 m
= gfc_match_varspec (e
, 0, false, true);
3128 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3129 end up here. Unfortunately, sym->value->expr_type is set to
3130 EXPR_CONSTANT, and so the if () branch would be followed without
3131 the !sym->as check. */
3132 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3133 e
= gfc_copy_expr (sym
->value
);
3136 e
= gfc_get_expr ();
3137 e
->expr_type
= EXPR_VARIABLE
;
3140 e
->symtree
= symtree
;
3141 m
= gfc_match_varspec (e
, 0, false, true);
3143 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3146 /* Variable array references to derived type parameters cause
3147 all sorts of headaches in simplification. Treating such
3148 expressions as variable works just fine for all array
3150 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3152 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3153 if (ref
->type
== REF_ARRAY
)
3156 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3162 e
= gfc_get_expr ();
3163 e
->expr_type
= EXPR_VARIABLE
;
3164 e
->symtree
= symtree
;
3172 sym
= gfc_use_derived (sym
);
3176 goto generic_function
;
3179 /* If we're here, then the name is known to be the name of a
3180 procedure, yet it is not sure to be the name of a function. */
3183 /* Procedure Pointer Assignments. */
3185 if (gfc_matching_procptr_assignment
)
3187 gfc_gobble_whitespace ();
3188 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3189 /* Parse functions returning a procptr. */
3192 e
= gfc_get_expr ();
3193 e
->expr_type
= EXPR_VARIABLE
;
3194 e
->symtree
= symtree
;
3195 m
= gfc_match_varspec (e
, 0, false, true);
3196 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3197 && sym
->ts
.type
== BT_UNKNOWN
3198 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3206 if (sym
->attr
.subroutine
)
3208 gfc_error ("Unexpected use of subroutine name %qs at %C",
3214 /* At this point, the name has to be a non-statement function.
3215 If the name is the same as the current function being
3216 compiled, then we have a variable reference (to the function
3217 result) if the name is non-recursive. */
3219 st
= gfc_enclosing_unit (NULL
);
3222 && st
->state
== COMP_FUNCTION
3224 && !sym
->attr
.recursive
)
3226 e
= gfc_get_expr ();
3227 e
->symtree
= symtree
;
3228 e
->expr_type
= EXPR_VARIABLE
;
3230 m
= gfc_match_varspec (e
, 0, false, true);
3234 /* Match a function reference. */
3236 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3239 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3240 gfc_error ("Statement function %qs requires argument list at %C",
3243 gfc_error ("Function %qs requires an argument list at %C",
3256 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3257 sym
= symtree
->n
.sym
;
3259 replace_hidden_procptr_result (&sym
, &symtree
);
3261 e
= gfc_get_expr ();
3262 e
->symtree
= symtree
;
3263 e
->expr_type
= EXPR_FUNCTION
;
3264 e
->value
.function
.actual
= actual_arglist
;
3265 e
->where
= gfc_current_locus
;
3267 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3268 && CLASS_DATA (sym
)->as
)
3269 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3270 else if (sym
->as
!= NULL
)
3271 e
->rank
= sym
->as
->rank
;
3273 if (!sym
->attr
.function
3274 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3280 /* Check here for the existence of at least one argument for the
3281 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3282 argument(s) given will be checked in gfc_iso_c_func_interface,
3283 during resolution of the function call. */
3284 if (sym
->attr
.is_iso_c
== 1
3285 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3286 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3287 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3288 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3290 /* make sure we were given a param */
3291 if (actual_arglist
== NULL
)
3293 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3299 if (sym
->result
== NULL
)
3302 gfc_gobble_whitespace ();
3304 if (gfc_peek_ascii_char() == '%')
3306 gfc_error ("The leftmost part-ref in a data-ref can not be a "
3307 "function reference at %C");
3316 /* Special case for derived type variables that get their types
3317 via an IMPLICIT statement. This can't wait for the
3318 resolution phase. */
3320 old_loc
= gfc_current_locus
;
3321 if (gfc_match_member_sep (sym
) == MATCH_YES
3322 && sym
->ts
.type
== BT_UNKNOWN
3323 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3324 gfc_set_default_type (sym
, 0, sym
->ns
);
3325 gfc_current_locus
= old_loc
;
3327 /* If the symbol has a (co)dimension attribute, the expression is a
3330 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3332 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3338 e
= gfc_get_expr ();
3339 e
->symtree
= symtree
;
3340 e
->expr_type
= EXPR_VARIABLE
;
3341 m
= gfc_match_varspec (e
, 0, false, true);
3345 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3346 && (CLASS_DATA (sym
)->attr
.dimension
3347 || CLASS_DATA (sym
)->attr
.codimension
))
3349 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3355 e
= gfc_get_expr ();
3356 e
->symtree
= symtree
;
3357 e
->expr_type
= EXPR_VARIABLE
;
3358 m
= gfc_match_varspec (e
, 0, false, true);
3362 /* Name is not an array, so we peek to see if a '(' implies a
3363 function call or a substring reference. Otherwise the
3364 variable is just a scalar. */
3366 gfc_gobble_whitespace ();
3367 if (gfc_peek_ascii_char () != '(')
3369 /* Assume a scalar variable */
3370 e
= gfc_get_expr ();
3371 e
->symtree
= symtree
;
3372 e
->expr_type
= EXPR_VARIABLE
;
3374 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3380 /*FIXME:??? gfc_match_varspec does set this for us: */
3382 m
= gfc_match_varspec (e
, 0, false, true);
3386 /* See if this is a function reference with a keyword argument
3387 as first argument. We do this because otherwise a spurious
3388 symbol would end up in the symbol table. */
3390 old_loc
= gfc_current_locus
;
3391 m2
= gfc_match (" ( %n =", argname
);
3392 gfc_current_locus
= old_loc
;
3394 e
= gfc_get_expr ();
3395 e
->symtree
= symtree
;
3397 if (m2
!= MATCH_YES
)
3399 /* Try to figure out whether we're dealing with a character type.
3400 We're peeking ahead here, because we don't want to call
3401 match_substring if we're dealing with an implicitly typed
3402 non-character variable. */
3403 implicit_char
= false;
3404 if (sym
->ts
.type
== BT_UNKNOWN
)
3406 ts
= gfc_get_default_type (sym
->name
, NULL
);
3407 if (ts
->type
== BT_CHARACTER
)
3408 implicit_char
= true;
3411 /* See if this could possibly be a substring reference of a name
3412 that we're not sure is a variable yet. */
3414 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3415 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3418 e
->expr_type
= EXPR_VARIABLE
;
3420 if (sym
->attr
.flavor
!= FL_VARIABLE
3421 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3428 if (sym
->ts
.type
== BT_UNKNOWN
3429 && !gfc_set_default_type (sym
, 1, NULL
))
3443 /* Give up, assume we have a function. */
3445 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3446 sym
= symtree
->n
.sym
;
3447 e
->expr_type
= EXPR_FUNCTION
;
3449 if (!sym
->attr
.function
3450 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3458 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3460 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3468 /* If our new function returns a character, array or structure
3469 type, it might have subsequent references. */
3471 m
= gfc_match_varspec (e
, 0, false, true);
3478 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3479 specially. Creates a generic symbol for derived types. */
3480 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3482 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3483 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3484 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3486 e
= gfc_get_expr ();
3487 e
->symtree
= symtree
;
3488 e
->expr_type
= EXPR_FUNCTION
;
3490 if (gfc_fl_struct (sym
->attr
.flavor
))
3492 e
->value
.function
.esym
= sym
;
3493 e
->symtree
->n
.sym
->attr
.generic
= 1;
3496 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3504 gfc_error ("Symbol at %C is not appropriate for an expression");
3520 /* Match a variable, i.e. something that can be assigned to. This
3521 starts as a symbol, can be a structure component or an array
3522 reference. It can be a function if the function doesn't have a
3523 separate RESULT variable. If the symbol has not been previously
3524 seen, we assume it is a variable.
3526 This function is called by two interface functions:
3527 gfc_match_variable, which has host_flag = 1, and
3528 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3529 match of the symbol to the local scope. */
3532 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3534 gfc_symbol
*sym
, *dt_sym
;
3537 locus where
, old_loc
;
3540 /* Since nothing has any business being an lvalue in a module
3541 specification block, an interface block or a contains section,
3542 we force the changed_symbols mechanism to work by setting
3543 host_flag to 0. This prevents valid symbols that have the name
3544 of keywords, such as 'end', being turned into variables by
3545 failed matching to assignments for, e.g., END INTERFACE. */
3546 if (gfc_current_state () == COMP_MODULE
3547 || gfc_current_state () == COMP_SUBMODULE
3548 || gfc_current_state () == COMP_INTERFACE
3549 || gfc_current_state () == COMP_CONTAINS
)
3552 where
= gfc_current_locus
;
3553 m
= gfc_match_sym_tree (&st
, host_flag
);
3559 /* If this is an implicit do loop index and implicitly typed,
3560 it should not be host associated. */
3561 m
= check_for_implicit_index (&st
, &sym
);
3565 sym
->attr
.implied_index
= 0;
3567 gfc_set_sym_referenced (sym
);
3569 /* STRUCTUREs may share names with variables, but derived types may not. */
3570 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3571 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3573 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3574 gfc_error ("Derived type '%s' cannot be used as a variable at %C",
3579 switch (sym
->attr
.flavor
)
3582 /* Everything is alright. */
3587 sym_flavor flavor
= FL_UNKNOWN
;
3589 gfc_gobble_whitespace ();
3591 if (sym
->attr
.external
|| sym
->attr
.procedure
3592 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3593 flavor
= FL_PROCEDURE
;
3595 /* If it is not a procedure, is not typed and is host associated,
3596 we cannot give it a flavor yet. */
3597 else if (sym
->ns
== gfc_current_ns
->parent
3598 && sym
->ts
.type
== BT_UNKNOWN
)
3601 /* These are definitive indicators that this is a variable. */
3602 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3603 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3604 flavor
= FL_VARIABLE
;
3606 if (flavor
!= FL_UNKNOWN
3607 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3615 gfc_error ("Named constant at %C in an EQUIVALENCE");
3618 /* Otherwise this is checked for and an error given in the
3619 variable definition context checks. */
3623 /* Check for a nonrecursive function result variable. */
3624 if (sym
->attr
.function
3625 && !sym
->attr
.external
3626 && sym
->result
== sym
3627 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3629 && sym
->ns
== gfc_current_ns
)
3631 && sym
->ns
== gfc_current_ns
->parent
)))
3633 /* If a function result is a derived type, then the derived
3634 type may still have to be resolved. */
3636 if (sym
->ts
.type
== BT_DERIVED
3637 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3642 if (sym
->attr
.proc_pointer
3643 || replace_hidden_procptr_result (&sym
, &st
))
3646 /* Fall through to error */
3650 gfc_error ("%qs at %C is not a variable", sym
->name
);
3654 /* Special case for derived type variables that get their types
3655 via an IMPLICIT statement. This can't wait for the
3656 resolution phase. */
3659 gfc_namespace
* implicit_ns
;
3661 if (gfc_current_ns
->proc_name
== sym
)
3662 implicit_ns
= gfc_current_ns
;
3664 implicit_ns
= sym
->ns
;
3666 old_loc
= gfc_current_locus
;
3667 if (gfc_match_member_sep (sym
) == MATCH_YES
3668 && sym
->ts
.type
== BT_UNKNOWN
3669 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3670 gfc_set_default_type (sym
, 0, implicit_ns
);
3671 gfc_current_locus
= old_loc
;
3674 expr
= gfc_get_expr ();
3676 expr
->expr_type
= EXPR_VARIABLE
;
3679 expr
->where
= where
;
3681 /* Now see if we have to do more. */
3682 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3685 gfc_free_expr (expr
);
3695 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3697 return match_variable (result
, equiv_flag
, 1);
3702 gfc_match_equiv_variable (gfc_expr
**result
)
3704 return match_variable (result
, 1, 0);