1 /* Primary expression subroutines
2 Copyright (C) 2000-2018 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_charlen_int_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
;
1010 int kind
,save_warn_ampersand
, ret
;
1011 locus old_locus
, start_locus
;
1015 gfc_char_t c
, delimiter
, *p
;
1017 old_locus
= gfc_current_locus
;
1019 gfc_gobble_whitespace ();
1021 c
= gfc_next_char ();
1022 if (c
== '\'' || c
== '"')
1024 kind
= gfc_default_character_kind
;
1025 start_locus
= gfc_current_locus
;
1029 if (gfc_wide_is_digit (c
))
1033 while (gfc_wide_is_digit (c
))
1035 kind
= kind
* 10 + c
- '0';
1038 c
= gfc_next_char ();
1044 gfc_current_locus
= old_locus
;
1046 m
= match_charkind_name (name
);
1050 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1052 || sym
->attr
.flavor
!= FL_PARAMETER
)
1056 c
= gfc_next_char ();
1061 gfc_gobble_whitespace ();
1062 c
= gfc_next_char ();
1068 gfc_gobble_whitespace ();
1070 c
= gfc_next_char ();
1071 if (c
!= '\'' && c
!= '"')
1074 start_locus
= gfc_current_locus
;
1078 if (gfc_extract_int (sym
->value
, &kind
, 1))
1080 gfc_set_sym_referenced (sym
);
1083 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1085 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1090 /* Scan the string into a block of memory by first figuring out how
1091 long it is, allocating the structure, then re-reading it. This
1092 isn't particularly efficient, but string constants aren't that
1093 common in most code. TODO: Use obstacks? */
1100 c
= next_string_char (delimiter
, &ret
);
1105 gfc_current_locus
= start_locus
;
1106 gfc_error ("Unterminated character constant beginning at %C");
1113 /* Peek at the next character to see if it is a b, o, z, or x for the
1114 postfixed BOZ literal constants. */
1115 peek
= gfc_peek_ascii_char ();
1116 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1119 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1121 gfc_current_locus
= start_locus
;
1123 /* We disable the warning for the following loop as the warning has already
1124 been printed in the loop above. */
1125 save_warn_ampersand
= warn_ampersand
;
1126 warn_ampersand
= false;
1128 p
= e
->value
.character
.string
;
1129 for (size_t i
= 0; i
< length
; i
++)
1131 c
= next_string_char (delimiter
, &ret
);
1133 if (!gfc_check_character_range (c
, kind
))
1136 gfc_error ("Character %qs in string at %C is not representable "
1137 "in character kind %d", gfc_print_wide_char (c
), kind
);
1144 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1145 warn_ampersand
= save_warn_ampersand
;
1147 next_string_char (delimiter
, &ret
);
1149 gfc_internal_error ("match_string_constant(): Delimiter not found");
1151 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1152 e
->expr_type
= EXPR_SUBSTRING
;
1159 gfc_current_locus
= old_locus
;
1164 /* Match a .true. or .false. Returns 1 if a .true. was found,
1165 0 if a .false. was found, and -1 otherwise. */
1167 match_logical_constant_string (void)
1169 locus orig_loc
= gfc_current_locus
;
1171 gfc_gobble_whitespace ();
1172 if (gfc_next_ascii_char () == '.')
1174 char ch
= gfc_next_ascii_char ();
1177 if (gfc_next_ascii_char () == 'a'
1178 && gfc_next_ascii_char () == 'l'
1179 && gfc_next_ascii_char () == 's'
1180 && gfc_next_ascii_char () == 'e'
1181 && gfc_next_ascii_char () == '.')
1182 /* Matched ".false.". */
1187 if (gfc_next_ascii_char () == 'r'
1188 && gfc_next_ascii_char () == 'u'
1189 && gfc_next_ascii_char () == 'e'
1190 && gfc_next_ascii_char () == '.')
1191 /* Matched ".true.". */
1195 gfc_current_locus
= orig_loc
;
1199 /* Match a .true. or .false. */
1202 match_logical_constant (gfc_expr
**result
)
1205 int i
, kind
, is_iso_c
;
1207 i
= match_logical_constant_string ();
1211 kind
= get_kind (&is_iso_c
);
1215 kind
= gfc_default_logical_kind
;
1217 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1219 gfc_error ("Bad kind for logical constant at %C");
1223 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1224 e
->ts
.is_c_interop
= is_iso_c
;
1231 /* Match a real or imaginary part of a complex constant that is a
1232 symbolic constant. */
1235 match_sym_complex_part (gfc_expr
**result
)
1237 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1242 m
= gfc_match_name (name
);
1246 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1249 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1251 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1258 if (!gfc_numeric_ts (&sym
->value
->ts
))
1260 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1264 if (sym
->value
->rank
!= 0)
1266 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1270 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1271 "complex constant at %C"))
1274 switch (sym
->value
->ts
.type
)
1277 e
= gfc_copy_expr (sym
->value
);
1281 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1287 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1293 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1296 *result
= e
; /* e is a scalar, real, constant expression. */
1300 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1305 /* Match a real or imaginary part of a complex number. */
1308 match_complex_part (gfc_expr
**result
)
1312 m
= match_sym_complex_part (result
);
1316 m
= match_real_constant (result
, 1);
1320 return match_integer_constant (result
, 1);
1324 /* Try to match a complex constant. */
1327 match_complex_constant (gfc_expr
**result
)
1329 gfc_expr
*e
, *real
, *imag
;
1330 gfc_error_buffer old_error
;
1331 gfc_typespec target
;
1336 old_loc
= gfc_current_locus
;
1337 real
= imag
= e
= NULL
;
1339 m
= gfc_match_char ('(');
1343 gfc_push_error (&old_error
);
1345 m
= match_complex_part (&real
);
1348 gfc_free_error (&old_error
);
1352 if (gfc_match_char (',') == MATCH_NO
)
1354 /* It is possible that gfc_int2real issued a warning when
1355 converting an integer to real. Throw this away here. */
1357 gfc_clear_warning ();
1358 gfc_pop_error (&old_error
);
1363 /* If m is error, then something was wrong with the real part and we
1364 assume we have a complex constant because we've seen the ','. An
1365 ambiguous case here is the start of an iterator list of some
1366 sort. These sort of lists are matched prior to coming here. */
1368 if (m
== MATCH_ERROR
)
1370 gfc_free_error (&old_error
);
1373 gfc_pop_error (&old_error
);
1375 m
= match_complex_part (&imag
);
1378 if (m
== MATCH_ERROR
)
1381 m
= gfc_match_char (')');
1384 /* Give the matcher for implied do-loops a chance to run. This
1385 yields a much saner error message for (/ (i, 4=i, 6) /). */
1386 if (gfc_peek_ascii_char () == '=')
1395 if (m
== MATCH_ERROR
)
1398 /* Decide on the kind of this complex number. */
1399 if (real
->ts
.type
== BT_REAL
)
1401 if (imag
->ts
.type
== BT_REAL
)
1402 kind
= gfc_kind_max (real
, imag
);
1404 kind
= real
->ts
.kind
;
1408 if (imag
->ts
.type
== BT_REAL
)
1409 kind
= imag
->ts
.kind
;
1411 kind
= gfc_default_real_kind
;
1413 gfc_clear_ts (&target
);
1414 target
.type
= BT_REAL
;
1417 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1418 gfc_convert_type (real
, &target
, 2);
1419 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1420 gfc_convert_type (imag
, &target
, 2);
1422 e
= gfc_convert_complex (real
, imag
, kind
);
1423 e
->where
= gfc_current_locus
;
1425 gfc_free_expr (real
);
1426 gfc_free_expr (imag
);
1432 gfc_error ("Syntax error in COMPLEX constant at %C");
1437 gfc_free_expr (real
);
1438 gfc_free_expr (imag
);
1439 gfc_current_locus
= old_loc
;
1445 /* Match constants in any of several forms. Returns nonzero for a
1446 match, zero for no match. */
1449 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1453 m
= match_complex_constant (result
);
1457 m
= match_string_constant (result
);
1461 m
= match_boz_constant (result
);
1465 m
= match_real_constant (result
, signflag
);
1469 m
= match_hollerith_constant (result
);
1473 m
= match_integer_constant (result
, signflag
);
1477 m
= match_logical_constant (result
);
1485 /* This checks if a symbol is the return value of an encompassing function.
1486 Function nesting can be maximally two levels deep, but we may have
1487 additional local namespaces like BLOCK etc. */
1490 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1492 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1496 if (ns
->proc_name
== sym
)
1504 /* Match a single actual argument value. An actual argument is
1505 usually an expression, but can also be a procedure name. If the
1506 argument is a single name, it is not always possible to tell
1507 whether the name is a dummy procedure or not. We treat these cases
1508 by creating an argument that looks like a dummy procedure and
1509 fixing things later during resolution. */
1512 match_actual_arg (gfc_expr
**result
)
1514 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1515 gfc_symtree
*symtree
;
1520 gfc_gobble_whitespace ();
1521 where
= gfc_current_locus
;
1523 switch (gfc_match_name (name
))
1532 w
= gfc_current_locus
;
1533 gfc_gobble_whitespace ();
1534 c
= gfc_next_ascii_char ();
1535 gfc_current_locus
= w
;
1537 if (c
!= ',' && c
!= ')')
1540 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1542 /* Handle error elsewhere. */
1544 /* Eliminate a couple of common cases where we know we don't
1545 have a function argument. */
1546 if (symtree
== NULL
)
1548 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1549 gfc_set_sym_referenced (symtree
->n
.sym
);
1555 sym
= symtree
->n
.sym
;
1556 gfc_set_sym_referenced (sym
);
1557 if (sym
->attr
.flavor
== FL_NAMELIST
)
1559 gfc_error ("Namelist %qs can not be an argument at %L",
1563 if (sym
->attr
.flavor
!= FL_PROCEDURE
1564 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1567 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1569 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1570 sym
->name
, &sym
->declared_at
))
1575 /* If the symbol is a function with itself as the result and
1576 is being defined, then we have a variable. */
1577 if (sym
->attr
.function
&& sym
->result
== sym
)
1579 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1583 && (sym
->ns
== gfc_current_ns
1584 || sym
->ns
== gfc_current_ns
->parent
))
1586 gfc_entry_list
*el
= NULL
;
1588 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1598 e
= gfc_get_expr (); /* Leave it unknown for now */
1599 e
->symtree
= symtree
;
1600 e
->expr_type
= EXPR_VARIABLE
;
1601 e
->ts
.type
= BT_PROCEDURE
;
1608 gfc_current_locus
= where
;
1609 return gfc_match_expr (result
);
1613 /* Match a keyword argument or type parameter spec list.. */
1616 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
, bool pdt
)
1618 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1619 gfc_actual_arglist
*a
;
1623 name_locus
= gfc_current_locus
;
1624 m
= gfc_match_name (name
);
1628 if (gfc_match_char ('=') != MATCH_YES
)
1636 if (gfc_match_char ('*') == MATCH_YES
)
1638 actual
->spec_type
= SPEC_ASSUMED
;
1641 else if (gfc_match_char (':') == MATCH_YES
)
1643 actual
->spec_type
= SPEC_DEFERRED
;
1647 actual
->spec_type
= SPEC_EXPLICIT
;
1650 m
= match_actual_arg (&actual
->expr
);
1654 /* Make sure this name has not appeared yet. */
1656 if (name
[0] != '\0')
1658 for (a
= base
; a
; a
= a
->next
)
1659 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1661 gfc_error ("Keyword %qs at %C has already appeared in the "
1662 "current argument list", name
);
1667 actual
->name
= gfc_get_string ("%s", name
);
1671 gfc_current_locus
= name_locus
;
1676 /* Match an argument list function, such as %VAL. */
1679 match_arg_list_function (gfc_actual_arglist
*result
)
1681 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1685 old_locus
= gfc_current_locus
;
1687 if (gfc_match_char ('%') != MATCH_YES
)
1693 m
= gfc_match ("%n (", name
);
1697 if (name
[0] != '\0')
1702 if (strncmp (name
, "loc", 3) == 0)
1704 result
->name
= "%LOC";
1709 if (strncmp (name
, "ref", 3) == 0)
1711 result
->name
= "%REF";
1716 if (strncmp (name
, "val", 3) == 0)
1718 result
->name
= "%VAL";
1728 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1734 m
= match_actual_arg (&result
->expr
);
1738 if (gfc_match_char (')') != MATCH_YES
)
1747 gfc_current_locus
= old_locus
;
1752 /* Matches an actual argument list of a function or subroutine, from
1753 the opening parenthesis to the closing parenthesis. The argument
1754 list is assumed to allow keyword arguments because we don't know if
1755 the symbol associated with the procedure has an implicit interface
1756 or not. We make sure keywords are unique. If sub_flag is set,
1757 we're matching the argument list of a subroutine.
1759 NOTE: An alternative use for this function is to match type parameter
1760 spec lists, which are so similar to actual argument lists that the
1761 machinery can be reused. This use is flagged by the optional argument
1765 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
, bool pdt
)
1767 gfc_actual_arglist
*head
, *tail
;
1769 gfc_st_label
*label
;
1773 *argp
= tail
= NULL
;
1774 old_loc
= gfc_current_locus
;
1778 if (gfc_match_char ('(') == MATCH_NO
)
1779 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1781 if (gfc_match_char (')') == MATCH_YES
)
1786 matching_actual_arglist
++;
1791 head
= tail
= gfc_get_actual_arglist ();
1794 tail
->next
= gfc_get_actual_arglist ();
1798 if (sub_flag
&& !pdt
&& gfc_match_char ('*') == MATCH_YES
)
1800 m
= gfc_match_st_label (&label
);
1802 gfc_error ("Expected alternate return label at %C");
1806 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1810 tail
->label
= label
;
1814 if (pdt
&& !seen_keyword
)
1816 if (gfc_match_char (':') == MATCH_YES
)
1818 tail
->spec_type
= SPEC_DEFERRED
;
1821 else if (gfc_match_char ('*') == MATCH_YES
)
1823 tail
->spec_type
= SPEC_ASSUMED
;
1827 tail
->spec_type
= SPEC_EXPLICIT
;
1829 m
= match_keyword_arg (tail
, head
, pdt
);
1835 if (m
== MATCH_ERROR
)
1839 /* After the first keyword argument is seen, the following
1840 arguments must also have keywords. */
1843 m
= match_keyword_arg (tail
, head
, pdt
);
1845 if (m
== MATCH_ERROR
)
1849 gfc_error ("Missing keyword name in actual argument list at %C");
1856 /* Try an argument list function, like %VAL. */
1857 m
= match_arg_list_function (tail
);
1858 if (m
== MATCH_ERROR
)
1861 /* See if we have the first keyword argument. */
1864 m
= match_keyword_arg (tail
, head
, false);
1867 if (m
== MATCH_ERROR
)
1873 /* Try for a non-keyword argument. */
1874 m
= match_actual_arg (&tail
->expr
);
1875 if (m
== MATCH_ERROR
)
1884 if (gfc_match_char (')') == MATCH_YES
)
1886 if (gfc_match_char (',') != MATCH_YES
)
1891 matching_actual_arglist
--;
1895 gfc_error ("Syntax error in argument list at %C");
1898 gfc_free_actual_arglist (head
);
1899 gfc_current_locus
= old_loc
;
1900 matching_actual_arglist
--;
1905 /* Used by gfc_match_varspec() to extend the reference list by one
1909 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1911 if (primary
->ref
== NULL
)
1912 primary
->ref
= tail
= gfc_get_ref ();
1916 gfc_internal_error ("extend_ref(): Bad tail");
1917 tail
->next
= gfc_get_ref ();
1925 /* Match any additional specifications associated with the current
1926 variable like member references or substrings. If equiv_flag is
1927 set we only match stuff that is allowed inside an EQUIVALENCE
1928 statement. sub_flag tells whether we expect a type-bound procedure found
1929 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1930 components, 'ppc_arg' determines whether the PPC may be called (with an
1931 argument list), or whether it may just be referred to as a pointer. */
1934 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1937 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1938 gfc_ref
*substring
, *tail
, *tmp
;
1939 gfc_component
*component
;
1940 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1941 gfc_expr
*tgt_expr
= NULL
;
1948 gfc_gobble_whitespace ();
1950 if (gfc_peek_ascii_char () == '[')
1952 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1953 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1954 && CLASS_DATA (sym
)->attr
.dimension
))
1956 gfc_error ("Array section designator, e.g. '(:)', is required "
1957 "besides the coarray designator '[...]' at %C");
1960 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1961 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1962 && !CLASS_DATA (sym
)->attr
.codimension
))
1964 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1970 if (sym
->assoc
&& sym
->assoc
->target
)
1971 tgt_expr
= sym
->assoc
->target
;
1973 /* For associate names, we may not yet know whether they are arrays or not.
1974 If the selector expression is unambiguously an array; eg. a full array
1975 or an array section, then the associate name must be an array and we can
1976 fix it now. Otherwise, if parentheses follow and it is not a character
1977 type, we have to assume that it actually is one for now. The final
1978 decision will be made at resolution, of course. */
1980 && gfc_peek_ascii_char () == '('
1981 && sym
->ts
.type
!= BT_CLASS
1982 && !sym
->attr
.dimension
)
1984 gfc_ref
*ref
= NULL
;
1986 if (!sym
->assoc
->dangling
&& tgt_expr
)
1988 if (tgt_expr
->expr_type
== EXPR_VARIABLE
)
1989 gfc_resolve_expr (tgt_expr
);
1991 ref
= tgt_expr
->ref
;
1992 for (; ref
; ref
= ref
->next
)
1993 if (ref
->type
== REF_ARRAY
1994 && (ref
->u
.ar
.type
== AR_FULL
1995 || ref
->u
.ar
.type
== AR_SECTION
))
1999 if (ref
|| (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
2001 && sym
->assoc
->st
->n
.sym
2002 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
2004 sym
->attr
.dimension
= 1;
2007 && sym
->assoc
->st
->n
.sym
2008 && sym
->assoc
->st
->n
.sym
->as
)
2009 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
2012 else if (sym
->ts
.type
== BT_CLASS
2014 && tgt_expr
->expr_type
== EXPR_VARIABLE
2015 && sym
->ts
.u
.derived
!= tgt_expr
->ts
.u
.derived
)
2017 gfc_resolve_expr (tgt_expr
);
2019 sym
->ts
.u
.derived
= tgt_expr
->ts
.u
.derived
;
2022 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
2023 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
2024 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
2025 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
2026 && !(gfc_matching_procptr_assignment
2027 && sym
->attr
.flavor
== FL_PROCEDURE
))
2028 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2029 && (CLASS_DATA (sym
)->attr
.dimension
2030 || CLASS_DATA (sym
)->attr
.codimension
)))
2034 tail
= extend_ref (primary
, tail
);
2035 tail
->type
= REF_ARRAY
;
2037 /* In EQUIVALENCE, we don't know yet whether we are seeing
2038 an array, character variable or array of character
2039 variables. We'll leave the decision till resolve time. */
2043 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2044 as
= CLASS_DATA (sym
)->as
;
2048 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
2049 as
? as
->corank
: 0);
2053 gfc_gobble_whitespace ();
2054 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
2056 tail
= extend_ref (primary
, tail
);
2057 tail
->type
= REF_ARRAY
;
2059 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2065 primary
->ts
= sym
->ts
;
2070 /* With DEC extensions, member separator may be '.' or '%'. */
2071 sep
= gfc_peek_ascii_char ();
2072 m
= gfc_match_member_sep (sym
);
2073 if (m
== MATCH_ERROR
)
2076 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2077 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2078 gfc_set_default_type (sym
, 0, sym
->ns
);
2080 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2081 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2085 /* These target expressions can be resolved at any time. */
2086 permissible
= tgt_expr
&& tgt_expr
->symtree
&& tgt_expr
->symtree
->n
.sym
2087 && (tgt_expr
->symtree
->n
.sym
->attr
.use_assoc
2088 || tgt_expr
->symtree
->n
.sym
->attr
.host_assoc
2089 || tgt_expr
->symtree
->n
.sym
->attr
.if_source
2091 permissible
= permissible
2092 || (tgt_expr
&& tgt_expr
->expr_type
== EXPR_OP
);
2096 gfc_resolve_expr (tgt_expr
);
2097 sym
->ts
= tgt_expr
->ts
;
2100 if (sym
->ts
.type
== BT_UNKNOWN
)
2102 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2106 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2109 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2114 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2116 goto check_substring
;
2118 sym
= sym
->ts
.u
.derived
;
2125 m
= gfc_match_name (name
);
2127 gfc_error ("Expected structure component name at %C");
2131 if (sym
&& sym
->f2k_derived
)
2132 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2138 gfc_symbol
* tbp_sym
;
2143 gcc_assert (!tail
|| !tail
->next
);
2145 if (!(primary
->expr_type
== EXPR_VARIABLE
2146 || (primary
->expr_type
== EXPR_STRUCTURE
2147 && primary
->symtree
&& primary
->symtree
->n
.sym
2148 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2151 if (tbp
->n
.tb
->is_generic
)
2154 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2156 primary
->expr_type
= EXPR_COMPCALL
;
2157 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2158 primary
->value
.compcall
.name
= tbp
->name
;
2159 primary
->value
.compcall
.ignore_pass
= 0;
2160 primary
->value
.compcall
.assign
= 0;
2161 primary
->value
.compcall
.base_object
= NULL
;
2162 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2164 primary
->ts
= tbp_sym
->ts
;
2166 gfc_clear_ts (&primary
->ts
);
2168 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2169 &primary
->value
.compcall
.actual
);
2170 if (m
== MATCH_ERROR
)
2175 primary
->value
.compcall
.actual
= NULL
;
2178 gfc_error ("Expected argument list at %C");
2186 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2187 if (component
== NULL
)
2190 /* Extend the reference chain determined by gfc_find_component. */
2191 if (primary
->ref
== NULL
)
2195 /* Set by the for loop below for the last component ref. */
2196 gcc_assert (tail
!= NULL
);
2200 /* The reference chain may be longer than one hop for union
2201 subcomponents; find the new tail. */
2202 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2205 primary
->ts
= component
->ts
;
2207 if (component
->attr
.proc_pointer
&& ppc_arg
)
2209 /* Procedure pointer component call: Look for argument list. */
2210 m
= gfc_match_actual_arglist (sub_flag
,
2211 &primary
->value
.compcall
.actual
);
2212 if (m
== MATCH_ERROR
)
2215 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2216 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2218 gfc_error ("Procedure pointer component %qs requires an "
2219 "argument list at %C", component
->name
);
2224 primary
->expr_type
= EXPR_PPC
;
2229 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2231 tail
= extend_ref (primary
, tail
);
2232 tail
->type
= REF_ARRAY
;
2234 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2235 component
->as
->corank
);
2239 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2240 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2242 tail
= extend_ref (primary
, tail
);
2243 tail
->type
= REF_ARRAY
;
2245 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2247 CLASS_DATA (component
)->as
->corank
);
2252 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2253 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2256 sym
= component
->ts
.u
.derived
;
2261 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2263 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2265 gfc_set_default_type (sym
, 0, sym
->ns
);
2266 primary
->ts
= sym
->ts
;
2271 if (primary
->ts
.type
== BT_CHARACTER
)
2273 bool def
= primary
->ts
.deferred
== 1;
2274 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2278 primary
->ref
= substring
;
2280 tail
->next
= substring
;
2282 if (primary
->expr_type
== EXPR_CONSTANT
)
2283 primary
->expr_type
= EXPR_SUBSTRING
;
2286 primary
->ts
.u
.cl
= NULL
;
2293 gfc_clear_ts (&primary
->ts
);
2294 gfc_clear_ts (&sym
->ts
);
2304 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2305 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2307 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2312 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2314 gfc_error ("Coindexed procedure-pointer component at %C");
2322 /* Given an expression that is a variable, figure out what the
2323 ultimate variable's type and attribute is, traversing the reference
2324 structures if necessary.
2326 This subroutine is trickier than it looks. We start at the base
2327 symbol and store the attribute. Component references load a
2328 completely new attribute.
2330 A couple of rules come into play. Subobjects of targets are always
2331 targets themselves. If we see a component that goes through a
2332 pointer, then the expression must also be a target, since the
2333 pointer is associated with something (if it isn't core will soon be
2334 dumped). If we see a full part or section of an array, the
2335 expression is also an array.
2337 We can have at most one full array reference. */
2340 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2342 int dimension
, codimension
, pointer
, allocatable
, target
;
2343 symbol_attribute attr
;
2346 gfc_component
*comp
;
2348 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2349 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2351 sym
= expr
->symtree
->n
.sym
;
2354 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2356 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2357 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2358 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2359 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2363 dimension
= attr
.dimension
;
2364 codimension
= attr
.codimension
;
2365 pointer
= attr
.pointer
;
2366 allocatable
= attr
.allocatable
;
2369 target
= attr
.target
;
2370 if (pointer
|| attr
.proc_pointer
)
2373 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2376 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2381 switch (ref
->u
.ar
.type
)
2388 allocatable
= pointer
= 0;
2393 /* Handle coarrays. */
2394 if (ref
->u
.ar
.dimen
> 0)
2395 allocatable
= pointer
= 0;
2399 /* If any of start, end or stride is not integer, there will
2400 already have been an error issued. */
2402 gfc_get_errors (NULL
, &errors
);
2404 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2410 comp
= ref
->u
.c
.component
;
2415 /* Don't set the string length if a substring reference
2417 if (ts
->type
== BT_CHARACTER
2418 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2422 if (comp
->ts
.type
== BT_CLASS
)
2424 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2425 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2426 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2430 codimension
= comp
->attr
.codimension
;
2431 pointer
= comp
->attr
.pointer
;
2432 allocatable
= comp
->attr
.allocatable
;
2434 if (pointer
|| attr
.proc_pointer
)
2440 allocatable
= pointer
= 0;
2444 attr
.dimension
= dimension
;
2445 attr
.codimension
= codimension
;
2446 attr
.pointer
= pointer
;
2447 attr
.allocatable
= allocatable
;
2448 attr
.target
= target
;
2449 attr
.save
= sym
->attr
.save
;
2455 /* Return the attribute from a general expression. */
2458 gfc_expr_attr (gfc_expr
*e
)
2460 symbol_attribute attr
;
2462 switch (e
->expr_type
)
2465 attr
= gfc_variable_attr (e
, NULL
);
2469 gfc_clear_attr (&attr
);
2471 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2473 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2475 if (sym
->ts
.type
== BT_CLASS
)
2477 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2478 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2479 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2482 else if (e
->value
.function
.isym
2483 && e
->value
.function
.isym
->transformational
2484 && e
->ts
.type
== BT_CLASS
)
2485 attr
= CLASS_DATA (e
)->attr
;
2487 attr
= gfc_variable_attr (e
, NULL
);
2489 /* TODO: NULL() returns pointers. May have to take care of this
2495 gfc_clear_attr (&attr
);
2503 /* Given an expression, figure out what the ultimate expression
2504 attribute is. This routine is similar to gfc_variable_attr with
2505 parts of gfc_expr_attr, but focuses more on the needs of
2506 coarrays. For coarrays a codimension attribute is kind of
2507 "infectious" being propagated once set and never cleared.
2508 The coarray_comp is only set, when the expression refs a coarray
2509 component. REFS_COMP is set when present to true only, when this EXPR
2510 refs a (non-_data) component. To check whether EXPR refs an allocatable
2511 component in a derived type coarray *refs_comp needs to be set and
2512 coarray_comp has to false. */
2514 static symbol_attribute
2515 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2517 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2518 symbol_attribute attr
;
2521 gfc_component
*comp
;
2523 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2524 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2526 sym
= expr
->symtree
->n
.sym
;
2527 gfc_clear_attr (&attr
);
2532 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2534 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2535 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2536 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2537 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2538 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2539 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2543 dimension
= sym
->attr
.dimension
;
2544 codimension
= sym
->attr
.codimension
;
2545 pointer
= sym
->attr
.pointer
;
2546 allocatable
= sym
->attr
.allocatable
;
2547 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2548 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2549 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2550 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2553 target
= coarray_comp
= 0;
2554 if (pointer
|| attr
.proc_pointer
)
2557 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2562 switch (ref
->u
.ar
.type
)
2570 /* Handle coarrays. */
2571 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2572 allocatable
= pointer
= 0;
2576 /* If any of start, end or stride is not integer, there will
2577 already have been an error issued. */
2579 gfc_get_errors (NULL
, &errors
);
2581 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2587 comp
= ref
->u
.c
.component
;
2589 if (comp
->ts
.type
== BT_CLASS
)
2591 /* Set coarray_comp only, when this component introduces the
2593 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2594 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2595 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2596 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2600 /* Set coarray_comp only, when this component introduces the
2602 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2603 codimension
|= comp
->attr
.codimension
;
2604 pointer
= comp
->attr
.pointer
;
2605 allocatable
= comp
->attr
.allocatable
;
2608 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2609 && (ref
->next
== NULL
2610 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2613 if (pointer
|| attr
.proc_pointer
)
2619 allocatable
= pointer
= 0;
2623 attr
.dimension
= dimension
;
2624 attr
.codimension
= codimension
;
2625 attr
.pointer
= pointer
;
2626 attr
.allocatable
= allocatable
;
2627 attr
.target
= target
;
2628 attr
.save
= sym
->attr
.save
;
2629 attr
.coarray_comp
= coarray_comp
;
2636 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2638 symbol_attribute attr
;
2640 switch (e
->expr_type
)
2643 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2647 gfc_clear_attr (&attr
);
2649 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2651 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2653 if (sym
->ts
.type
== BT_CLASS
)
2655 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2656 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2657 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2658 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2659 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2660 ->attr
.pointer_comp
;
2663 else if (e
->symtree
)
2664 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2666 gfc_clear_attr (&attr
);
2670 gfc_clear_attr (&attr
);
2678 /* Match a structure constructor. The initial symbol has already been
2681 typedef struct gfc_structure_ctor_component
2686 struct gfc_structure_ctor_component
* next
;
2688 gfc_structure_ctor_component
;
2690 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2693 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2696 gfc_free_expr (comp
->val
);
2701 /* Translate the component list into the actual constructor by sorting it in
2702 the order required; this also checks along the way that each and every
2703 component actually has an initializer and handles default initializers
2704 for components without explicit value given. */
2706 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2707 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2709 gfc_structure_ctor_component
*comp_iter
;
2710 gfc_component
*comp
;
2712 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2714 gfc_structure_ctor_component
**next_ptr
;
2715 gfc_expr
*value
= NULL
;
2717 /* Try to find the initializer for the current component by name. */
2718 next_ptr
= comp_head
;
2719 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2721 if (!strcmp (comp_iter
->name
, comp
->name
))
2723 next_ptr
= &comp_iter
->next
;
2726 /* If an extension, try building the parent derived type by building
2727 a value expression for the parent derived type and calling self. */
2728 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2730 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2732 &gfc_current_locus
);
2733 value
->ts
= comp
->ts
;
2735 if (!build_actual_constructor (comp_head
,
2736 &value
->value
.constructor
,
2737 comp
->ts
.u
.derived
))
2739 gfc_free_expr (value
);
2743 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2747 /* If it was not found, try the default initializer if there's any;
2748 otherwise, it's an error unless this is a deferred parameter. */
2751 if (comp
->initializer
)
2753 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2754 "with missing optional arguments at %C"))
2756 value
= gfc_copy_expr (comp
->initializer
);
2758 else if (comp
->attr
.allocatable
2759 || (comp
->ts
.type
== BT_CLASS
2760 && CLASS_DATA (comp
)->attr
.allocatable
))
2762 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2763 "allocatable component %qs given in the "
2764 "structure constructor at %C", comp
->name
))
2767 else if (!comp
->attr
.artificial
)
2769 gfc_error ("No initializer for component %qs given in the"
2770 " structure constructor at %C", comp
->name
);
2775 value
= comp_iter
->val
;
2777 /* Add the value to the constructor chain built. */
2778 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2780 /* Remove the entry from the component list. We don't want the expression
2781 value to be free'd, so set it to NULL. */
2784 *next_ptr
= comp_iter
->next
;
2785 comp_iter
->val
= NULL
;
2786 gfc_free_structure_ctor_component (comp_iter
);
2794 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2795 gfc_actual_arglist
**arglist
,
2798 gfc_actual_arglist
*actual
;
2799 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2800 gfc_constructor_base ctor_head
= NULL
;
2801 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2802 const char* last_name
= NULL
;
2806 expr
= parent
? *cexpr
: e
;
2807 old_locus
= gfc_current_locus
;
2809 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2811 gfc_current_locus
= expr
->where
;
2813 comp_tail
= comp_head
= NULL
;
2815 if (!parent
&& sym
->attr
.abstract
)
2817 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2818 sym
->name
, &expr
->where
);
2822 comp
= sym
->components
;
2823 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2826 gfc_component
*this_comp
= NULL
;
2829 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2832 comp_tail
->next
= gfc_get_structure_ctor_component ();
2833 comp_tail
= comp_tail
->next
;
2837 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2838 " constructor with named arguments at %C"))
2841 comp_tail
->name
= xstrdup (actual
->name
);
2842 last_name
= comp_tail
->name
;
2847 /* Components without name are not allowed after the first named
2848 component initializer! */
2849 if (!comp
|| comp
->attr
.artificial
)
2852 gfc_error ("Component initializer without name after component"
2853 " named %s at %L", last_name
,
2854 actual
->expr
? &actual
->expr
->where
2855 : &gfc_current_locus
);
2857 gfc_error ("Too many components in structure constructor at "
2858 "%L", actual
->expr
? &actual
->expr
->where
2859 : &gfc_current_locus
);
2863 comp_tail
->name
= xstrdup (comp
->name
);
2866 /* Find the current component in the structure definition and check
2867 its access is not private. */
2869 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
2872 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2873 false, false, NULL
);
2874 comp
= NULL
; /* Reset needed! */
2877 /* Here we can check if a component name is given which does not
2878 correspond to any component of the defined structure. */
2882 /* For a constant string constructor, make sure the length is
2883 correct; truncate of fill with blanks if needed. */
2884 if (this_comp
->ts
.type
== BT_CHARACTER
&& !this_comp
->attr
.allocatable
2885 && this_comp
->ts
.u
.cl
&& this_comp
->ts
.u
.cl
->length
2886 && this_comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
2887 && actual
->expr
->expr_type
== EXPR_CONSTANT
)
2890 c
= gfc_mpz_get_hwi (this_comp
->ts
.u
.cl
->length
->value
.integer
);
2891 e
= actual
->expr
->value
.character
.length
;
2897 dest
= gfc_get_wide_string (c
+ 1);
2900 for (i
= 0; i
< to
; i
++)
2901 dest
[i
] = actual
->expr
->value
.character
.string
[i
];
2903 for (i
= e
; i
< c
; i
++)
2907 free (actual
->expr
->value
.character
.string
);
2909 actual
->expr
->value
.character
.length
= c
;
2910 actual
->expr
->value
.character
.string
= dest
;
2914 comp_tail
->val
= actual
->expr
;
2915 if (actual
->expr
!= NULL
)
2916 comp_tail
->where
= actual
->expr
->where
;
2917 actual
->expr
= NULL
;
2919 /* Check if this component is already given a value. */
2920 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2921 comp_iter
= comp_iter
->next
)
2923 gcc_assert (comp_iter
);
2924 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2926 gfc_error ("Component %qs is initialized twice in the structure"
2927 " constructor at %L", comp_tail
->name
,
2928 comp_tail
->val
? &comp_tail
->where
2929 : &gfc_current_locus
);
2934 /* F2008, R457/C725, for PURE C1283. */
2935 if (this_comp
->attr
.pointer
&& comp_tail
->val
2936 && gfc_is_coindexed (comp_tail
->val
))
2938 gfc_error ("Coindexed expression to pointer component %qs in "
2939 "structure constructor at %L", comp_tail
->name
,
2944 /* If not explicitly a parent constructor, gather up the components
2946 if (comp
&& comp
== sym
->components
2947 && sym
->attr
.extension
2949 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
2951 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2954 gfc_actual_arglist
*arg_null
= NULL
;
2956 actual
->expr
= comp_tail
->val
;
2957 comp_tail
->val
= NULL
;
2959 m
= gfc_convert_to_structure_constructor (NULL
,
2960 comp
->ts
.u
.derived
, &comp_tail
->val
,
2961 comp
->ts
.u
.derived
->attr
.zero_comp
2962 ? &arg_null
: &actual
, true);
2966 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2975 if (parent
&& !comp
)
2979 actual
= actual
->next
;
2982 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2985 /* No component should be left, as this should have caused an error in the
2986 loop constructing the component-list (name that does not correspond to any
2987 component in the structure definition). */
2988 if (comp_head
&& sym
->attr
.extension
)
2990 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2992 gfc_error ("component %qs at %L has already been set by a "
2993 "parent derived type constructor", comp_iter
->name
,
2999 gcc_assert (!comp_head
);
3003 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
3004 expr
->ts
.u
.derived
= sym
;
3005 expr
->value
.constructor
= ctor_head
;
3010 expr
->ts
.u
.derived
= sym
;
3012 expr
->ts
.type
= BT_DERIVED
;
3013 expr
->value
.constructor
= ctor_head
;
3014 expr
->expr_type
= EXPR_STRUCTURE
;
3017 gfc_current_locus
= old_locus
;
3023 gfc_current_locus
= old_locus
;
3025 for (comp_iter
= comp_head
; comp_iter
; )
3027 gfc_structure_ctor_component
*next
= comp_iter
->next
;
3028 gfc_free_structure_ctor_component (comp_iter
);
3031 gfc_constructor_free (ctor_head
);
3038 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
3042 gfc_symtree
*symtree
;
3044 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
3046 e
= gfc_get_expr ();
3047 e
->symtree
= symtree
;
3048 e
->expr_type
= EXPR_FUNCTION
;
3050 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
3051 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
3052 e
->value
.function
.esym
= sym
;
3053 e
->symtree
->n
.sym
->attr
.generic
= 1;
3055 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3062 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
3068 /* If a structure constructor is in a DATA statement, then each entity
3069 in the structure constructor must be a constant. Try to reduce the
3071 if (gfc_in_match_data ())
3072 gfc_reduce_init_expr (e
);
3079 /* If the symbol is an implicit do loop index and implicitly typed,
3080 it should not be host associated. Provide a symtree from the
3081 current namespace. */
3083 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
3085 if ((*sym
)->attr
.flavor
== FL_VARIABLE
3086 && (*sym
)->ns
!= gfc_current_ns
3087 && (*sym
)->attr
.implied_index
3088 && (*sym
)->attr
.implicit_type
3089 && !(*sym
)->attr
.use_assoc
)
3092 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
3095 *sym
= (*st
)->n
.sym
;
3101 /* Procedure pointer as function result: Replace the function symbol by the
3102 auto-generated hidden result variable named "ppr@". */
3105 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
3107 /* Check for procedure pointer result variable. */
3108 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
3109 && (*sym
)->result
&& (*sym
)->result
!= *sym
3110 && (*sym
)->result
->attr
.proc_pointer
3111 && (*sym
) == gfc_current_ns
->proc_name
3112 && (*sym
) == (*sym
)->result
->ns
->proc_name
3113 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3115 /* Automatic replacement with "hidden" result variable. */
3116 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3117 *sym
= (*sym
)->result
;
3118 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3125 /* Matches a variable name followed by anything that might follow it--
3126 array reference, argument list of a function, etc. */
3129 gfc_match_rvalue (gfc_expr
**result
)
3131 gfc_actual_arglist
*actual_arglist
;
3132 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3135 gfc_symtree
*symtree
;
3136 locus where
, old_loc
;
3144 m
= gfc_match ("%%loc");
3147 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3149 strncpy (name
, "loc", 4);
3154 m
= gfc_match_name (name
);
3159 /* Check if the symbol exists. */
3160 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3163 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3164 type. For derived types we create a generic symbol which links to the
3165 derived type symbol; STRUCTUREs are simpler and must not conflict with
3168 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3170 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3172 if (gfc_find_state (COMP_INTERFACE
)
3173 && !gfc_current_ns
->has_import_set
)
3174 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3176 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3182 sym
= symtree
->n
.sym
;
3184 where
= gfc_current_locus
;
3186 replace_hidden_procptr_result (&sym
, &symtree
);
3188 /* If this is an implicit do loop index and implicitly typed,
3189 it should not be host associated. */
3190 m
= check_for_implicit_index (&symtree
, &sym
);
3194 gfc_set_sym_referenced (sym
);
3195 sym
->attr
.implied_index
= 0;
3197 if (sym
->attr
.function
&& sym
->result
== sym
)
3199 /* See if this is a directly recursive function call. */
3200 gfc_gobble_whitespace ();
3201 if (sym
->attr
.recursive
3202 && gfc_peek_ascii_char () == '('
3203 && gfc_current_ns
->proc_name
== sym
3204 && !sym
->attr
.dimension
)
3206 gfc_error ("%qs at %C is the name of a recursive function "
3207 "and so refers to the result variable. Use an "
3208 "explicit RESULT variable for direct recursion "
3209 "(12.5.2.1)", sym
->name
);
3213 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3217 && (sym
->ns
== gfc_current_ns
3218 || sym
->ns
== gfc_current_ns
->parent
))
3220 gfc_entry_list
*el
= NULL
;
3222 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3228 if (gfc_matching_procptr_assignment
)
3231 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3234 if (sym
->attr
.generic
)
3235 goto generic_function
;
3237 switch (sym
->attr
.flavor
)
3241 e
= gfc_get_expr ();
3243 e
->expr_type
= EXPR_VARIABLE
;
3244 e
->symtree
= symtree
;
3246 m
= gfc_match_varspec (e
, 0, false, true);
3250 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3251 end up here. Unfortunately, sym->value->expr_type is set to
3252 EXPR_CONSTANT, and so the if () branch would be followed without
3253 the !sym->as check. */
3254 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3255 e
= gfc_copy_expr (sym
->value
);
3258 e
= gfc_get_expr ();
3259 e
->expr_type
= EXPR_VARIABLE
;
3262 e
->symtree
= symtree
;
3263 m
= gfc_match_varspec (e
, 0, false, true);
3265 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3268 /* Variable array references to derived type parameters cause
3269 all sorts of headaches in simplification. Treating such
3270 expressions as variable works just fine for all array
3272 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3274 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3275 if (ref
->type
== REF_ARRAY
)
3278 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3284 e
= gfc_get_expr ();
3285 e
->expr_type
= EXPR_VARIABLE
;
3286 e
->symtree
= symtree
;
3294 sym
= gfc_use_derived (sym
);
3298 goto generic_function
;
3301 /* If we're here, then the name is known to be the name of a
3302 procedure, yet it is not sure to be the name of a function. */
3305 /* Procedure Pointer Assignments. */
3307 if (gfc_matching_procptr_assignment
)
3309 gfc_gobble_whitespace ();
3310 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3311 /* Parse functions returning a procptr. */
3314 e
= gfc_get_expr ();
3315 e
->expr_type
= EXPR_VARIABLE
;
3316 e
->symtree
= symtree
;
3317 m
= gfc_match_varspec (e
, 0, false, true);
3318 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3319 && sym
->ts
.type
== BT_UNKNOWN
3320 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3328 if (sym
->attr
.subroutine
)
3330 gfc_error ("Unexpected use of subroutine name %qs at %C",
3336 /* At this point, the name has to be a non-statement function.
3337 If the name is the same as the current function being
3338 compiled, then we have a variable reference (to the function
3339 result) if the name is non-recursive. */
3341 st
= gfc_enclosing_unit (NULL
);
3344 && st
->state
== COMP_FUNCTION
3346 && !sym
->attr
.recursive
)
3348 e
= gfc_get_expr ();
3349 e
->symtree
= symtree
;
3350 e
->expr_type
= EXPR_VARIABLE
;
3352 m
= gfc_match_varspec (e
, 0, false, true);
3356 /* Match a function reference. */
3358 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3361 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3362 gfc_error ("Statement function %qs requires argument list at %C",
3365 gfc_error ("Function %qs requires an argument list at %C",
3378 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3379 sym
= symtree
->n
.sym
;
3381 replace_hidden_procptr_result (&sym
, &symtree
);
3383 e
= gfc_get_expr ();
3384 e
->symtree
= symtree
;
3385 e
->expr_type
= EXPR_FUNCTION
;
3386 e
->value
.function
.actual
= actual_arglist
;
3387 e
->where
= gfc_current_locus
;
3389 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3390 && CLASS_DATA (sym
)->as
)
3391 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3392 else if (sym
->as
!= NULL
)
3393 e
->rank
= sym
->as
->rank
;
3395 if (!sym
->attr
.function
3396 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3402 /* Check here for the existence of at least one argument for the
3403 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3404 argument(s) given will be checked in gfc_iso_c_func_interface,
3405 during resolution of the function call. */
3406 if (sym
->attr
.is_iso_c
== 1
3407 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3408 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3409 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3410 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3412 /* make sure we were given a param */
3413 if (actual_arglist
== NULL
)
3415 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3421 if (sym
->result
== NULL
)
3424 gfc_gobble_whitespace ();
3426 if (gfc_peek_ascii_char() == '%')
3428 gfc_error ("The leftmost part-ref in a data-ref can not be a "
3429 "function reference at %C");
3438 /* Special case for derived type variables that get their types
3439 via an IMPLICIT statement. This can't wait for the
3440 resolution phase. */
3442 old_loc
= gfc_current_locus
;
3443 if (gfc_match_member_sep (sym
) == MATCH_YES
3444 && sym
->ts
.type
== BT_UNKNOWN
3445 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3446 gfc_set_default_type (sym
, 0, sym
->ns
);
3447 gfc_current_locus
= old_loc
;
3449 /* If the symbol has a (co)dimension attribute, the expression is a
3452 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3454 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3460 e
= gfc_get_expr ();
3461 e
->symtree
= symtree
;
3462 e
->expr_type
= EXPR_VARIABLE
;
3463 m
= gfc_match_varspec (e
, 0, false, true);
3467 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3468 && (CLASS_DATA (sym
)->attr
.dimension
3469 || CLASS_DATA (sym
)->attr
.codimension
))
3471 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3477 e
= gfc_get_expr ();
3478 e
->symtree
= symtree
;
3479 e
->expr_type
= EXPR_VARIABLE
;
3480 m
= gfc_match_varspec (e
, 0, false, true);
3484 /* Name is not an array, so we peek to see if a '(' implies a
3485 function call or a substring reference. Otherwise the
3486 variable is just a scalar. */
3488 gfc_gobble_whitespace ();
3489 if (gfc_peek_ascii_char () != '(')
3491 /* Assume a scalar variable */
3492 e
= gfc_get_expr ();
3493 e
->symtree
= symtree
;
3494 e
->expr_type
= EXPR_VARIABLE
;
3496 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3502 /*FIXME:??? gfc_match_varspec does set this for us: */
3504 m
= gfc_match_varspec (e
, 0, false, true);
3508 /* See if this is a function reference with a keyword argument
3509 as first argument. We do this because otherwise a spurious
3510 symbol would end up in the symbol table. */
3512 old_loc
= gfc_current_locus
;
3513 m2
= gfc_match (" ( %n =", argname
);
3514 gfc_current_locus
= old_loc
;
3516 e
= gfc_get_expr ();
3517 e
->symtree
= symtree
;
3519 if (m2
!= MATCH_YES
)
3521 /* Try to figure out whether we're dealing with a character type.
3522 We're peeking ahead here, because we don't want to call
3523 match_substring if we're dealing with an implicitly typed
3524 non-character variable. */
3525 implicit_char
= false;
3526 if (sym
->ts
.type
== BT_UNKNOWN
)
3528 ts
= gfc_get_default_type (sym
->name
, NULL
);
3529 if (ts
->type
== BT_CHARACTER
)
3530 implicit_char
= true;
3533 /* See if this could possibly be a substring reference of a name
3534 that we're not sure is a variable yet. */
3536 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3537 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3540 e
->expr_type
= EXPR_VARIABLE
;
3542 if (sym
->attr
.flavor
!= FL_VARIABLE
3543 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3550 if (sym
->ts
.type
== BT_UNKNOWN
3551 && !gfc_set_default_type (sym
, 1, NULL
))
3565 /* Give up, assume we have a function. */
3567 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3568 sym
= symtree
->n
.sym
;
3569 e
->expr_type
= EXPR_FUNCTION
;
3571 if (!sym
->attr
.function
3572 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3580 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3582 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3590 /* If our new function returns a character, array or structure
3591 type, it might have subsequent references. */
3593 m
= gfc_match_varspec (e
, 0, false, true);
3600 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3601 specially. Creates a generic symbol for derived types. */
3602 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3604 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3605 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3606 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3608 e
= gfc_get_expr ();
3609 e
->symtree
= symtree
;
3610 e
->expr_type
= EXPR_FUNCTION
;
3612 if (gfc_fl_struct (sym
->attr
.flavor
))
3614 e
->value
.function
.esym
= sym
;
3615 e
->symtree
->n
.sym
->attr
.generic
= 1;
3618 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3626 gfc_error ("Symbol at %C is not appropriate for an expression");
3642 /* Match a variable, i.e. something that can be assigned to. This
3643 starts as a symbol, can be a structure component or an array
3644 reference. It can be a function if the function doesn't have a
3645 separate RESULT variable. If the symbol has not been previously
3646 seen, we assume it is a variable.
3648 This function is called by two interface functions:
3649 gfc_match_variable, which has host_flag = 1, and
3650 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3651 match of the symbol to the local scope. */
3654 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3656 gfc_symbol
*sym
, *dt_sym
;
3659 locus where
, old_loc
;
3662 /* Since nothing has any business being an lvalue in a module
3663 specification block, an interface block or a contains section,
3664 we force the changed_symbols mechanism to work by setting
3665 host_flag to 0. This prevents valid symbols that have the name
3666 of keywords, such as 'end', being turned into variables by
3667 failed matching to assignments for, e.g., END INTERFACE. */
3668 if (gfc_current_state () == COMP_MODULE
3669 || gfc_current_state () == COMP_SUBMODULE
3670 || gfc_current_state () == COMP_INTERFACE
3671 || gfc_current_state () == COMP_CONTAINS
)
3674 where
= gfc_current_locus
;
3675 m
= gfc_match_sym_tree (&st
, host_flag
);
3681 /* If this is an implicit do loop index and implicitly typed,
3682 it should not be host associated. */
3683 m
= check_for_implicit_index (&st
, &sym
);
3687 sym
->attr
.implied_index
= 0;
3689 gfc_set_sym_referenced (sym
);
3691 /* STRUCTUREs may share names with variables, but derived types may not. */
3692 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3693 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3695 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3696 gfc_error ("Derived type %qs cannot be used as a variable at %C",
3701 switch (sym
->attr
.flavor
)
3704 /* Everything is alright. */
3709 sym_flavor flavor
= FL_UNKNOWN
;
3711 gfc_gobble_whitespace ();
3713 if (sym
->attr
.external
|| sym
->attr
.procedure
3714 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3715 flavor
= FL_PROCEDURE
;
3717 /* If it is not a procedure, is not typed and is host associated,
3718 we cannot give it a flavor yet. */
3719 else if (sym
->ns
== gfc_current_ns
->parent
3720 && sym
->ts
.type
== BT_UNKNOWN
)
3723 /* These are definitive indicators that this is a variable. */
3724 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3725 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3726 flavor
= FL_VARIABLE
;
3728 if (flavor
!= FL_UNKNOWN
3729 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3737 gfc_error ("Named constant at %C in an EQUIVALENCE");
3740 /* Otherwise this is checked for and an error given in the
3741 variable definition context checks. */
3745 /* Check for a nonrecursive function result variable. */
3746 if (sym
->attr
.function
3747 && !sym
->attr
.external
3748 && sym
->result
== sym
3749 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3751 && sym
->ns
== gfc_current_ns
)
3753 && sym
->ns
== gfc_current_ns
->parent
)))
3755 /* If a function result is a derived type, then the derived
3756 type may still have to be resolved. */
3758 if (sym
->ts
.type
== BT_DERIVED
3759 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3764 if (sym
->attr
.proc_pointer
3765 || replace_hidden_procptr_result (&sym
, &st
))
3768 /* Fall through to error */
3772 gfc_error ("%qs at %C is not a variable", sym
->name
);
3776 /* Special case for derived type variables that get their types
3777 via an IMPLICIT statement. This can't wait for the
3778 resolution phase. */
3781 gfc_namespace
* implicit_ns
;
3783 if (gfc_current_ns
->proc_name
== sym
)
3784 implicit_ns
= gfc_current_ns
;
3786 implicit_ns
= sym
->ns
;
3788 old_loc
= gfc_current_locus
;
3789 if (gfc_match_member_sep (sym
) == MATCH_YES
3790 && sym
->ts
.type
== BT_UNKNOWN
3791 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3792 gfc_set_default_type (sym
, 0, implicit_ns
);
3793 gfc_current_locus
= old_loc
;
3796 expr
= gfc_get_expr ();
3798 expr
->expr_type
= EXPR_VARIABLE
;
3801 expr
->where
= where
;
3803 /* Now see if we have to do more. */
3804 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3807 gfc_free_expr (expr
);
3817 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3819 return match_variable (result
, equiv_flag
, 1);
3824 gfc_match_equiv_variable (gfc_expr
**result
)
3826 return match_variable (result
, 1, 0);