1 /* Primary expression subroutines
2 Copyright (C) 2000-2019 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 /* Give the matcher for implied do-loops a chance to run. This yields
1252 a much saner error message for "write(*,*) (i, i=1, 6" where the
1253 right parenthesis is missing. */
1255 gfc_gobble_whitespace ();
1256 c
= gfc_peek_ascii_char ();
1257 if (c
== '=' || c
== ',')
1263 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1272 if (!gfc_numeric_ts (&sym
->value
->ts
))
1274 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1278 if (sym
->value
->rank
!= 0)
1280 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1284 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1285 "complex constant at %C"))
1288 switch (sym
->value
->ts
.type
)
1291 e
= gfc_copy_expr (sym
->value
);
1295 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1301 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1307 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1310 *result
= e
; /* e is a scalar, real, constant expression. */
1314 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1319 /* Match a real or imaginary part of a complex number. */
1322 match_complex_part (gfc_expr
**result
)
1326 m
= match_sym_complex_part (result
);
1330 m
= match_real_constant (result
, 1);
1334 return match_integer_constant (result
, 1);
1338 /* Try to match a complex constant. */
1341 match_complex_constant (gfc_expr
**result
)
1343 gfc_expr
*e
, *real
, *imag
;
1344 gfc_error_buffer old_error
;
1345 gfc_typespec target
;
1350 old_loc
= gfc_current_locus
;
1351 real
= imag
= e
= NULL
;
1353 m
= gfc_match_char ('(');
1357 gfc_push_error (&old_error
);
1359 m
= match_complex_part (&real
);
1362 gfc_free_error (&old_error
);
1366 if (gfc_match_char (',') == MATCH_NO
)
1368 /* It is possible that gfc_int2real issued a warning when
1369 converting an integer to real. Throw this away here. */
1371 gfc_clear_warning ();
1372 gfc_pop_error (&old_error
);
1377 /* If m is error, then something was wrong with the real part and we
1378 assume we have a complex constant because we've seen the ','. An
1379 ambiguous case here is the start of an iterator list of some
1380 sort. These sort of lists are matched prior to coming here. */
1382 if (m
== MATCH_ERROR
)
1384 gfc_free_error (&old_error
);
1387 gfc_pop_error (&old_error
);
1389 m
= match_complex_part (&imag
);
1392 if (m
== MATCH_ERROR
)
1395 m
= gfc_match_char (')');
1398 /* Give the matcher for implied do-loops a chance to run. This
1399 yields a much saner error message for (/ (i, 4=i, 6) /). */
1400 if (gfc_peek_ascii_char () == '=')
1409 if (m
== MATCH_ERROR
)
1412 /* Decide on the kind of this complex number. */
1413 if (real
->ts
.type
== BT_REAL
)
1415 if (imag
->ts
.type
== BT_REAL
)
1416 kind
= gfc_kind_max (real
, imag
);
1418 kind
= real
->ts
.kind
;
1422 if (imag
->ts
.type
== BT_REAL
)
1423 kind
= imag
->ts
.kind
;
1425 kind
= gfc_default_real_kind
;
1427 gfc_clear_ts (&target
);
1428 target
.type
= BT_REAL
;
1431 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1432 gfc_convert_type (real
, &target
, 2);
1433 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1434 gfc_convert_type (imag
, &target
, 2);
1436 e
= gfc_convert_complex (real
, imag
, kind
);
1437 e
->where
= gfc_current_locus
;
1439 gfc_free_expr (real
);
1440 gfc_free_expr (imag
);
1446 gfc_error ("Syntax error in COMPLEX constant at %C");
1451 gfc_free_expr (real
);
1452 gfc_free_expr (imag
);
1453 gfc_current_locus
= old_loc
;
1459 /* Match constants in any of several forms. Returns nonzero for a
1460 match, zero for no match. */
1463 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1467 m
= match_complex_constant (result
);
1471 m
= match_string_constant (result
);
1475 m
= match_boz_constant (result
);
1479 m
= match_real_constant (result
, signflag
);
1483 m
= match_hollerith_constant (result
);
1487 m
= match_integer_constant (result
, signflag
);
1491 m
= match_logical_constant (result
);
1499 /* This checks if a symbol is the return value of an encompassing function.
1500 Function nesting can be maximally two levels deep, but we may have
1501 additional local namespaces like BLOCK etc. */
1504 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1506 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1510 if (ns
->proc_name
== sym
)
1518 /* Match a single actual argument value. An actual argument is
1519 usually an expression, but can also be a procedure name. If the
1520 argument is a single name, it is not always possible to tell
1521 whether the name is a dummy procedure or not. We treat these cases
1522 by creating an argument that looks like a dummy procedure and
1523 fixing things later during resolution. */
1526 match_actual_arg (gfc_expr
**result
)
1528 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1529 gfc_symtree
*symtree
;
1534 gfc_gobble_whitespace ();
1535 where
= gfc_current_locus
;
1537 switch (gfc_match_name (name
))
1546 w
= gfc_current_locus
;
1547 gfc_gobble_whitespace ();
1548 c
= gfc_next_ascii_char ();
1549 gfc_current_locus
= w
;
1551 if (c
!= ',' && c
!= ')')
1554 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1556 /* Handle error elsewhere. */
1558 /* Eliminate a couple of common cases where we know we don't
1559 have a function argument. */
1560 if (symtree
== NULL
)
1562 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1563 gfc_set_sym_referenced (symtree
->n
.sym
);
1569 sym
= symtree
->n
.sym
;
1570 gfc_set_sym_referenced (sym
);
1571 if (sym
->attr
.flavor
== FL_NAMELIST
)
1573 gfc_error ("Namelist %qs can not be an argument at %L",
1577 if (sym
->attr
.flavor
!= FL_PROCEDURE
1578 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1581 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1583 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1584 sym
->name
, &sym
->declared_at
))
1589 /* If the symbol is a function with itself as the result and
1590 is being defined, then we have a variable. */
1591 if (sym
->attr
.function
&& sym
->result
== sym
)
1593 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1597 && (sym
->ns
== gfc_current_ns
1598 || sym
->ns
== gfc_current_ns
->parent
))
1600 gfc_entry_list
*el
= NULL
;
1602 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1612 e
= gfc_get_expr (); /* Leave it unknown for now */
1613 e
->symtree
= symtree
;
1614 e
->expr_type
= EXPR_VARIABLE
;
1615 e
->ts
.type
= BT_PROCEDURE
;
1622 gfc_current_locus
= where
;
1623 return gfc_match_expr (result
);
1627 /* Match a keyword argument or type parameter spec list.. */
1630 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
, bool pdt
)
1632 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1633 gfc_actual_arglist
*a
;
1637 name_locus
= gfc_current_locus
;
1638 m
= gfc_match_name (name
);
1642 if (gfc_match_char ('=') != MATCH_YES
)
1650 if (gfc_match_char ('*') == MATCH_YES
)
1652 actual
->spec_type
= SPEC_ASSUMED
;
1655 else if (gfc_match_char (':') == MATCH_YES
)
1657 actual
->spec_type
= SPEC_DEFERRED
;
1661 actual
->spec_type
= SPEC_EXPLICIT
;
1664 m
= match_actual_arg (&actual
->expr
);
1668 /* Make sure this name has not appeared yet. */
1670 if (name
[0] != '\0')
1672 for (a
= base
; a
; a
= a
->next
)
1673 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1675 gfc_error ("Keyword %qs at %C has already appeared in the "
1676 "current argument list", name
);
1681 actual
->name
= gfc_get_string ("%s", name
);
1685 gfc_current_locus
= name_locus
;
1690 /* Match an argument list function, such as %VAL. */
1693 match_arg_list_function (gfc_actual_arglist
*result
)
1695 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1699 old_locus
= gfc_current_locus
;
1701 if (gfc_match_char ('%') != MATCH_YES
)
1707 m
= gfc_match ("%n (", name
);
1711 if (name
[0] != '\0')
1716 if (gfc_str_startswith (name
, "loc"))
1718 result
->name
= "%LOC";
1723 if (gfc_str_startswith (name
, "ref"))
1725 result
->name
= "%REF";
1730 if (gfc_str_startswith (name
, "val"))
1732 result
->name
= "%VAL";
1742 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1748 m
= match_actual_arg (&result
->expr
);
1752 if (gfc_match_char (')') != MATCH_YES
)
1761 gfc_current_locus
= old_locus
;
1766 /* Matches an actual argument list of a function or subroutine, from
1767 the opening parenthesis to the closing parenthesis. The argument
1768 list is assumed to allow keyword arguments because we don't know if
1769 the symbol associated with the procedure has an implicit interface
1770 or not. We make sure keywords are unique. If sub_flag is set,
1771 we're matching the argument list of a subroutine.
1773 NOTE: An alternative use for this function is to match type parameter
1774 spec lists, which are so similar to actual argument lists that the
1775 machinery can be reused. This use is flagged by the optional argument
1779 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
, bool pdt
)
1781 gfc_actual_arglist
*head
, *tail
;
1783 gfc_st_label
*label
;
1787 *argp
= tail
= NULL
;
1788 old_loc
= gfc_current_locus
;
1792 if (gfc_match_char ('(') == MATCH_NO
)
1793 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1795 if (gfc_match_char (')') == MATCH_YES
)
1800 matching_actual_arglist
++;
1805 head
= tail
= gfc_get_actual_arglist ();
1808 tail
->next
= gfc_get_actual_arglist ();
1812 if (sub_flag
&& !pdt
&& gfc_match_char ('*') == MATCH_YES
)
1814 m
= gfc_match_st_label (&label
);
1816 gfc_error ("Expected alternate return label at %C");
1820 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1824 tail
->label
= label
;
1828 if (pdt
&& !seen_keyword
)
1830 if (gfc_match_char (':') == MATCH_YES
)
1832 tail
->spec_type
= SPEC_DEFERRED
;
1835 else if (gfc_match_char ('*') == MATCH_YES
)
1837 tail
->spec_type
= SPEC_ASSUMED
;
1841 tail
->spec_type
= SPEC_EXPLICIT
;
1843 m
= match_keyword_arg (tail
, head
, pdt
);
1849 if (m
== MATCH_ERROR
)
1853 /* After the first keyword argument is seen, the following
1854 arguments must also have keywords. */
1857 m
= match_keyword_arg (tail
, head
, pdt
);
1859 if (m
== MATCH_ERROR
)
1863 gfc_error ("Missing keyword name in actual argument list at %C");
1870 /* Try an argument list function, like %VAL. */
1871 m
= match_arg_list_function (tail
);
1872 if (m
== MATCH_ERROR
)
1875 /* See if we have the first keyword argument. */
1878 m
= match_keyword_arg (tail
, head
, false);
1881 if (m
== MATCH_ERROR
)
1887 /* Try for a non-keyword argument. */
1888 m
= match_actual_arg (&tail
->expr
);
1889 if (m
== MATCH_ERROR
)
1898 if (gfc_match_char (')') == MATCH_YES
)
1900 if (gfc_match_char (',') != MATCH_YES
)
1905 matching_actual_arglist
--;
1909 gfc_error ("Syntax error in argument list at %C");
1912 gfc_free_actual_arglist (head
);
1913 gfc_current_locus
= old_loc
;
1914 matching_actual_arglist
--;
1919 /* Used by gfc_match_varspec() to extend the reference list by one
1923 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1925 if (primary
->ref
== NULL
)
1926 primary
->ref
= tail
= gfc_get_ref ();
1930 gfc_internal_error ("extend_ref(): Bad tail");
1931 tail
->next
= gfc_get_ref ();
1939 /* Used by gfc_match_varspec() to match an inquiry reference. */
1942 is_inquiry_ref (const char *name
, gfc_ref
**ref
)
1949 if (ref
) *ref
= NULL
;
1951 if (strcmp (name
, "re") == 0)
1953 else if (strcmp (name
, "im") == 0)
1955 else if (strcmp (name
, "kind") == 0)
1956 type
= INQUIRY_KIND
;
1957 else if (strcmp (name
, "len") == 0)
1964 *ref
= gfc_get_ref ();
1965 (*ref
)->type
= REF_INQUIRY
;
1973 /* Match any additional specifications associated with the current
1974 variable like member references or substrings. If equiv_flag is
1975 set we only match stuff that is allowed inside an EQUIVALENCE
1976 statement. sub_flag tells whether we expect a type-bound procedure found
1977 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1978 components, 'ppc_arg' determines whether the PPC may be called (with an
1979 argument list), or whether it may just be referred to as a pointer. */
1982 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1985 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1986 gfc_ref
*substring
, *tail
, *tmp
;
1987 gfc_component
*component
;
1988 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1989 gfc_expr
*tgt_expr
= NULL
;
1998 gfc_gobble_whitespace ();
2000 if (gfc_peek_ascii_char () == '[')
2002 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
2003 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2004 && CLASS_DATA (sym
)->attr
.dimension
))
2006 gfc_error ("Array section designator, e.g. '(:)', is required "
2007 "besides the coarray designator '[...]' at %C");
2010 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
2011 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2012 && !CLASS_DATA (sym
)->attr
.codimension
))
2014 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2020 if (sym
->assoc
&& sym
->assoc
->target
)
2021 tgt_expr
= sym
->assoc
->target
;
2023 /* For associate names, we may not yet know whether they are arrays or not.
2024 If the selector expression is unambiguously an array; eg. a full array
2025 or an array section, then the associate name must be an array and we can
2026 fix it now. Otherwise, if parentheses follow and it is not a character
2027 type, we have to assume that it actually is one for now. The final
2028 decision will be made at resolution, of course. */
2030 && gfc_peek_ascii_char () == '('
2031 && sym
->ts
.type
!= BT_CLASS
2032 && !sym
->attr
.dimension
)
2034 gfc_ref
*ref
= NULL
;
2036 if (!sym
->assoc
->dangling
&& tgt_expr
)
2038 if (tgt_expr
->expr_type
== EXPR_VARIABLE
)
2039 gfc_resolve_expr (tgt_expr
);
2041 ref
= tgt_expr
->ref
;
2042 for (; ref
; ref
= ref
->next
)
2043 if (ref
->type
== REF_ARRAY
2044 && (ref
->u
.ar
.type
== AR_FULL
2045 || ref
->u
.ar
.type
== AR_SECTION
))
2049 if (ref
|| (!(sym
->assoc
->dangling
|| sym
->ts
.type
== BT_CHARACTER
)
2051 && sym
->assoc
->st
->n
.sym
2052 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0))
2054 sym
->attr
.dimension
= 1;
2057 && sym
->assoc
->st
->n
.sym
2058 && sym
->assoc
->st
->n
.sym
->as
)
2059 sym
->as
= gfc_copy_array_spec (sym
->assoc
->st
->n
.sym
->as
);
2062 else if (sym
->ts
.type
== BT_CLASS
2064 && tgt_expr
->expr_type
== EXPR_VARIABLE
2065 && sym
->ts
.u
.derived
!= tgt_expr
->ts
.u
.derived
)
2067 gfc_resolve_expr (tgt_expr
);
2069 sym
->ts
.u
.derived
= tgt_expr
->ts
.u
.derived
;
2072 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
2073 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
2074 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
2075 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
2076 && !(gfc_matching_procptr_assignment
2077 && sym
->attr
.flavor
== FL_PROCEDURE
))
2078 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
2079 && (CLASS_DATA (sym
)->attr
.dimension
2080 || CLASS_DATA (sym
)->attr
.codimension
)))
2084 tail
= extend_ref (primary
, tail
);
2085 tail
->type
= REF_ARRAY
;
2087 /* In EQUIVALENCE, we don't know yet whether we are seeing
2088 an array, character variable or array of character
2089 variables. We'll leave the decision till resolve time. */
2093 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
2094 as
= CLASS_DATA (sym
)->as
;
2098 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
2099 as
? as
->corank
: 0);
2103 gfc_gobble_whitespace ();
2104 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
2106 tail
= extend_ref (primary
, tail
);
2107 tail
->type
= REF_ARRAY
;
2109 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
2115 primary
->ts
= sym
->ts
;
2120 /* With DEC extensions, member separator may be '.' or '%'. */
2121 sep
= gfc_peek_ascii_char ();
2122 m
= gfc_match_member_sep (sym
);
2123 if (m
== MATCH_ERROR
)
2127 if (m
== MATCH_YES
&& sep
== '%'
2128 && primary
->ts
.type
!= BT_CLASS
2129 && primary
->ts
.type
!= BT_DERIVED
)
2132 old_loc
= gfc_current_locus
;
2133 mm
= gfc_match_name (name
);
2134 if (mm
== MATCH_YES
&& is_inquiry_ref (name
, &tmp
))
2136 gfc_current_locus
= old_loc
;
2139 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
2140 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
2141 gfc_set_default_type (sym
, 0, sym
->ns
);
2143 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2144 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
2148 /* These target expressions can be resolved at any time. */
2149 permissible
= tgt_expr
&& tgt_expr
->symtree
&& tgt_expr
->symtree
->n
.sym
2150 && (tgt_expr
->symtree
->n
.sym
->attr
.use_assoc
2151 || tgt_expr
->symtree
->n
.sym
->attr
.host_assoc
2152 || tgt_expr
->symtree
->n
.sym
->attr
.if_source
2154 permissible
= permissible
2155 || (tgt_expr
&& tgt_expr
->expr_type
== EXPR_OP
);
2159 gfc_resolve_expr (tgt_expr
);
2160 sym
->ts
= tgt_expr
->ts
;
2163 if (sym
->ts
.type
== BT_UNKNOWN
)
2165 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
2169 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2170 && m
== MATCH_YES
&& !inquiry
)
2172 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2177 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
&& !inquiry
)
2179 goto check_substring
;
2182 sym
= sym
->ts
.u
.derived
;
2191 m
= gfc_match_name (name
);
2193 gfc_error ("Expected structure component name at %C");
2197 if (primary
->ts
.type
!= BT_CLASS
&& primary
->ts
.type
!= BT_DERIVED
)
2199 inquiry
= is_inquiry_ref (name
, &tmp
);
2206 if (sym
&& sym
->f2k_derived
)
2207 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2213 gfc_symbol
* tbp_sym
;
2218 gcc_assert (!tail
|| !tail
->next
);
2220 if (!(primary
->expr_type
== EXPR_VARIABLE
2221 || (primary
->expr_type
== EXPR_STRUCTURE
2222 && primary
->symtree
&& primary
->symtree
->n
.sym
2223 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2226 if (tbp
->n
.tb
->is_generic
)
2229 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2231 primary
->expr_type
= EXPR_COMPCALL
;
2232 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2233 primary
->value
.compcall
.name
= tbp
->name
;
2234 primary
->value
.compcall
.ignore_pass
= 0;
2235 primary
->value
.compcall
.assign
= 0;
2236 primary
->value
.compcall
.base_object
= NULL
;
2237 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2239 primary
->ts
= tbp_sym
->ts
;
2241 gfc_clear_ts (&primary
->ts
);
2243 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2244 &primary
->value
.compcall
.actual
);
2245 if (m
== MATCH_ERROR
)
2250 primary
->value
.compcall
.actual
= NULL
;
2253 gfc_error ("Expected argument list at %C");
2262 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2266 if (component
== NULL
&& !inquiry
)
2269 /* Extend the reference chain determined by gfc_find_component or
2271 if (primary
->ref
== NULL
)
2275 /* Set by the for loop below for the last component ref. */
2276 gcc_assert (tail
!= NULL
);
2280 /* The reference chain may be longer than one hop for union
2281 subcomponents; find the new tail. */
2282 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2285 if (tmp
&& tmp
->type
== REF_INQUIRY
)
2287 gfc_simplify_expr (primary
, 0);
2289 if (primary
->expr_type
== EXPR_CONSTANT
)
2296 if (!gfc_notify_std (GFC_STD_F2008
, "RE or IM part_ref at %C"))
2299 if (primary
->ts
.type
!= BT_COMPLEX
)
2301 gfc_error ("The RE or IM part_ref at %C must be "
2302 "applied to a COMPLEX expression");
2305 primary
->ts
.type
= BT_REAL
;
2309 if (!gfc_notify_std (GFC_STD_F2003
, "LEN part_ref at %C"))
2312 if (primary
->ts
.type
!= BT_CHARACTER
)
2314 gfc_error ("The LEN part_ref at %C must be applied "
2315 "to a CHARACTER expression");
2318 primary
->ts
.u
.cl
= NULL
;
2319 primary
->ts
.type
= BT_INTEGER
;
2320 primary
->ts
.kind
= gfc_default_integer_kind
;
2324 if (!gfc_notify_std (GFC_STD_F2003
, "KIND part_ref at %C"))
2327 if (primary
->ts
.type
== BT_CLASS
2328 || primary
->ts
.type
== BT_DERIVED
)
2330 gfc_error ("The KIND part_ref at %C must be applied "
2331 "to an expression of intrinsic type");
2334 primary
->ts
.type
= BT_INTEGER
;
2335 primary
->ts
.kind
= gfc_default_integer_kind
;
2345 primary
->ts
= component
->ts
;
2347 if (component
->attr
.proc_pointer
&& ppc_arg
)
2349 /* Procedure pointer component call: Look for argument list. */
2350 m
= gfc_match_actual_arglist (sub_flag
,
2351 &primary
->value
.compcall
.actual
);
2352 if (m
== MATCH_ERROR
)
2355 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2356 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2358 gfc_error ("Procedure pointer component %qs requires an "
2359 "argument list at %C", component
->name
);
2364 primary
->expr_type
= EXPR_PPC
;
2369 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2371 tail
= extend_ref (primary
, tail
);
2372 tail
->type
= REF_ARRAY
;
2374 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2375 component
->as
->corank
);
2379 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2380 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2382 tail
= extend_ref (primary
, tail
);
2383 tail
->type
= REF_ARRAY
;
2385 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2387 CLASS_DATA (component
)->as
->corank
);
2393 /* In principle, we could have eg. expr%re%kind so we must allow for
2394 this possibility. */
2395 if (gfc_match_char ('%') == MATCH_YES
)
2397 if (component
&& (component
->ts
.type
== BT_DERIVED
2398 || component
->ts
.type
== BT_CLASS
))
2399 sym
= component
->ts
.u
.derived
;
2405 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2406 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2409 if (component
->ts
.type
== BT_DERIVED
|| component
->ts
.type
== BT_CLASS
)
2410 sym
= component
->ts
.u
.derived
;
2415 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2417 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2419 gfc_set_default_type (sym
, 0, sym
->ns
);
2420 primary
->ts
= sym
->ts
;
2425 if (primary
->ts
.type
== BT_CHARACTER
)
2427 bool def
= primary
->ts
.deferred
== 1;
2428 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2432 primary
->ref
= substring
;
2434 tail
->next
= substring
;
2436 if (primary
->expr_type
== EXPR_CONSTANT
)
2437 primary
->expr_type
= EXPR_SUBSTRING
;
2440 primary
->ts
.u
.cl
= NULL
;
2447 gfc_clear_ts (&primary
->ts
);
2448 gfc_clear_ts (&sym
->ts
);
2458 if (primary
->ts
.type
== BT_DERIVED
&& primary
->ref
2459 && primary
->ts
.u
.derived
&& primary
->ts
.u
.derived
->attr
.abstract
)
2461 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2466 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2468 gfc_error ("Coindexed procedure-pointer component at %C");
2476 /* Given an expression that is a variable, figure out what the
2477 ultimate variable's type and attribute is, traversing the reference
2478 structures if necessary.
2480 This subroutine is trickier than it looks. We start at the base
2481 symbol and store the attribute. Component references load a
2482 completely new attribute.
2484 A couple of rules come into play. Subobjects of targets are always
2485 targets themselves. If we see a component that goes through a
2486 pointer, then the expression must also be a target, since the
2487 pointer is associated with something (if it isn't core will soon be
2488 dumped). If we see a full part or section of an array, the
2489 expression is also an array.
2491 We can have at most one full array reference. */
2494 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2496 int dimension
, codimension
, pointer
, allocatable
, target
;
2497 symbol_attribute attr
;
2500 gfc_component
*comp
;
2501 bool has_inquiry_part
;
2503 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2504 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2506 sym
= expr
->symtree
->n
.sym
;
2509 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2511 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2512 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2513 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2514 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2518 dimension
= attr
.dimension
;
2519 codimension
= attr
.codimension
;
2520 pointer
= attr
.pointer
;
2521 allocatable
= attr
.allocatable
;
2524 target
= attr
.target
;
2525 if (pointer
|| attr
.proc_pointer
)
2528 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2531 has_inquiry_part
= false;
2532 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2533 if (ref
->type
== REF_INQUIRY
)
2535 has_inquiry_part
= true;
2539 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2544 switch (ref
->u
.ar
.type
)
2551 allocatable
= pointer
= 0;
2556 /* Handle coarrays. */
2557 if (ref
->u
.ar
.dimen
> 0)
2558 allocatable
= pointer
= 0;
2562 /* If any of start, end or stride is not integer, there will
2563 already have been an error issued. */
2565 gfc_get_errors (NULL
, &errors
);
2567 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2573 comp
= ref
->u
.c
.component
;
2575 if (ts
!= NULL
&& !has_inquiry_part
)
2578 /* Don't set the string length if a substring reference
2580 if (ts
->type
== BT_CHARACTER
2581 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2585 if (comp
->ts
.type
== BT_CLASS
)
2587 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2588 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2589 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2593 codimension
= comp
->attr
.codimension
;
2594 pointer
= comp
->attr
.pointer
;
2595 allocatable
= comp
->attr
.allocatable
;
2597 if (pointer
|| attr
.proc_pointer
)
2604 allocatable
= pointer
= 0;
2608 attr
.dimension
= dimension
;
2609 attr
.codimension
= codimension
;
2610 attr
.pointer
= pointer
;
2611 attr
.allocatable
= allocatable
;
2612 attr
.target
= target
;
2613 attr
.save
= sym
->attr
.save
;
2619 /* Return the attribute from a general expression. */
2622 gfc_expr_attr (gfc_expr
*e
)
2624 symbol_attribute attr
;
2626 switch (e
->expr_type
)
2629 attr
= gfc_variable_attr (e
, NULL
);
2633 gfc_clear_attr (&attr
);
2635 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2637 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2639 if (sym
->ts
.type
== BT_CLASS
)
2641 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2642 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2643 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2646 else if (e
->value
.function
.isym
2647 && e
->value
.function
.isym
->transformational
2648 && e
->ts
.type
== BT_CLASS
)
2649 attr
= CLASS_DATA (e
)->attr
;
2651 attr
= gfc_variable_attr (e
, NULL
);
2653 /* TODO: NULL() returns pointers. May have to take care of this
2659 gfc_clear_attr (&attr
);
2667 /* Given an expression, figure out what the ultimate expression
2668 attribute is. This routine is similar to gfc_variable_attr with
2669 parts of gfc_expr_attr, but focuses more on the needs of
2670 coarrays. For coarrays a codimension attribute is kind of
2671 "infectious" being propagated once set and never cleared.
2672 The coarray_comp is only set, when the expression refs a coarray
2673 component. REFS_COMP is set when present to true only, when this EXPR
2674 refs a (non-_data) component. To check whether EXPR refs an allocatable
2675 component in a derived type coarray *refs_comp needs to be set and
2676 coarray_comp has to false. */
2678 static symbol_attribute
2679 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
, bool *refs_comp
)
2681 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
;
2682 symbol_attribute attr
;
2685 gfc_component
*comp
;
2687 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2688 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2690 sym
= expr
->symtree
->n
.sym
;
2691 gfc_clear_attr (&attr
);
2696 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2698 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2699 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2700 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2701 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2702 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2703 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pointer_comp
;
2707 dimension
= sym
->attr
.dimension
;
2708 codimension
= sym
->attr
.codimension
;
2709 pointer
= sym
->attr
.pointer
;
2710 allocatable
= sym
->attr
.allocatable
;
2711 attr
.alloc_comp
= sym
->ts
.type
== BT_DERIVED
2712 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2713 attr
.pointer_comp
= sym
->ts
.type
== BT_DERIVED
2714 ? sym
->ts
.u
.derived
->attr
.pointer_comp
: 0;
2717 target
= coarray_comp
= 0;
2718 if (pointer
|| attr
.proc_pointer
)
2721 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2726 switch (ref
->u
.ar
.type
)
2734 /* Handle coarrays. */
2735 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2736 allocatable
= pointer
= 0;
2740 /* If any of start, end or stride is not integer, there will
2741 already have been an error issued. */
2743 gfc_get_errors (NULL
, &errors
);
2745 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2751 comp
= ref
->u
.c
.component
;
2753 if (comp
->ts
.type
== BT_CLASS
)
2755 /* Set coarray_comp only, when this component introduces the
2757 coarray_comp
= !codimension
&& CLASS_DATA (comp
)->attr
.codimension
;
2758 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2759 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2760 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2764 /* Set coarray_comp only, when this component introduces the
2766 coarray_comp
= !codimension
&& comp
->attr
.codimension
;
2767 codimension
|= comp
->attr
.codimension
;
2768 pointer
= comp
->attr
.pointer
;
2769 allocatable
= comp
->attr
.allocatable
;
2772 if (refs_comp
&& strcmp (comp
->name
, "_data") != 0
2773 && (ref
->next
== NULL
2774 || (ref
->next
->type
== REF_ARRAY
&& ref
->next
->next
== NULL
)))
2777 if (pointer
|| attr
.proc_pointer
)
2784 allocatable
= pointer
= 0;
2788 attr
.dimension
= dimension
;
2789 attr
.codimension
= codimension
;
2790 attr
.pointer
= pointer
;
2791 attr
.allocatable
= allocatable
;
2792 attr
.target
= target
;
2793 attr
.save
= sym
->attr
.save
;
2794 attr
.coarray_comp
= coarray_comp
;
2801 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
, bool *refs_comp
)
2803 symbol_attribute attr
;
2805 switch (e
->expr_type
)
2808 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2812 gfc_clear_attr (&attr
);
2814 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2816 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2818 if (sym
->ts
.type
== BT_CLASS
)
2820 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2821 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2822 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2823 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2824 attr
.pointer_comp
= CLASS_DATA (sym
)->ts
.u
.derived
2825 ->attr
.pointer_comp
;
2828 else if (e
->symtree
)
2829 attr
= caf_variable_attr (e
, in_allocate
, refs_comp
);
2831 gfc_clear_attr (&attr
);
2835 gfc_clear_attr (&attr
);
2843 /* Match a structure constructor. The initial symbol has already been
2846 typedef struct gfc_structure_ctor_component
2851 struct gfc_structure_ctor_component
* next
;
2853 gfc_structure_ctor_component
;
2855 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2858 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2861 gfc_free_expr (comp
->val
);
2866 /* Translate the component list into the actual constructor by sorting it in
2867 the order required; this also checks along the way that each and every
2868 component actually has an initializer and handles default initializers
2869 for components without explicit value given. */
2871 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2872 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2874 gfc_structure_ctor_component
*comp_iter
;
2875 gfc_component
*comp
;
2877 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2879 gfc_structure_ctor_component
**next_ptr
;
2880 gfc_expr
*value
= NULL
;
2882 /* Try to find the initializer for the current component by name. */
2883 next_ptr
= comp_head
;
2884 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2886 if (!strcmp (comp_iter
->name
, comp
->name
))
2888 next_ptr
= &comp_iter
->next
;
2891 /* If an extension, try building the parent derived type by building
2892 a value expression for the parent derived type and calling self. */
2893 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2895 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2897 &gfc_current_locus
);
2898 value
->ts
= comp
->ts
;
2900 if (!build_actual_constructor (comp_head
,
2901 &value
->value
.constructor
,
2902 comp
->ts
.u
.derived
))
2904 gfc_free_expr (value
);
2908 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2912 /* If it was not found, try the default initializer if there's any;
2913 otherwise, it's an error unless this is a deferred parameter. */
2916 if (comp
->initializer
)
2918 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2919 "with missing optional arguments at %C"))
2921 value
= gfc_copy_expr (comp
->initializer
);
2923 else if (comp
->attr
.allocatable
2924 || (comp
->ts
.type
== BT_CLASS
2925 && CLASS_DATA (comp
)->attr
.allocatable
))
2927 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2928 "allocatable component %qs given in the "
2929 "structure constructor at %C", comp
->name
))
2932 else if (!comp
->attr
.artificial
)
2934 gfc_error ("No initializer for component %qs given in the"
2935 " structure constructor at %C", comp
->name
);
2940 value
= comp_iter
->val
;
2942 /* Add the value to the constructor chain built. */
2943 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2945 /* Remove the entry from the component list. We don't want the expression
2946 value to be free'd, so set it to NULL. */
2949 *next_ptr
= comp_iter
->next
;
2950 comp_iter
->val
= NULL
;
2951 gfc_free_structure_ctor_component (comp_iter
);
2959 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2960 gfc_actual_arglist
**arglist
,
2963 gfc_actual_arglist
*actual
;
2964 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2965 gfc_constructor_base ctor_head
= NULL
;
2966 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2967 const char* last_name
= NULL
;
2971 expr
= parent
? *cexpr
: e
;
2972 old_locus
= gfc_current_locus
;
2974 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2976 gfc_current_locus
= expr
->where
;
2978 comp_tail
= comp_head
= NULL
;
2980 if (!parent
&& sym
->attr
.abstract
)
2982 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2983 sym
->name
, &expr
->where
);
2987 comp
= sym
->components
;
2988 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2991 gfc_component
*this_comp
= NULL
;
2994 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2997 comp_tail
->next
= gfc_get_structure_ctor_component ();
2998 comp_tail
= comp_tail
->next
;
3002 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
3003 " constructor with named arguments at %C"))
3006 comp_tail
->name
= xstrdup (actual
->name
);
3007 last_name
= comp_tail
->name
;
3012 /* Components without name are not allowed after the first named
3013 component initializer! */
3014 if (!comp
|| comp
->attr
.artificial
)
3017 gfc_error ("Component initializer without name after component"
3018 " named %s at %L", last_name
,
3019 actual
->expr
? &actual
->expr
->where
3020 : &gfc_current_locus
);
3022 gfc_error ("Too many components in structure constructor at "
3023 "%L", actual
->expr
? &actual
->expr
->where
3024 : &gfc_current_locus
);
3028 comp_tail
->name
= xstrdup (comp
->name
);
3031 /* Find the current component in the structure definition and check
3032 its access is not private. */
3034 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
3037 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
3038 false, false, NULL
);
3039 comp
= NULL
; /* Reset needed! */
3042 /* Here we can check if a component name is given which does not
3043 correspond to any component of the defined structure. */
3047 /* For a constant string constructor, make sure the length is
3048 correct; truncate of fill with blanks if needed. */
3049 if (this_comp
->ts
.type
== BT_CHARACTER
&& !this_comp
->attr
.allocatable
3050 && this_comp
->ts
.u
.cl
&& this_comp
->ts
.u
.cl
->length
3051 && this_comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
3052 && actual
->expr
->ts
.type
== BT_CHARACTER
3053 && actual
->expr
->expr_type
== EXPR_CONSTANT
)
3056 c
= gfc_mpz_get_hwi (this_comp
->ts
.u
.cl
->length
->value
.integer
);
3057 e
= actual
->expr
->value
.character
.length
;
3063 dest
= gfc_get_wide_string (c
+ 1);
3066 for (i
= 0; i
< to
; i
++)
3067 dest
[i
] = actual
->expr
->value
.character
.string
[i
];
3069 for (i
= e
; i
< c
; i
++)
3073 free (actual
->expr
->value
.character
.string
);
3075 actual
->expr
->value
.character
.length
= c
;
3076 actual
->expr
->value
.character
.string
= dest
;
3080 comp_tail
->val
= actual
->expr
;
3081 if (actual
->expr
!= NULL
)
3082 comp_tail
->where
= actual
->expr
->where
;
3083 actual
->expr
= NULL
;
3085 /* Check if this component is already given a value. */
3086 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
3087 comp_iter
= comp_iter
->next
)
3089 gcc_assert (comp_iter
);
3090 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
3092 gfc_error ("Component %qs is initialized twice in the structure"
3093 " constructor at %L", comp_tail
->name
,
3094 comp_tail
->val
? &comp_tail
->where
3095 : &gfc_current_locus
);
3100 /* F2008, R457/C725, for PURE C1283. */
3101 if (this_comp
->attr
.pointer
&& comp_tail
->val
3102 && gfc_is_coindexed (comp_tail
->val
))
3104 gfc_error ("Coindexed expression to pointer component %qs in "
3105 "structure constructor at %L", comp_tail
->name
,
3110 /* If not explicitly a parent constructor, gather up the components
3112 if (comp
&& comp
== sym
->components
3113 && sym
->attr
.extension
3115 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
3117 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
3120 gfc_actual_arglist
*arg_null
= NULL
;
3122 actual
->expr
= comp_tail
->val
;
3123 comp_tail
->val
= NULL
;
3125 m
= gfc_convert_to_structure_constructor (NULL
,
3126 comp
->ts
.u
.derived
, &comp_tail
->val
,
3127 comp
->ts
.u
.derived
->attr
.zero_comp
3128 ? &arg_null
: &actual
, true);
3132 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
3141 if (parent
&& !comp
)
3145 actual
= actual
->next
;
3148 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
3151 /* No component should be left, as this should have caused an error in the
3152 loop constructing the component-list (name that does not correspond to any
3153 component in the structure definition). */
3154 if (comp_head
&& sym
->attr
.extension
)
3156 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
3158 gfc_error ("component %qs at %L has already been set by a "
3159 "parent derived type constructor", comp_iter
->name
,
3165 gcc_assert (!comp_head
);
3169 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
3170 expr
->ts
.u
.derived
= sym
;
3171 expr
->value
.constructor
= ctor_head
;
3176 expr
->ts
.u
.derived
= sym
;
3178 expr
->ts
.type
= BT_DERIVED
;
3179 expr
->value
.constructor
= ctor_head
;
3180 expr
->expr_type
= EXPR_STRUCTURE
;
3183 gfc_current_locus
= old_locus
;
3189 gfc_current_locus
= old_locus
;
3191 for (comp_iter
= comp_head
; comp_iter
; )
3193 gfc_structure_ctor_component
*next
= comp_iter
->next
;
3194 gfc_free_structure_ctor_component (comp_iter
);
3197 gfc_constructor_free (ctor_head
);
3204 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
3208 gfc_symtree
*symtree
;
3210 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
3212 e
= gfc_get_expr ();
3213 e
->symtree
= symtree
;
3214 e
->expr_type
= EXPR_FUNCTION
;
3215 e
->where
= gfc_current_locus
;
3217 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
3218 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
3219 e
->value
.function
.esym
= sym
;
3220 e
->symtree
->n
.sym
->attr
.generic
= 1;
3222 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3229 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
3235 /* If a structure constructor is in a DATA statement, then each entity
3236 in the structure constructor must be a constant. Try to reduce the
3238 if (gfc_in_match_data ())
3239 gfc_reduce_init_expr (e
);
3246 /* If the symbol is an implicit do loop index and implicitly typed,
3247 it should not be host associated. Provide a symtree from the
3248 current namespace. */
3250 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
3252 if ((*sym
)->attr
.flavor
== FL_VARIABLE
3253 && (*sym
)->ns
!= gfc_current_ns
3254 && (*sym
)->attr
.implied_index
3255 && (*sym
)->attr
.implicit_type
3256 && !(*sym
)->attr
.use_assoc
)
3259 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
3262 *sym
= (*st
)->n
.sym
;
3268 /* Procedure pointer as function result: Replace the function symbol by the
3269 auto-generated hidden result variable named "ppr@". */
3272 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
3274 /* Check for procedure pointer result variable. */
3275 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
3276 && (*sym
)->result
&& (*sym
)->result
!= *sym
3277 && (*sym
)->result
->attr
.proc_pointer
3278 && (*sym
) == gfc_current_ns
->proc_name
3279 && (*sym
) == (*sym
)->result
->ns
->proc_name
3280 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
3282 /* Automatic replacement with "hidden" result variable. */
3283 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
3284 *sym
= (*sym
)->result
;
3285 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
3292 /* Matches a variable name followed by anything that might follow it--
3293 array reference, argument list of a function, etc. */
3296 gfc_match_rvalue (gfc_expr
**result
)
3298 gfc_actual_arglist
*actual_arglist
;
3299 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
3302 gfc_symtree
*symtree
;
3303 locus where
, old_loc
;
3311 m
= gfc_match ("%%loc");
3314 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
3316 strncpy (name
, "loc", 4);
3321 m
= gfc_match_name (name
);
3326 /* Check if the symbol exists. */
3327 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
3330 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3331 type. For derived types we create a generic symbol which links to the
3332 derived type symbol; STRUCTUREs are simpler and must not conflict with
3335 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3337 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3339 if (gfc_find_state (COMP_INTERFACE
)
3340 && !gfc_current_ns
->has_import_set
)
3341 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3343 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3349 sym
= symtree
->n
.sym
;
3351 where
= gfc_current_locus
;
3353 replace_hidden_procptr_result (&sym
, &symtree
);
3355 /* If this is an implicit do loop index and implicitly typed,
3356 it should not be host associated. */
3357 m
= check_for_implicit_index (&symtree
, &sym
);
3361 gfc_set_sym_referenced (sym
);
3362 sym
->attr
.implied_index
= 0;
3364 if (sym
->attr
.function
&& sym
->result
== sym
)
3366 /* See if this is a directly recursive function call. */
3367 gfc_gobble_whitespace ();
3368 if (sym
->attr
.recursive
3369 && gfc_peek_ascii_char () == '('
3370 && gfc_current_ns
->proc_name
== sym
3371 && !sym
->attr
.dimension
)
3373 gfc_error ("%qs at %C is the name of a recursive function "
3374 "and so refers to the result variable. Use an "
3375 "explicit RESULT variable for direct recursion "
3376 "(12.5.2.1)", sym
->name
);
3380 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3384 && (sym
->ns
== gfc_current_ns
3385 || sym
->ns
== gfc_current_ns
->parent
))
3387 gfc_entry_list
*el
= NULL
;
3389 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3395 if (gfc_matching_procptr_assignment
)
3398 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3401 if (sym
->attr
.generic
)
3402 goto generic_function
;
3404 switch (sym
->attr
.flavor
)
3408 e
= gfc_get_expr ();
3410 e
->expr_type
= EXPR_VARIABLE
;
3411 e
->symtree
= symtree
;
3413 m
= gfc_match_varspec (e
, 0, false, true);
3417 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3418 end up here. Unfortunately, sym->value->expr_type is set to
3419 EXPR_CONSTANT, and so the if () branch would be followed without
3420 the !sym->as check. */
3421 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3422 e
= gfc_copy_expr (sym
->value
);
3425 e
= gfc_get_expr ();
3426 e
->expr_type
= EXPR_VARIABLE
;
3429 e
->symtree
= symtree
;
3430 m
= gfc_match_varspec (e
, 0, false, true);
3432 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3435 /* Variable array references to derived type parameters cause
3436 all sorts of headaches in simplification. Treating such
3437 expressions as variable works just fine for all array
3439 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3441 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3442 if (ref
->type
== REF_ARRAY
)
3445 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3451 e
= gfc_get_expr ();
3452 e
->expr_type
= EXPR_VARIABLE
;
3453 e
->symtree
= symtree
;
3461 sym
= gfc_use_derived (sym
);
3465 goto generic_function
;
3468 /* If we're here, then the name is known to be the name of a
3469 procedure, yet it is not sure to be the name of a function. */
3472 /* Procedure Pointer Assignments. */
3474 if (gfc_matching_procptr_assignment
)
3476 gfc_gobble_whitespace ();
3477 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3478 /* Parse functions returning a procptr. */
3481 e
= gfc_get_expr ();
3482 e
->expr_type
= EXPR_VARIABLE
;
3483 e
->symtree
= symtree
;
3484 m
= gfc_match_varspec (e
, 0, false, true);
3485 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3486 && sym
->ts
.type
== BT_UNKNOWN
3487 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3495 if (sym
->attr
.subroutine
)
3497 gfc_error ("Unexpected use of subroutine name %qs at %C",
3503 /* At this point, the name has to be a non-statement function.
3504 If the name is the same as the current function being
3505 compiled, then we have a variable reference (to the function
3506 result) if the name is non-recursive. */
3508 st
= gfc_enclosing_unit (NULL
);
3511 && st
->state
== COMP_FUNCTION
3513 && !sym
->attr
.recursive
)
3515 e
= gfc_get_expr ();
3516 e
->symtree
= symtree
;
3517 e
->expr_type
= EXPR_VARIABLE
;
3519 m
= gfc_match_varspec (e
, 0, false, true);
3523 /* Match a function reference. */
3525 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3528 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3529 gfc_error ("Statement function %qs requires argument list at %C",
3532 gfc_error ("Function %qs requires an argument list at %C",
3545 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3546 sym
= symtree
->n
.sym
;
3548 replace_hidden_procptr_result (&sym
, &symtree
);
3550 e
= gfc_get_expr ();
3551 e
->symtree
= symtree
;
3552 e
->expr_type
= EXPR_FUNCTION
;
3553 e
->value
.function
.actual
= actual_arglist
;
3554 e
->where
= gfc_current_locus
;
3556 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3557 && CLASS_DATA (sym
)->as
)
3558 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3559 else if (sym
->as
!= NULL
)
3560 e
->rank
= sym
->as
->rank
;
3562 if (!sym
->attr
.function
3563 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3569 /* Check here for the existence of at least one argument for the
3570 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3571 argument(s) given will be checked in gfc_iso_c_func_interface,
3572 during resolution of the function call. */
3573 if (sym
->attr
.is_iso_c
== 1
3574 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3575 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3576 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3577 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3579 /* make sure we were given a param */
3580 if (actual_arglist
== NULL
)
3582 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3588 if (sym
->result
== NULL
)
3591 gfc_gobble_whitespace ();
3593 if (gfc_peek_ascii_char() == '%')
3595 gfc_error ("The leftmost part-ref in a data-ref can not be a "
3596 "function reference at %C");
3605 /* Special case for derived type variables that get their types
3606 via an IMPLICIT statement. This can't wait for the
3607 resolution phase. */
3609 old_loc
= gfc_current_locus
;
3610 if (gfc_match_member_sep (sym
) == MATCH_YES
3611 && sym
->ts
.type
== BT_UNKNOWN
3612 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3613 gfc_set_default_type (sym
, 0, sym
->ns
);
3614 gfc_current_locus
= old_loc
;
3616 /* If the symbol has a (co)dimension attribute, the expression is a
3619 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3621 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3627 e
= gfc_get_expr ();
3628 e
->symtree
= symtree
;
3629 e
->expr_type
= EXPR_VARIABLE
;
3630 m
= gfc_match_varspec (e
, 0, false, true);
3634 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3635 && (CLASS_DATA (sym
)->attr
.dimension
3636 || CLASS_DATA (sym
)->attr
.codimension
))
3638 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3644 e
= gfc_get_expr ();
3645 e
->symtree
= symtree
;
3646 e
->expr_type
= EXPR_VARIABLE
;
3647 m
= gfc_match_varspec (e
, 0, false, true);
3651 /* Name is not an array, so we peek to see if a '(' implies a
3652 function call or a substring reference. Otherwise the
3653 variable is just a scalar. */
3655 gfc_gobble_whitespace ();
3656 if (gfc_peek_ascii_char () != '(')
3658 /* Assume a scalar variable */
3659 e
= gfc_get_expr ();
3660 e
->symtree
= symtree
;
3661 e
->expr_type
= EXPR_VARIABLE
;
3663 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3669 /*FIXME:??? gfc_match_varspec does set this for us: */
3671 m
= gfc_match_varspec (e
, 0, false, true);
3675 /* See if this is a function reference with a keyword argument
3676 as first argument. We do this because otherwise a spurious
3677 symbol would end up in the symbol table. */
3679 old_loc
= gfc_current_locus
;
3680 m2
= gfc_match (" ( %n =", argname
);
3681 gfc_current_locus
= old_loc
;
3683 e
= gfc_get_expr ();
3684 e
->symtree
= symtree
;
3686 if (m2
!= MATCH_YES
)
3688 /* Try to figure out whether we're dealing with a character type.
3689 We're peeking ahead here, because we don't want to call
3690 match_substring if we're dealing with an implicitly typed
3691 non-character variable. */
3692 implicit_char
= false;
3693 if (sym
->ts
.type
== BT_UNKNOWN
)
3695 ts
= gfc_get_default_type (sym
->name
, NULL
);
3696 if (ts
->type
== BT_CHARACTER
)
3697 implicit_char
= true;
3700 /* See if this could possibly be a substring reference of a name
3701 that we're not sure is a variable yet. */
3703 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3704 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3707 e
->expr_type
= EXPR_VARIABLE
;
3709 if (sym
->attr
.flavor
!= FL_VARIABLE
3710 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3717 if (sym
->ts
.type
== BT_UNKNOWN
3718 && !gfc_set_default_type (sym
, 1, NULL
))
3732 /* Give up, assume we have a function. */
3734 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3735 sym
= symtree
->n
.sym
;
3736 e
->expr_type
= EXPR_FUNCTION
;
3738 if (!sym
->attr
.function
3739 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3747 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3749 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3757 /* If our new function returns a character, array or structure
3758 type, it might have subsequent references. */
3760 m
= gfc_match_varspec (e
, 0, false, true);
3767 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3768 specially. Creates a generic symbol for derived types. */
3769 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3771 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3772 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3773 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3775 e
= gfc_get_expr ();
3776 e
->symtree
= symtree
;
3777 e
->expr_type
= EXPR_FUNCTION
;
3779 if (gfc_fl_struct (sym
->attr
.flavor
))
3781 e
->value
.function
.esym
= sym
;
3782 e
->symtree
->n
.sym
->attr
.generic
= 1;
3785 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3793 gfc_error ("Symbol at %C is not appropriate for an expression");
3809 /* Match a variable, i.e. something that can be assigned to. This
3810 starts as a symbol, can be a structure component or an array
3811 reference. It can be a function if the function doesn't have a
3812 separate RESULT variable. If the symbol has not been previously
3813 seen, we assume it is a variable.
3815 This function is called by two interface functions:
3816 gfc_match_variable, which has host_flag = 1, and
3817 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3818 match of the symbol to the local scope. */
3821 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3823 gfc_symbol
*sym
, *dt_sym
;
3826 locus where
, old_loc
;
3829 /* Since nothing has any business being an lvalue in a module
3830 specification block, an interface block or a contains section,
3831 we force the changed_symbols mechanism to work by setting
3832 host_flag to 0. This prevents valid symbols that have the name
3833 of keywords, such as 'end', being turned into variables by
3834 failed matching to assignments for, e.g., END INTERFACE. */
3835 if (gfc_current_state () == COMP_MODULE
3836 || gfc_current_state () == COMP_SUBMODULE
3837 || gfc_current_state () == COMP_INTERFACE
3838 || gfc_current_state () == COMP_CONTAINS
)
3841 where
= gfc_current_locus
;
3842 m
= gfc_match_sym_tree (&st
, host_flag
);
3848 /* If this is an implicit do loop index and implicitly typed,
3849 it should not be host associated. */
3850 m
= check_for_implicit_index (&st
, &sym
);
3854 sym
->attr
.implied_index
= 0;
3856 gfc_set_sym_referenced (sym
);
3858 /* STRUCTUREs may share names with variables, but derived types may not. */
3859 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3860 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3862 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3863 gfc_error ("Derived type %qs cannot be used as a variable at %C",
3868 switch (sym
->attr
.flavor
)
3871 /* Everything is alright. */
3876 sym_flavor flavor
= FL_UNKNOWN
;
3878 gfc_gobble_whitespace ();
3880 if (sym
->attr
.external
|| sym
->attr
.procedure
3881 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3882 flavor
= FL_PROCEDURE
;
3884 /* If it is not a procedure, is not typed and is host associated,
3885 we cannot give it a flavor yet. */
3886 else if (sym
->ns
== gfc_current_ns
->parent
3887 && sym
->ts
.type
== BT_UNKNOWN
)
3890 /* These are definitive indicators that this is a variable. */
3891 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3892 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3893 flavor
= FL_VARIABLE
;
3895 if (flavor
!= FL_UNKNOWN
3896 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3904 gfc_error ("Named constant at %C in an EQUIVALENCE");
3907 /* Otherwise this is checked for and an error given in the
3908 variable definition context checks. */
3912 /* Check for a nonrecursive function result variable. */
3913 if (sym
->attr
.function
3914 && !sym
->attr
.external
3915 && sym
->result
== sym
3916 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3918 && sym
->ns
== gfc_current_ns
)
3920 && sym
->ns
== gfc_current_ns
->parent
)))
3922 /* If a function result is a derived type, then the derived
3923 type may still have to be resolved. */
3925 if (sym
->ts
.type
== BT_DERIVED
3926 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3931 if (sym
->attr
.proc_pointer
3932 || replace_hidden_procptr_result (&sym
, &st
))
3935 /* Fall through to error */
3939 gfc_error ("%qs at %C is not a variable", sym
->name
);
3943 /* Special case for derived type variables that get their types
3944 via an IMPLICIT statement. This can't wait for the
3945 resolution phase. */
3948 gfc_namespace
* implicit_ns
;
3950 if (gfc_current_ns
->proc_name
== sym
)
3951 implicit_ns
= gfc_current_ns
;
3953 implicit_ns
= sym
->ns
;
3955 old_loc
= gfc_current_locus
;
3956 if (gfc_match_member_sep (sym
) == MATCH_YES
3957 && sym
->ts
.type
== BT_UNKNOWN
3958 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3959 gfc_set_default_type (sym
, 0, implicit_ns
);
3960 gfc_current_locus
= old_loc
;
3963 expr
= gfc_get_expr ();
3965 expr
->expr_type
= EXPR_VARIABLE
;
3968 expr
->where
= where
;
3970 /* Now see if we have to do more. */
3971 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3974 gfc_free_expr (expr
);
3984 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3986 return match_variable (result
, equiv_flag
, 1);
3991 gfc_match_equiv_variable (gfc_expr
**result
)
3993 return match_variable (result
, 1, 0);