1 /* Primary expression subroutines
2 Copyright (C) 2000-2016 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];
49 m
= gfc_match_small_literal_int (kind
, NULL
);
53 m
= gfc_match_name (name
);
57 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
63 *is_iso_c
= sym
->attr
.is_iso_c
;
65 if (sym
->attr
.flavor
!= FL_PARAMETER
)
68 if (sym
->value
== NULL
)
71 p
= gfc_extract_int (sym
->value
, kind
);
75 gfc_set_sym_referenced (sym
);
84 /* Get a trailing kind-specification for non-character variables.
86 * the integer kind value or
87 * -1 if an error was generated,
88 * -2 if no kind was found.
89 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
90 symbol like e.g. 'c_int'. */
93 get_kind (int *is_iso_c
)
100 if (gfc_match_char ('_') != MATCH_YES
)
103 m
= match_kind_param (&kind
, is_iso_c
);
105 gfc_error ("Missing kind-parameter at %C");
107 return (m
== MATCH_YES
) ? kind
: -1;
111 /* Given a character and a radix, see if the character is a valid
112 digit in that radix. */
115 gfc_check_digit (char c
, int radix
)
122 r
= ('0' <= c
&& c
<= '1');
126 r
= ('0' <= c
&& c
<= '7');
130 r
= ('0' <= c
&& c
<= '9');
138 gfc_internal_error ("gfc_check_digit(): bad radix");
145 /* Match the digit string part of an integer if signflag is not set,
146 the signed digit string part if signflag is set. If the buffer
147 is NULL, we just count characters for the resolution pass. Returns
148 the number of characters matched, -1 for no match. */
151 match_digits (int signflag
, int radix
, char *buffer
)
158 c
= gfc_next_ascii_char ();
160 if (signflag
&& (c
== '+' || c
== '-'))
164 gfc_gobble_whitespace ();
165 c
= gfc_next_ascii_char ();
169 if (!gfc_check_digit (c
, radix
))
178 old_loc
= gfc_current_locus
;
179 c
= gfc_next_ascii_char ();
181 if (!gfc_check_digit (c
, radix
))
189 gfc_current_locus
= old_loc
;
195 /* Match an integer (digit string and optional kind).
196 A sign will be accepted if signflag is set. */
199 match_integer_constant (gfc_expr
**result
, int signflag
)
201 int length
, kind
, is_iso_c
;
206 old_loc
= gfc_current_locus
;
207 gfc_gobble_whitespace ();
209 length
= match_digits (signflag
, 10, NULL
);
210 gfc_current_locus
= old_loc
;
214 buffer
= (char *) alloca (length
+ 1);
215 memset (buffer
, '\0', length
+ 1);
217 gfc_gobble_whitespace ();
219 match_digits (signflag
, 10, buffer
);
221 kind
= get_kind (&is_iso_c
);
223 kind
= gfc_default_integer_kind
;
227 if (kind
== 4 && flag_integer4_kind
== 8)
230 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
232 gfc_error ("Integer kind %d at %C not available", kind
);
236 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
237 e
->ts
.is_c_interop
= is_iso_c
;
239 if (gfc_range_check (e
) != ARITH_OK
)
241 gfc_error ("Integer too big for its kind at %C. This check can be "
242 "disabled with the option -fno-range-check");
253 /* Match a Hollerith constant. */
256 match_hollerith_constant (gfc_expr
**result
)
264 old_loc
= gfc_current_locus
;
265 gfc_gobble_whitespace ();
267 if (match_integer_constant (&e
, 0) == MATCH_YES
268 && gfc_match_char ('h') == MATCH_YES
)
270 if (!gfc_notify_std (GFC_STD_LEGACY
, "Hollerith constant at %C"))
273 msg
= gfc_extract_int (e
, &num
);
281 gfc_error ("Invalid Hollerith constant: %L must contain at least "
282 "one character", &old_loc
);
285 if (e
->ts
.kind
!= gfc_default_integer_kind
)
287 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
288 "should be default", &old_loc
);
294 e
= gfc_get_constant_expr (BT_HOLLERITH
, gfc_default_character_kind
,
297 /* Calculate padding needed to fit default integer memory. */
298 pad
= gfc_default_integer_kind
- (num
% gfc_default_integer_kind
);
300 e
->representation
.string
= XCNEWVEC (char, num
+ pad
+ 1);
302 for (i
= 0; i
< num
; i
++)
304 gfc_char_t c
= gfc_next_char_literal (INSTRING_WARN
);
305 if (! gfc_wide_fits_in_byte (c
))
307 gfc_error ("Invalid Hollerith constant at %L contains a "
308 "wide character", &old_loc
);
312 e
->representation
.string
[i
] = (unsigned char) c
;
315 /* Now pad with blanks and end with a null char. */
316 for (i
= 0; i
< pad
; i
++)
317 e
->representation
.string
[num
+ i
] = ' ';
319 e
->representation
.string
[num
+ i
] = '\0';
320 e
->representation
.length
= num
+ pad
;
329 gfc_current_locus
= old_loc
;
338 /* Match a binary, octal or hexadecimal constant that can be found in
339 a DATA statement. The standard permits b'010...', o'73...', and
340 z'a1...' where b, o, and z can be capital letters. This function
341 also accepts postfixed forms of the constants: '01...'b, '73...'o,
342 and 'a1...'z. An additional extension is the use of x for z. */
345 match_boz_constant (gfc_expr
**result
)
347 int radix
, length
, x_hex
, kind
;
348 locus old_loc
, start_loc
;
349 char *buffer
, post
, delim
;
352 start_loc
= old_loc
= gfc_current_locus
;
353 gfc_gobble_whitespace ();
356 switch (post
= gfc_next_ascii_char ())
378 radix
= 16; /* Set to accept any valid digit string. */
384 /* No whitespace allowed here. */
387 delim
= gfc_next_ascii_char ();
389 if (delim
!= '\'' && delim
!= '\"')
393 && (!gfc_notify_std(GFC_STD_GNU
, "Hexadecimal "
394 "constant at %C uses non-standard syntax")))
397 old_loc
= gfc_current_locus
;
399 length
= match_digits (0, radix
, NULL
);
402 gfc_error ("Empty set of digits in BOZ constant at %C");
406 if (gfc_next_ascii_char () != delim
)
408 gfc_error ("Illegal character in BOZ constant at %C");
414 switch (gfc_next_ascii_char ())
431 if (!gfc_notify_std (GFC_STD_GNU
, "BOZ constant "
432 "at %C uses non-standard postfix syntax"))
436 gfc_current_locus
= old_loc
;
438 buffer
= (char *) alloca (length
+ 1);
439 memset (buffer
, '\0', length
+ 1);
441 match_digits (0, radix
, buffer
);
442 gfc_next_ascii_char (); /* Eat delimiter. */
444 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
446 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
447 "If a data-stmt-constant is a boz-literal-constant, the corresponding
448 variable shall be of type integer. The boz-literal-constant is treated
449 as if it were an int-literal-constant with a kind-param that specifies
450 the representation method with the largest decimal exponent range
451 supported by the processor." */
453 kind
= gfc_max_integer_kind
;
454 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
456 /* Mark as boz variable. */
459 if (gfc_range_check (e
) != ARITH_OK
)
461 gfc_error ("Integer too big for integer kind %i at %C", kind
);
466 if (!gfc_in_match_data ()
467 && (!gfc_notify_std(GFC_STD_F2003
, "BOZ used outside a DATA "
475 gfc_current_locus
= start_loc
;
480 /* Match a real constant of some sort. Allow a signed constant if signflag
484 match_real_constant (gfc_expr
**result
, int signflag
)
486 int kind
, count
, seen_dp
, seen_digits
, is_iso_c
;
487 locus old_loc
, temp_loc
;
488 char *p
, *buffer
, c
, exp_char
;
492 old_loc
= gfc_current_locus
;
493 gfc_gobble_whitespace ();
503 c
= gfc_next_ascii_char ();
504 if (signflag
&& (c
== '+' || c
== '-'))
509 gfc_gobble_whitespace ();
510 c
= gfc_next_ascii_char ();
513 /* Scan significand. */
514 for (;; c
= gfc_next_ascii_char (), count
++)
521 /* Check to see if "." goes with a following operator like
523 temp_loc
= gfc_current_locus
;
524 c
= gfc_next_ascii_char ();
526 if (c
== 'e' || c
== 'd' || c
== 'q')
528 c
= gfc_next_ascii_char ();
530 goto done
; /* Operator named .e. or .d. */
534 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
536 gfc_current_locus
= temp_loc
;
550 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
557 if (!gfc_notify_std (GFC_STD_GNU
, "exponent-letter 'q' in "
558 "real-literal-constant at %C"))
560 else if (warn_real_q_constant
)
561 gfc_warning (OPT_Wreal_q_constant
,
562 "Extension: exponent-letter %<q%> in real-literal-constant "
567 c
= gfc_next_ascii_char ();
570 if (c
== '+' || c
== '-')
571 { /* optional sign */
572 c
= gfc_next_ascii_char ();
578 gfc_error ("Missing exponent in real number at %C");
584 c
= gfc_next_ascii_char ();
589 /* Check that we have a numeric constant. */
590 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
592 gfc_current_locus
= old_loc
;
596 /* Convert the number. */
597 gfc_current_locus
= old_loc
;
598 gfc_gobble_whitespace ();
600 buffer
= (char *) alloca (count
+ 1);
601 memset (buffer
, '\0', count
+ 1);
604 c
= gfc_next_ascii_char ();
605 if (c
== '+' || c
== '-')
607 gfc_gobble_whitespace ();
608 c
= gfc_next_ascii_char ();
611 /* Hack for mpfr_set_str(). */
614 if (c
== 'd' || c
== 'q')
622 c
= gfc_next_ascii_char ();
625 kind
= get_kind (&is_iso_c
);
634 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
638 kind
= gfc_default_double_kind
;
642 if (flag_real4_kind
== 8)
644 if (flag_real4_kind
== 10)
646 if (flag_real4_kind
== 16)
652 if (flag_real8_kind
== 4)
654 if (flag_real8_kind
== 10)
656 if (flag_real8_kind
== 16)
664 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
669 /* The maximum possible real kind type parameter is 16. First, try
670 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
671 extended precision. If neither value works, just given up. */
673 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
676 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
678 gfc_error ("Invalid exponent-letter %<q%> in "
679 "real-literal-constant at %C");
687 kind
= gfc_default_real_kind
;
691 if (flag_real4_kind
== 8)
693 if (flag_real4_kind
== 10)
695 if (flag_real4_kind
== 16)
701 if (flag_real8_kind
== 4)
703 if (flag_real8_kind
== 10)
705 if (flag_real8_kind
== 16)
709 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
711 gfc_error ("Invalid real kind %d at %C", kind
);
716 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
718 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
719 e
->ts
.is_c_interop
= is_iso_c
;
721 switch (gfc_range_check (e
))
726 gfc_error ("Real constant overflows its kind at %C");
729 case ARITH_UNDERFLOW
:
731 gfc_warning (OPT_Wunderflow
, "Real constant underflows its kind at %C");
732 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
736 gfc_internal_error ("gfc_range_check() returned bad value");
739 /* Warn about trailing digits which suggest the user added too many
740 trailing digits, which may cause the appearance of higher pecision
741 than the kind kan support.
743 This is done by replacing the rightmost non-zero digit with zero
744 and comparing with the original value. If these are equal, we
745 assume the user supplied more digits than intended (or forgot to
746 convert to the correct kind).
749 if (warn_conversion_extra
)
755 c
= strchr (buffer
, 'e');
757 c
= buffer
+ strlen(buffer
);
760 for (p
= c
- 1; p
>= buffer
; p
--)
776 mpfr_set_str (r
, buffer
, 10, GFC_RND_MODE
);
778 mpfr_neg (r
, r
, GFC_RND_MODE
);
780 mpfr_sub (r
, r
, e
->value
.real
, GFC_RND_MODE
);
782 if (mpfr_cmp_ui (r
, 0) == 0)
783 gfc_warning (OPT_Wconversion_extra
, "Non-significant digits "
784 "in %qs number at %C, maybe incorrect KIND",
785 gfc_typename (&e
->ts
));
800 /* Match a substring reference. */
803 match_substring (gfc_charlen
*cl
, int init
, gfc_ref
**result
, bool deferred
)
805 gfc_expr
*start
, *end
;
813 old_loc
= gfc_current_locus
;
815 m
= gfc_match_char ('(');
819 if (gfc_match_char (':') != MATCH_YES
)
822 m
= gfc_match_init_expr (&start
);
824 m
= gfc_match_expr (&start
);
832 m
= gfc_match_char (':');
837 if (gfc_match_char (')') != MATCH_YES
)
840 m
= gfc_match_init_expr (&end
);
842 m
= gfc_match_expr (&end
);
846 if (m
== MATCH_ERROR
)
849 m
= gfc_match_char (')');
854 /* Optimize away the (:) reference. */
855 if (start
== NULL
&& end
== NULL
&& !deferred
)
859 ref
= gfc_get_ref ();
861 ref
->type
= REF_SUBSTRING
;
863 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
864 ref
->u
.ss
.start
= start
;
865 if (end
== NULL
&& cl
)
866 end
= gfc_copy_expr (cl
->length
);
868 ref
->u
.ss
.length
= cl
;
875 gfc_error ("Syntax error in SUBSTRING specification at %C");
879 gfc_free_expr (start
);
882 gfc_current_locus
= old_loc
;
887 /* Reads the next character of a string constant, taking care to
888 return doubled delimiters on the input as a single instance of
891 Special return values for "ret" argument are:
892 -1 End of the string, as determined by the delimiter
893 -2 Unterminated string detected
895 Backslash codes are also expanded at this time. */
898 next_string_char (gfc_char_t delimiter
, int *ret
)
903 c
= gfc_next_char_literal (INSTRING_WARN
);
912 if (flag_backslash
&& c
== '\\')
914 old_locus
= gfc_current_locus
;
916 if (gfc_match_special_char (&c
) == MATCH_NO
)
917 gfc_current_locus
= old_locus
;
919 if (!(gfc_option
.allow_std
& GFC_STD_GNU
) && !inhibit_warnings
)
920 gfc_warning (0, "Extension: backslash character at %C");
926 old_locus
= gfc_current_locus
;
927 c
= gfc_next_char_literal (NONSTRING
);
931 gfc_current_locus
= old_locus
;
938 /* Special case of gfc_match_name() that matches a parameter kind name
939 before a string constant. This takes case of the weird but legal
944 where kind____ is a parameter. gfc_match_name() will happily slurp
945 up all the underscores, which leads to problems. If we return
946 MATCH_YES, the parse pointer points to the final underscore, which
947 is not part of the name. We never return MATCH_ERROR-- errors in
948 the name will be detected later. */
951 match_charkind_name (char *name
)
957 gfc_gobble_whitespace ();
958 c
= gfc_next_ascii_char ();
967 old_loc
= gfc_current_locus
;
968 c
= gfc_next_ascii_char ();
972 peek
= gfc_peek_ascii_char ();
974 if (peek
== '\'' || peek
== '\"')
976 gfc_current_locus
= old_loc
;
984 && (c
!= '$' || !flag_dollar_ok
))
988 if (++len
> GFC_MAX_SYMBOL_LEN
)
996 /* See if the current input matches a character constant. Lots of
997 contortions have to be done to match the kind parameter which comes
998 before the actual string. The main consideration is that we don't
999 want to error out too quickly. For example, we don't actually do
1000 any validation of the kinds until we have actually seen a legal
1001 delimiter. Using match_kind_param() generates errors too quickly. */
1004 match_string_constant (gfc_expr
**result
)
1006 char name
[GFC_MAX_SYMBOL_LEN
+ 1], peek
;
1007 int i
, kind
, length
, save_warn_ampersand
, ret
;
1008 locus old_locus
, start_locus
;
1013 gfc_char_t c
, delimiter
, *p
;
1015 old_locus
= gfc_current_locus
;
1017 gfc_gobble_whitespace ();
1019 c
= gfc_next_char ();
1020 if (c
== '\'' || c
== '"')
1022 kind
= gfc_default_character_kind
;
1023 start_locus
= gfc_current_locus
;
1027 if (gfc_wide_is_digit (c
))
1031 while (gfc_wide_is_digit (c
))
1033 kind
= kind
* 10 + c
- '0';
1036 c
= gfc_next_char ();
1042 gfc_current_locus
= old_locus
;
1044 m
= match_charkind_name (name
);
1048 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
1050 || sym
->attr
.flavor
!= FL_PARAMETER
)
1054 c
= gfc_next_char ();
1059 gfc_gobble_whitespace ();
1060 c
= gfc_next_char ();
1066 gfc_gobble_whitespace ();
1068 c
= gfc_next_char ();
1069 if (c
!= '\'' && c
!= '"')
1072 start_locus
= gfc_current_locus
;
1076 q
= gfc_extract_int (sym
->value
, &kind
);
1082 gfc_set_sym_referenced (sym
);
1085 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1087 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
1092 /* Scan the string into a block of memory by first figuring out how
1093 long it is, allocating the structure, then re-reading it. This
1094 isn't particularly efficient, but string constants aren't that
1095 common in most code. TODO: Use obstacks? */
1102 c
= next_string_char (delimiter
, &ret
);
1107 gfc_current_locus
= start_locus
;
1108 gfc_error ("Unterminated character constant beginning at %C");
1115 /* Peek at the next character to see if it is a b, o, z, or x for the
1116 postfixed BOZ literal constants. */
1117 peek
= gfc_peek_ascii_char ();
1118 if (peek
== 'b' || peek
== 'o' || peek
=='z' || peek
== 'x')
1121 e
= gfc_get_character_expr (kind
, &start_locus
, NULL
, length
);
1123 gfc_current_locus
= start_locus
;
1125 /* We disable the warning for the following loop as the warning has already
1126 been printed in the loop above. */
1127 save_warn_ampersand
= warn_ampersand
;
1128 warn_ampersand
= false;
1130 p
= e
->value
.character
.string
;
1131 for (i
= 0; i
< length
; i
++)
1133 c
= next_string_char (delimiter
, &ret
);
1135 if (!gfc_check_character_range (c
, kind
))
1138 gfc_error ("Character %qs in string at %C is not representable "
1139 "in character kind %d", gfc_print_wide_char (c
), kind
);
1146 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
1147 warn_ampersand
= save_warn_ampersand
;
1149 next_string_char (delimiter
, &ret
);
1151 gfc_internal_error ("match_string_constant(): Delimiter not found");
1153 if (match_substring (NULL
, 0, &e
->ref
, false) != MATCH_NO
)
1154 e
->expr_type
= EXPR_SUBSTRING
;
1161 gfc_current_locus
= old_locus
;
1166 /* Match a .true. or .false. Returns 1 if a .true. was found,
1167 0 if a .false. was found, and -1 otherwise. */
1169 match_logical_constant_string (void)
1171 locus orig_loc
= gfc_current_locus
;
1173 gfc_gobble_whitespace ();
1174 if (gfc_next_ascii_char () == '.')
1176 char ch
= gfc_next_ascii_char ();
1179 if (gfc_next_ascii_char () == 'a'
1180 && gfc_next_ascii_char () == 'l'
1181 && gfc_next_ascii_char () == 's'
1182 && gfc_next_ascii_char () == 'e'
1183 && gfc_next_ascii_char () == '.')
1184 /* Matched ".false.". */
1189 if (gfc_next_ascii_char () == 'r'
1190 && gfc_next_ascii_char () == 'u'
1191 && gfc_next_ascii_char () == 'e'
1192 && gfc_next_ascii_char () == '.')
1193 /* Matched ".true.". */
1197 gfc_current_locus
= orig_loc
;
1201 /* Match a .true. or .false. */
1204 match_logical_constant (gfc_expr
**result
)
1207 int i
, kind
, is_iso_c
;
1209 i
= match_logical_constant_string ();
1213 kind
= get_kind (&is_iso_c
);
1217 kind
= gfc_default_logical_kind
;
1219 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1221 gfc_error ("Bad kind for logical constant at %C");
1225 e
= gfc_get_logical_expr (kind
, &gfc_current_locus
, i
);
1226 e
->ts
.is_c_interop
= is_iso_c
;
1233 /* Match a real or imaginary part of a complex constant that is a
1234 symbolic constant. */
1237 match_sym_complex_part (gfc_expr
**result
)
1239 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1244 m
= gfc_match_name (name
);
1248 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1251 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1253 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1260 if (!gfc_numeric_ts (&sym
->value
->ts
))
1262 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1266 if (sym
->value
->rank
!= 0)
1268 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1272 if (!gfc_notify_std (GFC_STD_F2003
, "PARAMETER symbol in "
1273 "complex constant at %C"))
1276 switch (sym
->value
->ts
.type
)
1279 e
= gfc_copy_expr (sym
->value
);
1283 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1289 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1295 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1298 *result
= e
; /* e is a scalar, real, constant expression. */
1302 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1307 /* Match a real or imaginary part of a complex number. */
1310 match_complex_part (gfc_expr
**result
)
1314 m
= match_sym_complex_part (result
);
1318 m
= match_real_constant (result
, 1);
1322 return match_integer_constant (result
, 1);
1326 /* Try to match a complex constant. */
1329 match_complex_constant (gfc_expr
**result
)
1331 gfc_expr
*e
, *real
, *imag
;
1332 gfc_error_buffer old_error
;
1333 gfc_typespec target
;
1338 old_loc
= gfc_current_locus
;
1339 real
= imag
= e
= NULL
;
1341 m
= gfc_match_char ('(');
1345 gfc_push_error (&old_error
);
1347 m
= match_complex_part (&real
);
1350 gfc_free_error (&old_error
);
1354 if (gfc_match_char (',') == MATCH_NO
)
1356 /* It is possible that gfc_int2real issued a warning when
1357 converting an integer to real. Throw this away here. */
1359 gfc_clear_warning ();
1360 gfc_pop_error (&old_error
);
1365 /* If m is error, then something was wrong with the real part and we
1366 assume we have a complex constant because we've seen the ','. An
1367 ambiguous case here is the start of an iterator list of some
1368 sort. These sort of lists are matched prior to coming here. */
1370 if (m
== MATCH_ERROR
)
1372 gfc_free_error (&old_error
);
1375 gfc_pop_error (&old_error
);
1377 m
= match_complex_part (&imag
);
1380 if (m
== MATCH_ERROR
)
1383 m
= gfc_match_char (')');
1386 /* Give the matcher for implied do-loops a chance to run. This
1387 yields a much saner error message for (/ (i, 4=i, 6) /). */
1388 if (gfc_peek_ascii_char () == '=')
1397 if (m
== MATCH_ERROR
)
1400 /* Decide on the kind of this complex number. */
1401 if (real
->ts
.type
== BT_REAL
)
1403 if (imag
->ts
.type
== BT_REAL
)
1404 kind
= gfc_kind_max (real
, imag
);
1406 kind
= real
->ts
.kind
;
1410 if (imag
->ts
.type
== BT_REAL
)
1411 kind
= imag
->ts
.kind
;
1413 kind
= gfc_default_real_kind
;
1415 gfc_clear_ts (&target
);
1416 target
.type
= BT_REAL
;
1419 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1420 gfc_convert_type (real
, &target
, 2);
1421 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1422 gfc_convert_type (imag
, &target
, 2);
1424 e
= gfc_convert_complex (real
, imag
, kind
);
1425 e
->where
= gfc_current_locus
;
1427 gfc_free_expr (real
);
1428 gfc_free_expr (imag
);
1434 gfc_error ("Syntax error in COMPLEX constant at %C");
1439 gfc_free_expr (real
);
1440 gfc_free_expr (imag
);
1441 gfc_current_locus
= old_loc
;
1447 /* Match constants in any of several forms. Returns nonzero for a
1448 match, zero for no match. */
1451 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1455 m
= match_complex_constant (result
);
1459 m
= match_string_constant (result
);
1463 m
= match_boz_constant (result
);
1467 m
= match_real_constant (result
, signflag
);
1471 m
= match_hollerith_constant (result
);
1475 m
= match_integer_constant (result
, signflag
);
1479 m
= match_logical_constant (result
);
1487 /* This checks if a symbol is the return value of an encompassing function.
1488 Function nesting can be maximally two levels deep, but we may have
1489 additional local namespaces like BLOCK etc. */
1492 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1494 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1498 if (ns
->proc_name
== sym
)
1506 /* Match a single actual argument value. An actual argument is
1507 usually an expression, but can also be a procedure name. If the
1508 argument is a single name, it is not always possible to tell
1509 whether the name is a dummy procedure or not. We treat these cases
1510 by creating an argument that looks like a dummy procedure and
1511 fixing things later during resolution. */
1514 match_actual_arg (gfc_expr
**result
)
1516 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1517 gfc_symtree
*symtree
;
1522 gfc_gobble_whitespace ();
1523 where
= gfc_current_locus
;
1525 switch (gfc_match_name (name
))
1534 w
= gfc_current_locus
;
1535 gfc_gobble_whitespace ();
1536 c
= gfc_next_ascii_char ();
1537 gfc_current_locus
= w
;
1539 if (c
!= ',' && c
!= ')')
1542 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1544 /* Handle error elsewhere. */
1546 /* Eliminate a couple of common cases where we know we don't
1547 have a function argument. */
1548 if (symtree
== NULL
)
1550 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1551 gfc_set_sym_referenced (symtree
->n
.sym
);
1557 sym
= symtree
->n
.sym
;
1558 gfc_set_sym_referenced (sym
);
1559 if (sym
->attr
.flavor
== FL_NAMELIST
)
1561 gfc_error ("Namelist '%s' can not be an argument at %L",
1565 if (sym
->attr
.flavor
!= FL_PROCEDURE
1566 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1569 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1571 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1572 sym
->name
, &sym
->declared_at
))
1577 /* If the symbol is a function with itself as the result and
1578 is being defined, then we have a variable. */
1579 if (sym
->attr
.function
&& sym
->result
== sym
)
1581 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1585 && (sym
->ns
== gfc_current_ns
1586 || sym
->ns
== gfc_current_ns
->parent
))
1588 gfc_entry_list
*el
= NULL
;
1590 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1600 e
= gfc_get_expr (); /* Leave it unknown for now */
1601 e
->symtree
= symtree
;
1602 e
->expr_type
= EXPR_VARIABLE
;
1603 e
->ts
.type
= BT_PROCEDURE
;
1610 gfc_current_locus
= where
;
1611 return gfc_match_expr (result
);
1615 /* Match a keyword argument. */
1618 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1620 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1621 gfc_actual_arglist
*a
;
1625 name_locus
= gfc_current_locus
;
1626 m
= gfc_match_name (name
);
1630 if (gfc_match_char ('=') != MATCH_YES
)
1636 m
= match_actual_arg (&actual
->expr
);
1640 /* Make sure this name has not appeared yet. */
1642 if (name
[0] != '\0')
1644 for (a
= base
; a
; a
= a
->next
)
1645 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1647 gfc_error ("Keyword %qs at %C has already appeared in the "
1648 "current argument list", name
);
1653 actual
->name
= gfc_get_string (name
);
1657 gfc_current_locus
= name_locus
;
1662 /* Match an argument list function, such as %VAL. */
1665 match_arg_list_function (gfc_actual_arglist
*result
)
1667 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1671 old_locus
= gfc_current_locus
;
1673 if (gfc_match_char ('%') != MATCH_YES
)
1679 m
= gfc_match ("%n (", name
);
1683 if (name
[0] != '\0')
1688 if (strncmp (name
, "loc", 3) == 0)
1690 result
->name
= "%LOC";
1695 if (strncmp (name
, "ref", 3) == 0)
1697 result
->name
= "%REF";
1702 if (strncmp (name
, "val", 3) == 0)
1704 result
->name
= "%VAL";
1714 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1720 m
= match_actual_arg (&result
->expr
);
1724 if (gfc_match_char (')') != MATCH_YES
)
1733 gfc_current_locus
= old_locus
;
1738 /* Matches an actual argument list of a function or subroutine, from
1739 the opening parenthesis to the closing parenthesis. The argument
1740 list is assumed to allow keyword arguments because we don't know if
1741 the symbol associated with the procedure has an implicit interface
1742 or not. We make sure keywords are unique. If sub_flag is set,
1743 we're matching the argument list of a subroutine. */
1746 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1748 gfc_actual_arglist
*head
, *tail
;
1750 gfc_st_label
*label
;
1754 *argp
= tail
= NULL
;
1755 old_loc
= gfc_current_locus
;
1759 if (gfc_match_char ('(') == MATCH_NO
)
1760 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1762 if (gfc_match_char (')') == MATCH_YES
)
1766 matching_actual_arglist
++;
1771 head
= tail
= gfc_get_actual_arglist ();
1774 tail
->next
= gfc_get_actual_arglist ();
1778 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1780 m
= gfc_match_st_label (&label
);
1782 gfc_error ("Expected alternate return label at %C");
1786 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1790 tail
->label
= label
;
1794 /* After the first keyword argument is seen, the following
1795 arguments must also have keywords. */
1798 m
= match_keyword_arg (tail
, head
);
1800 if (m
== MATCH_ERROR
)
1804 gfc_error ("Missing keyword name in actual argument list at %C");
1811 /* Try an argument list function, like %VAL. */
1812 m
= match_arg_list_function (tail
);
1813 if (m
== MATCH_ERROR
)
1816 /* See if we have the first keyword argument. */
1819 m
= match_keyword_arg (tail
, head
);
1822 if (m
== MATCH_ERROR
)
1828 /* Try for a non-keyword argument. */
1829 m
= match_actual_arg (&tail
->expr
);
1830 if (m
== MATCH_ERROR
)
1839 if (gfc_match_char (')') == MATCH_YES
)
1841 if (gfc_match_char (',') != MATCH_YES
)
1846 matching_actual_arglist
--;
1850 gfc_error ("Syntax error in argument list at %C");
1853 gfc_free_actual_arglist (head
);
1854 gfc_current_locus
= old_loc
;
1855 matching_actual_arglist
--;
1860 /* Used by gfc_match_varspec() to extend the reference list by one
1864 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1866 if (primary
->ref
== NULL
)
1867 primary
->ref
= tail
= gfc_get_ref ();
1871 gfc_internal_error ("extend_ref(): Bad tail");
1872 tail
->next
= gfc_get_ref ();
1880 /* Match any additional specifications associated with the current
1881 variable like member references or substrings. If equiv_flag is
1882 set we only match stuff that is allowed inside an EQUIVALENCE
1883 statement. sub_flag tells whether we expect a type-bound procedure found
1884 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1885 components, 'ppc_arg' determines whether the PPC may be called (with an
1886 argument list), or whether it may just be referred to as a pointer. */
1889 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1892 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1893 gfc_ref
*substring
, *tail
, *tmp
;
1894 gfc_component
*component
;
1895 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1902 gfc_gobble_whitespace ();
1904 if (gfc_peek_ascii_char () == '[')
1906 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1907 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1908 && CLASS_DATA (sym
)->attr
.dimension
))
1910 gfc_error ("Array section designator, e.g. '(:)', is required "
1911 "besides the coarray designator '[...]' at %C");
1914 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1915 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1916 && !CLASS_DATA (sym
)->attr
.codimension
))
1918 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1924 /* For associate names, we may not yet know whether they are arrays or not.
1925 Thus if we have one and parentheses follow, we have to assume that it
1926 actually is one for now. The final decision will be made at
1927 resolution time, of course. */
1928 if (sym
->assoc
&& gfc_peek_ascii_char () == '('
1929 && !(sym
->assoc
->dangling
&& sym
->assoc
->st
1930 && sym
->assoc
->st
->n
.sym
1931 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0)
1932 && sym
->ts
.type
!= BT_CLASS
)
1933 sym
->attr
.dimension
= 1;
1935 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1936 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1937 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1938 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1939 && !(gfc_matching_procptr_assignment
1940 && sym
->attr
.flavor
== FL_PROCEDURE
))
1941 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1942 && (CLASS_DATA (sym
)->attr
.dimension
1943 || CLASS_DATA (sym
)->attr
.codimension
)))
1947 tail
= extend_ref (primary
, tail
);
1948 tail
->type
= REF_ARRAY
;
1950 /* In EQUIVALENCE, we don't know yet whether we are seeing
1951 an array, character variable or array of character
1952 variables. We'll leave the decision till resolve time. */
1956 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1957 as
= CLASS_DATA (sym
)->as
;
1961 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1962 as
? as
->corank
: 0);
1966 gfc_gobble_whitespace ();
1967 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1969 tail
= extend_ref (primary
, tail
);
1970 tail
->type
= REF_ARRAY
;
1972 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1978 primary
->ts
= sym
->ts
;
1983 /* With DEC extensions, member separator may be '.' or '%'. */
1984 sep
= gfc_peek_ascii_char ();
1985 m
= gfc_match_member_sep (sym
);
1986 if (m
== MATCH_ERROR
)
1989 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
1990 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1991 gfc_set_default_type (sym
, 0, sym
->ns
);
1993 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
1995 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
1998 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2001 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2006 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2008 goto check_substring
;
2010 sym
= sym
->ts
.u
.derived
;
2017 m
= gfc_match_name (name
);
2019 gfc_error ("Expected structure component name at %C");
2023 if (sym
->f2k_derived
)
2024 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2030 gfc_symbol
* tbp_sym
;
2035 gcc_assert (!tail
|| !tail
->next
);
2037 if (!(primary
->expr_type
== EXPR_VARIABLE
2038 || (primary
->expr_type
== EXPR_STRUCTURE
2039 && primary
->symtree
&& primary
->symtree
->n
.sym
2040 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2043 if (tbp
->n
.tb
->is_generic
)
2046 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2048 primary
->expr_type
= EXPR_COMPCALL
;
2049 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2050 primary
->value
.compcall
.name
= tbp
->name
;
2051 primary
->value
.compcall
.ignore_pass
= 0;
2052 primary
->value
.compcall
.assign
= 0;
2053 primary
->value
.compcall
.base_object
= NULL
;
2054 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2056 primary
->ts
= tbp_sym
->ts
;
2058 gfc_clear_ts (&primary
->ts
);
2060 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2061 &primary
->value
.compcall
.actual
);
2062 if (m
== MATCH_ERROR
)
2067 primary
->value
.compcall
.actual
= NULL
;
2070 gfc_error ("Expected argument list at %C");
2078 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2079 if (component
== NULL
)
2082 /* Extend the reference chain determined by gfc_find_component. */
2083 if (primary
->ref
== NULL
)
2087 /* Set by the for loop below for the last component ref. */
2088 gcc_assert (tail
!= NULL
);
2092 /* The reference chain may be longer than one hop for union
2093 subcomponents; find the new tail. */
2094 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2097 primary
->ts
= component
->ts
;
2099 if (component
->attr
.proc_pointer
&& ppc_arg
)
2101 /* Procedure pointer component call: Look for argument list. */
2102 m
= gfc_match_actual_arglist (sub_flag
,
2103 &primary
->value
.compcall
.actual
);
2104 if (m
== MATCH_ERROR
)
2107 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2108 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2110 gfc_error ("Procedure pointer component %qs requires an "
2111 "argument list at %C", component
->name
);
2116 primary
->expr_type
= EXPR_PPC
;
2121 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2123 tail
= extend_ref (primary
, tail
);
2124 tail
->type
= REF_ARRAY
;
2126 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2127 component
->as
->corank
);
2131 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2132 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2134 tail
= extend_ref (primary
, tail
);
2135 tail
->type
= REF_ARRAY
;
2137 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2139 CLASS_DATA (component
)->as
->corank
);
2144 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2145 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2148 sym
= component
->ts
.u
.derived
;
2153 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2155 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2157 gfc_set_default_type (sym
, 0, sym
->ns
);
2158 primary
->ts
= sym
->ts
;
2163 if (primary
->ts
.type
== BT_CHARACTER
)
2165 bool def
= primary
->ts
.deferred
== 1;
2166 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2170 primary
->ref
= substring
;
2172 tail
->next
= substring
;
2174 if (primary
->expr_type
== EXPR_CONSTANT
)
2175 primary
->expr_type
= EXPR_SUBSTRING
;
2178 primary
->ts
.u
.cl
= NULL
;
2185 gfc_clear_ts (&primary
->ts
);
2186 gfc_clear_ts (&sym
->ts
);
2196 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2198 gfc_error ("Coindexed procedure-pointer component at %C");
2206 /* Given an expression that is a variable, figure out what the
2207 ultimate variable's type and attribute is, traversing the reference
2208 structures if necessary.
2210 This subroutine is trickier than it looks. We start at the base
2211 symbol and store the attribute. Component references load a
2212 completely new attribute.
2214 A couple of rules come into play. Subobjects of targets are always
2215 targets themselves. If we see a component that goes through a
2216 pointer, then the expression must also be a target, since the
2217 pointer is associated with something (if it isn't core will soon be
2218 dumped). If we see a full part or section of an array, the
2219 expression is also an array.
2221 We can have at most one full array reference. */
2224 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2226 int dimension
, codimension
, pointer
, allocatable
, target
;
2227 symbol_attribute attr
;
2230 gfc_component
*comp
;
2232 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2233 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2235 sym
= expr
->symtree
->n
.sym
;
2238 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2240 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2241 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2242 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2243 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2247 dimension
= attr
.dimension
;
2248 codimension
= attr
.codimension
;
2249 pointer
= attr
.pointer
;
2250 allocatable
= attr
.allocatable
;
2253 target
= attr
.target
;
2254 if (pointer
|| attr
.proc_pointer
)
2257 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2260 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2265 switch (ref
->u
.ar
.type
)
2272 allocatable
= pointer
= 0;
2277 /* Handle coarrays. */
2278 if (ref
->u
.ar
.dimen
> 0)
2279 allocatable
= pointer
= 0;
2283 /* If any of start, end or stride is not integer, there will
2284 already have been an error issued. */
2286 gfc_get_errors (NULL
, &errors
);
2288 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2294 comp
= ref
->u
.c
.component
;
2299 /* Don't set the string length if a substring reference
2301 if (ts
->type
== BT_CHARACTER
2302 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2306 if (comp
->ts
.type
== BT_CLASS
)
2308 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2309 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2310 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2314 codimension
= comp
->attr
.codimension
;
2315 pointer
= comp
->attr
.pointer
;
2316 allocatable
= comp
->attr
.allocatable
;
2318 if (pointer
|| attr
.proc_pointer
)
2324 allocatable
= pointer
= 0;
2328 attr
.dimension
= dimension
;
2329 attr
.codimension
= codimension
;
2330 attr
.pointer
= pointer
;
2331 attr
.allocatable
= allocatable
;
2332 attr
.target
= target
;
2333 attr
.save
= sym
->attr
.save
;
2339 /* Return the attribute from a general expression. */
2342 gfc_expr_attr (gfc_expr
*e
)
2344 symbol_attribute attr
;
2346 switch (e
->expr_type
)
2349 attr
= gfc_variable_attr (e
, NULL
);
2353 gfc_clear_attr (&attr
);
2355 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2357 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2359 if (sym
->ts
.type
== BT_CLASS
)
2361 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2362 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2363 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2366 else if (e
->value
.function
.isym
2367 && e
->value
.function
.isym
->transformational
2368 && e
->ts
.type
== BT_CLASS
)
2369 attr
= CLASS_DATA (e
)->attr
;
2371 attr
= gfc_variable_attr (e
, NULL
);
2373 /* TODO: NULL() returns pointers. May have to take care of this
2379 gfc_clear_attr (&attr
);
2387 /* Given an expression, figure out what the ultimate expression
2388 attribute is. This routine is similar to gfc_variable_attr with
2389 parts of gfc_expr_attr, but focuses more on the needs of
2390 coarrays. For coarrays a codimension attribute is kind of
2391 "infectious" being propagated once set and never cleared. */
2393 static symbol_attribute
2394 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
)
2396 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
,
2398 symbol_attribute attr
;
2401 gfc_component
*comp
;
2403 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2404 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2406 sym
= expr
->symtree
->n
.sym
;
2407 gfc_clear_attr (&attr
);
2409 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2411 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2412 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2413 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2414 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2415 coarray_comp
= CLASS_DATA (sym
)->attr
.coarray_comp
;
2416 alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2420 dimension
= sym
->attr
.dimension
;
2421 codimension
= sym
->attr
.codimension
;
2422 pointer
= sym
->attr
.pointer
;
2423 allocatable
= sym
->attr
.allocatable
;
2424 coarray_comp
= sym
->attr
.coarray_comp
;
2425 alloc_comp
= sym
->ts
.type
== BT_DERIVED
2426 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2429 target
= attr
.target
;
2430 if (pointer
|| attr
.proc_pointer
)
2433 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2438 switch (ref
->u
.ar
.type
)
2446 /* Handle coarrays. */
2447 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2448 allocatable
= pointer
= 0;
2452 /* If any of start, end or stride is not integer, there will
2453 already have been an error issued. */
2455 gfc_get_errors (NULL
, &errors
);
2457 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2463 comp
= ref
->u
.c
.component
;
2465 if (comp
->ts
.type
== BT_CLASS
)
2467 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2468 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2469 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2470 coarray_comp
|= CLASS_DATA (comp
)->attr
.coarray_comp
;
2474 codimension
|= comp
->attr
.codimension
;
2475 pointer
= comp
->attr
.pointer
;
2476 allocatable
= comp
->attr
.allocatable
;
2477 coarray_comp
|= comp
->attr
.coarray_comp
;
2480 if (pointer
|| attr
.proc_pointer
)
2486 allocatable
= pointer
= 0;
2490 attr
.dimension
= dimension
;
2491 attr
.codimension
= codimension
;
2492 attr
.pointer
= pointer
;
2493 attr
.allocatable
= allocatable
;
2494 attr
.target
= target
;
2495 attr
.save
= sym
->attr
.save
;
2496 attr
.coarray_comp
= coarray_comp
;
2497 attr
.alloc_comp
= alloc_comp
;
2504 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
)
2506 symbol_attribute attr
;
2508 switch (e
->expr_type
)
2511 attr
= caf_variable_attr (e
, in_allocate
);
2515 gfc_clear_attr (&attr
);
2517 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2519 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2521 if (sym
->ts
.type
== BT_CLASS
)
2523 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2524 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2525 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2526 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2529 else if (e
->symtree
)
2530 attr
= caf_variable_attr (e
, in_allocate
);
2532 gfc_clear_attr (&attr
);
2536 gfc_clear_attr (&attr
);
2544 /* Match a structure constructor. The initial symbol has already been
2547 typedef struct gfc_structure_ctor_component
2552 struct gfc_structure_ctor_component
* next
;
2554 gfc_structure_ctor_component
;
2556 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2559 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2562 gfc_free_expr (comp
->val
);
2567 /* Translate the component list into the actual constructor by sorting it in
2568 the order required; this also checks along the way that each and every
2569 component actually has an initializer and handles default initializers
2570 for components without explicit value given. */
2572 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2573 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2575 gfc_structure_ctor_component
*comp_iter
;
2576 gfc_component
*comp
;
2578 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2580 gfc_structure_ctor_component
**next_ptr
;
2581 gfc_expr
*value
= NULL
;
2583 /* Try to find the initializer for the current component by name. */
2584 next_ptr
= comp_head
;
2585 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2587 if (!strcmp (comp_iter
->name
, comp
->name
))
2589 next_ptr
= &comp_iter
->next
;
2592 /* If an extension, try building the parent derived type by building
2593 a value expression for the parent derived type and calling self. */
2594 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2596 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2598 &gfc_current_locus
);
2599 value
->ts
= comp
->ts
;
2601 if (!build_actual_constructor (comp_head
,
2602 &value
->value
.constructor
,
2603 comp
->ts
.u
.derived
))
2605 gfc_free_expr (value
);
2609 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2613 /* If it was not found, try the default initializer if there's any;
2614 otherwise, it's an error unless this is a deferred parameter. */
2617 if (comp
->initializer
)
2619 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2620 "with missing optional arguments at %C"))
2622 value
= gfc_copy_expr (comp
->initializer
);
2624 else if (comp
->attr
.allocatable
2625 || (comp
->ts
.type
== BT_CLASS
2626 && CLASS_DATA (comp
)->attr
.allocatable
))
2628 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2629 "allocatable component '%qs' given in the "
2630 "structure constructor at %C", comp
->name
))
2633 else if (!comp
->attr
.artificial
)
2635 gfc_error ("No initializer for component %qs given in the"
2636 " structure constructor at %C!", comp
->name
);
2641 value
= comp_iter
->val
;
2643 /* Add the value to the constructor chain built. */
2644 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2646 /* Remove the entry from the component list. We don't want the expression
2647 value to be free'd, so set it to NULL. */
2650 *next_ptr
= comp_iter
->next
;
2651 comp_iter
->val
= NULL
;
2652 gfc_free_structure_ctor_component (comp_iter
);
2660 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2661 gfc_actual_arglist
**arglist
,
2664 gfc_actual_arglist
*actual
;
2665 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2666 gfc_constructor_base ctor_head
= NULL
;
2667 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2668 const char* last_name
= NULL
;
2672 expr
= parent
? *cexpr
: e
;
2673 old_locus
= gfc_current_locus
;
2675 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2677 gfc_current_locus
= expr
->where
;
2679 comp_tail
= comp_head
= NULL
;
2681 if (!parent
&& sym
->attr
.abstract
)
2683 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2684 sym
->name
, &expr
->where
);
2688 comp
= sym
->components
;
2689 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2692 gfc_component
*this_comp
= NULL
;
2695 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2698 comp_tail
->next
= gfc_get_structure_ctor_component ();
2699 comp_tail
= comp_tail
->next
;
2703 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2704 " constructor with named arguments at %C"))
2707 comp_tail
->name
= xstrdup (actual
->name
);
2708 last_name
= comp_tail
->name
;
2713 /* Components without name are not allowed after the first named
2714 component initializer! */
2715 if (!comp
|| comp
->attr
.artificial
)
2718 gfc_error ("Component initializer without name after component"
2719 " named %s at %L!", last_name
,
2720 actual
->expr
? &actual
->expr
->where
2721 : &gfc_current_locus
);
2723 gfc_error ("Too many components in structure constructor at "
2724 "%L!", actual
->expr
? &actual
->expr
->where
2725 : &gfc_current_locus
);
2729 comp_tail
->name
= xstrdup (comp
->name
);
2732 /* Find the current component in the structure definition and check
2733 its access is not private. */
2735 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
2738 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2739 false, false, NULL
);
2740 comp
= NULL
; /* Reset needed! */
2743 /* Here we can check if a component name is given which does not
2744 correspond to any component of the defined structure. */
2748 comp_tail
->val
= actual
->expr
;
2749 if (actual
->expr
!= NULL
)
2750 comp_tail
->where
= actual
->expr
->where
;
2751 actual
->expr
= NULL
;
2753 /* Check if this component is already given a value. */
2754 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2755 comp_iter
= comp_iter
->next
)
2757 gcc_assert (comp_iter
);
2758 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2760 gfc_error ("Component %qs is initialized twice in the structure"
2761 " constructor at %L!", comp_tail
->name
,
2762 comp_tail
->val
? &comp_tail
->where
2763 : &gfc_current_locus
);
2768 /* F2008, R457/C725, for PURE C1283. */
2769 if (this_comp
->attr
.pointer
&& comp_tail
->val
2770 && gfc_is_coindexed (comp_tail
->val
))
2772 gfc_error ("Coindexed expression to pointer component %qs in "
2773 "structure constructor at %L!", comp_tail
->name
,
2778 /* If not explicitly a parent constructor, gather up the components
2780 if (comp
&& comp
== sym
->components
2781 && sym
->attr
.extension
2783 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
2785 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2788 gfc_actual_arglist
*arg_null
= NULL
;
2790 actual
->expr
= comp_tail
->val
;
2791 comp_tail
->val
= NULL
;
2793 m
= gfc_convert_to_structure_constructor (NULL
,
2794 comp
->ts
.u
.derived
, &comp_tail
->val
,
2795 comp
->ts
.u
.derived
->attr
.zero_comp
2796 ? &arg_null
: &actual
, true);
2800 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2809 if (parent
&& !comp
)
2813 actual
= actual
->next
;
2816 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2819 /* No component should be left, as this should have caused an error in the
2820 loop constructing the component-list (name that does not correspond to any
2821 component in the structure definition). */
2822 if (comp_head
&& sym
->attr
.extension
)
2824 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2826 gfc_error ("component %qs at %L has already been set by a "
2827 "parent derived type constructor", comp_iter
->name
,
2833 gcc_assert (!comp_head
);
2837 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2838 expr
->ts
.u
.derived
= sym
;
2839 expr
->value
.constructor
= ctor_head
;
2844 expr
->ts
.u
.derived
= sym
;
2846 expr
->ts
.type
= BT_DERIVED
;
2847 expr
->value
.constructor
= ctor_head
;
2848 expr
->expr_type
= EXPR_STRUCTURE
;
2851 gfc_current_locus
= old_locus
;
2857 gfc_current_locus
= old_locus
;
2859 for (comp_iter
= comp_head
; comp_iter
; )
2861 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2862 gfc_free_structure_ctor_component (comp_iter
);
2865 gfc_constructor_free (ctor_head
);
2872 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2876 gfc_symtree
*symtree
;
2878 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
2880 e
= gfc_get_expr ();
2881 e
->symtree
= symtree
;
2882 e
->expr_type
= EXPR_FUNCTION
;
2884 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
2885 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2886 e
->value
.function
.esym
= sym
;
2887 e
->symtree
->n
.sym
->attr
.generic
= 1;
2889 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2896 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
2902 /* If a structure constructor is in a DATA statement, then each entity
2903 in the structure constructor must be a constant. Try to reduce the
2905 if (gfc_in_match_data ())
2906 gfc_reduce_init_expr (e
);
2913 /* If the symbol is an implicit do loop index and implicitly typed,
2914 it should not be host associated. Provide a symtree from the
2915 current namespace. */
2917 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2919 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2920 && (*sym
)->ns
!= gfc_current_ns
2921 && (*sym
)->attr
.implied_index
2922 && (*sym
)->attr
.implicit_type
2923 && !(*sym
)->attr
.use_assoc
)
2926 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2929 *sym
= (*st
)->n
.sym
;
2935 /* Procedure pointer as function result: Replace the function symbol by the
2936 auto-generated hidden result variable named "ppr@". */
2939 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2941 /* Check for procedure pointer result variable. */
2942 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2943 && (*sym
)->result
&& (*sym
)->result
!= *sym
2944 && (*sym
)->result
->attr
.proc_pointer
2945 && (*sym
) == gfc_current_ns
->proc_name
2946 && (*sym
) == (*sym
)->result
->ns
->proc_name
2947 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2949 /* Automatic replacement with "hidden" result variable. */
2950 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2951 *sym
= (*sym
)->result
;
2952 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2959 /* Matches a variable name followed by anything that might follow it--
2960 array reference, argument list of a function, etc. */
2963 gfc_match_rvalue (gfc_expr
**result
)
2965 gfc_actual_arglist
*actual_arglist
;
2966 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2969 gfc_symtree
*symtree
;
2970 locus where
, old_loc
;
2978 m
= gfc_match ("%%loc");
2981 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
2983 strncpy (name
, "loc", 4);
2988 m
= gfc_match_name (name
);
2993 /* Check if the symbol exists. */
2994 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
2997 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
2998 type. For derived types we create a generic symbol which links to the
2999 derived type symbol; STRUCTUREs are simpler and must not conflict with
3002 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3004 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3006 if (gfc_find_state (COMP_INTERFACE
)
3007 && !gfc_current_ns
->has_import_set
)
3008 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3010 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3016 sym
= symtree
->n
.sym
;
3018 where
= gfc_current_locus
;
3020 replace_hidden_procptr_result (&sym
, &symtree
);
3022 /* If this is an implicit do loop index and implicitly typed,
3023 it should not be host associated. */
3024 m
= check_for_implicit_index (&symtree
, &sym
);
3028 gfc_set_sym_referenced (sym
);
3029 sym
->attr
.implied_index
= 0;
3031 if (sym
->attr
.function
&& sym
->result
== sym
)
3033 /* See if this is a directly recursive function call. */
3034 gfc_gobble_whitespace ();
3035 if (sym
->attr
.recursive
3036 && gfc_peek_ascii_char () == '('
3037 && gfc_current_ns
->proc_name
== sym
3038 && !sym
->attr
.dimension
)
3040 gfc_error ("%qs at %C is the name of a recursive function "
3041 "and so refers to the result variable. Use an "
3042 "explicit RESULT variable for direct recursion "
3043 "(12.5.2.1)", sym
->name
);
3047 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3051 && (sym
->ns
== gfc_current_ns
3052 || sym
->ns
== gfc_current_ns
->parent
))
3054 gfc_entry_list
*el
= NULL
;
3056 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3062 if (gfc_matching_procptr_assignment
)
3065 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3068 if (sym
->attr
.generic
)
3069 goto generic_function
;
3071 switch (sym
->attr
.flavor
)
3075 e
= gfc_get_expr ();
3077 e
->expr_type
= EXPR_VARIABLE
;
3078 e
->symtree
= symtree
;
3080 m
= gfc_match_varspec (e
, 0, false, true);
3084 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3085 end up here. Unfortunately, sym->value->expr_type is set to
3086 EXPR_CONSTANT, and so the if () branch would be followed without
3087 the !sym->as check. */
3088 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3089 e
= gfc_copy_expr (sym
->value
);
3092 e
= gfc_get_expr ();
3093 e
->expr_type
= EXPR_VARIABLE
;
3096 e
->symtree
= symtree
;
3097 m
= gfc_match_varspec (e
, 0, false, true);
3099 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3102 /* Variable array references to derived type parameters cause
3103 all sorts of headaches in simplification. Treating such
3104 expressions as variable works just fine for all array
3106 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3108 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3109 if (ref
->type
== REF_ARRAY
)
3112 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3118 e
= gfc_get_expr ();
3119 e
->expr_type
= EXPR_VARIABLE
;
3120 e
->symtree
= symtree
;
3128 sym
= gfc_use_derived (sym
);
3132 goto generic_function
;
3135 /* If we're here, then the name is known to be the name of a
3136 procedure, yet it is not sure to be the name of a function. */
3139 /* Procedure Pointer Assignments. */
3141 if (gfc_matching_procptr_assignment
)
3143 gfc_gobble_whitespace ();
3144 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3145 /* Parse functions returning a procptr. */
3148 e
= gfc_get_expr ();
3149 e
->expr_type
= EXPR_VARIABLE
;
3150 e
->symtree
= symtree
;
3151 m
= gfc_match_varspec (e
, 0, false, true);
3152 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3153 && sym
->ts
.type
== BT_UNKNOWN
3154 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3162 if (sym
->attr
.subroutine
)
3164 gfc_error ("Unexpected use of subroutine name %qs at %C",
3170 /* At this point, the name has to be a non-statement function.
3171 If the name is the same as the current function being
3172 compiled, then we have a variable reference (to the function
3173 result) if the name is non-recursive. */
3175 st
= gfc_enclosing_unit (NULL
);
3178 && st
->state
== COMP_FUNCTION
3180 && !sym
->attr
.recursive
)
3182 e
= gfc_get_expr ();
3183 e
->symtree
= symtree
;
3184 e
->expr_type
= EXPR_VARIABLE
;
3186 m
= gfc_match_varspec (e
, 0, false, true);
3190 /* Match a function reference. */
3192 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3195 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3196 gfc_error ("Statement function %qs requires argument list at %C",
3199 gfc_error ("Function %qs requires an argument list at %C",
3212 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3213 sym
= symtree
->n
.sym
;
3215 replace_hidden_procptr_result (&sym
, &symtree
);
3217 e
= gfc_get_expr ();
3218 e
->symtree
= symtree
;
3219 e
->expr_type
= EXPR_FUNCTION
;
3220 e
->value
.function
.actual
= actual_arglist
;
3221 e
->where
= gfc_current_locus
;
3223 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3224 && CLASS_DATA (sym
)->as
)
3225 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3226 else if (sym
->as
!= NULL
)
3227 e
->rank
= sym
->as
->rank
;
3229 if (!sym
->attr
.function
3230 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3236 /* Check here for the existence of at least one argument for the
3237 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3238 argument(s) given will be checked in gfc_iso_c_func_interface,
3239 during resolution of the function call. */
3240 if (sym
->attr
.is_iso_c
== 1
3241 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3242 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3243 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3244 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3246 /* make sure we were given a param */
3247 if (actual_arglist
== NULL
)
3249 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3255 if (sym
->result
== NULL
)
3263 /* Special case for derived type variables that get their types
3264 via an IMPLICIT statement. This can't wait for the
3265 resolution phase. */
3267 old_loc
= gfc_current_locus
;
3268 if (gfc_match_member_sep (sym
) == MATCH_YES
3269 && sym
->ts
.type
== BT_UNKNOWN
3270 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3271 gfc_set_default_type (sym
, 0, sym
->ns
);
3272 gfc_current_locus
= old_loc
;
3274 /* If the symbol has a (co)dimension attribute, the expression is a
3277 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3279 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3285 e
= gfc_get_expr ();
3286 e
->symtree
= symtree
;
3287 e
->expr_type
= EXPR_VARIABLE
;
3288 m
= gfc_match_varspec (e
, 0, false, true);
3292 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3293 && (CLASS_DATA (sym
)->attr
.dimension
3294 || CLASS_DATA (sym
)->attr
.codimension
))
3296 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3302 e
= gfc_get_expr ();
3303 e
->symtree
= symtree
;
3304 e
->expr_type
= EXPR_VARIABLE
;
3305 m
= gfc_match_varspec (e
, 0, false, true);
3309 /* Name is not an array, so we peek to see if a '(' implies a
3310 function call or a substring reference. Otherwise the
3311 variable is just a scalar. */
3313 gfc_gobble_whitespace ();
3314 if (gfc_peek_ascii_char () != '(')
3316 /* Assume a scalar variable */
3317 e
= gfc_get_expr ();
3318 e
->symtree
= symtree
;
3319 e
->expr_type
= EXPR_VARIABLE
;
3321 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3327 /*FIXME:??? gfc_match_varspec does set this for us: */
3329 m
= gfc_match_varspec (e
, 0, false, true);
3333 /* See if this is a function reference with a keyword argument
3334 as first argument. We do this because otherwise a spurious
3335 symbol would end up in the symbol table. */
3337 old_loc
= gfc_current_locus
;
3338 m2
= gfc_match (" ( %n =", argname
);
3339 gfc_current_locus
= old_loc
;
3341 e
= gfc_get_expr ();
3342 e
->symtree
= symtree
;
3344 if (m2
!= MATCH_YES
)
3346 /* Try to figure out whether we're dealing with a character type.
3347 We're peeking ahead here, because we don't want to call
3348 match_substring if we're dealing with an implicitly typed
3349 non-character variable. */
3350 implicit_char
= false;
3351 if (sym
->ts
.type
== BT_UNKNOWN
)
3353 ts
= gfc_get_default_type (sym
->name
, NULL
);
3354 if (ts
->type
== BT_CHARACTER
)
3355 implicit_char
= true;
3358 /* See if this could possibly be a substring reference of a name
3359 that we're not sure is a variable yet. */
3361 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3362 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3365 e
->expr_type
= EXPR_VARIABLE
;
3367 if (sym
->attr
.flavor
!= FL_VARIABLE
3368 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3375 if (sym
->ts
.type
== BT_UNKNOWN
3376 && !gfc_set_default_type (sym
, 1, NULL
))
3390 /* Give up, assume we have a function. */
3392 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3393 sym
= symtree
->n
.sym
;
3394 e
->expr_type
= EXPR_FUNCTION
;
3396 if (!sym
->attr
.function
3397 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3405 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3407 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3415 /* If our new function returns a character, array or structure
3416 type, it might have subsequent references. */
3418 m
= gfc_match_varspec (e
, 0, false, true);
3425 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3426 specially. Creates a generic symbol for derived types. */
3427 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3429 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3430 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3431 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3433 e
= gfc_get_expr ();
3434 e
->symtree
= symtree
;
3435 e
->expr_type
= EXPR_FUNCTION
;
3437 if (gfc_fl_struct (sym
->attr
.flavor
))
3439 e
->value
.function
.esym
= sym
;
3440 e
->symtree
->n
.sym
->attr
.generic
= 1;
3443 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3451 gfc_error ("Symbol at %C is not appropriate for an expression");
3467 /* Match a variable, i.e. something that can be assigned to. This
3468 starts as a symbol, can be a structure component or an array
3469 reference. It can be a function if the function doesn't have a
3470 separate RESULT variable. If the symbol has not been previously
3471 seen, we assume it is a variable.
3473 This function is called by two interface functions:
3474 gfc_match_variable, which has host_flag = 1, and
3475 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3476 match of the symbol to the local scope. */
3479 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3481 gfc_symbol
*sym
, *dt_sym
;
3484 locus where
, old_loc
;
3487 /* Since nothing has any business being an lvalue in a module
3488 specification block, an interface block or a contains section,
3489 we force the changed_symbols mechanism to work by setting
3490 host_flag to 0. This prevents valid symbols that have the name
3491 of keywords, such as 'end', being turned into variables by
3492 failed matching to assignments for, e.g., END INTERFACE. */
3493 if (gfc_current_state () == COMP_MODULE
3494 || gfc_current_state () == COMP_SUBMODULE
3495 || gfc_current_state () == COMP_INTERFACE
3496 || gfc_current_state () == COMP_CONTAINS
)
3499 where
= gfc_current_locus
;
3500 m
= gfc_match_sym_tree (&st
, host_flag
);
3506 /* If this is an implicit do loop index and implicitly typed,
3507 it should not be host associated. */
3508 m
= check_for_implicit_index (&st
, &sym
);
3512 sym
->attr
.implied_index
= 0;
3514 gfc_set_sym_referenced (sym
);
3516 /* STRUCTUREs may share names with variables, but derived types may not. */
3517 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3518 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3520 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3521 gfc_error ("Derived type '%s' cannot be used as a variable at %C",
3526 switch (sym
->attr
.flavor
)
3529 /* Everything is alright. */
3534 sym_flavor flavor
= FL_UNKNOWN
;
3536 gfc_gobble_whitespace ();
3538 if (sym
->attr
.external
|| sym
->attr
.procedure
3539 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3540 flavor
= FL_PROCEDURE
;
3542 /* If it is not a procedure, is not typed and is host associated,
3543 we cannot give it a flavor yet. */
3544 else if (sym
->ns
== gfc_current_ns
->parent
3545 && sym
->ts
.type
== BT_UNKNOWN
)
3548 /* These are definitive indicators that this is a variable. */
3549 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3550 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3551 flavor
= FL_VARIABLE
;
3553 if (flavor
!= FL_UNKNOWN
3554 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3562 gfc_error ("Named constant at %C in an EQUIVALENCE");
3565 /* Otherwise this is checked for and an error given in the
3566 variable definition context checks. */
3570 /* Check for a nonrecursive function result variable. */
3571 if (sym
->attr
.function
3572 && !sym
->attr
.external
3573 && sym
->result
== sym
3574 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3576 && sym
->ns
== gfc_current_ns
)
3578 && sym
->ns
== gfc_current_ns
->parent
)))
3580 /* If a function result is a derived type, then the derived
3581 type may still have to be resolved. */
3583 if (sym
->ts
.type
== BT_DERIVED
3584 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3589 if (sym
->attr
.proc_pointer
3590 || replace_hidden_procptr_result (&sym
, &st
))
3593 /* Fall through to error */
3597 gfc_error ("%qs at %C is not a variable", sym
->name
);
3601 /* Special case for derived type variables that get their types
3602 via an IMPLICIT statement. This can't wait for the
3603 resolution phase. */
3606 gfc_namespace
* implicit_ns
;
3608 if (gfc_current_ns
->proc_name
== sym
)
3609 implicit_ns
= gfc_current_ns
;
3611 implicit_ns
= sym
->ns
;
3613 old_loc
= gfc_current_locus
;
3614 if (gfc_match_member_sep (sym
) == MATCH_YES
3615 && sym
->ts
.type
== BT_UNKNOWN
3616 && gfc_get_default_type (sym
->name
, implicit_ns
)->type
== BT_DERIVED
)
3617 gfc_set_default_type (sym
, 0, implicit_ns
);
3618 gfc_current_locus
= old_loc
;
3621 expr
= gfc_get_expr ();
3623 expr
->expr_type
= EXPR_VARIABLE
;
3626 expr
->where
= where
;
3628 /* Now see if we have to do more. */
3629 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3632 gfc_free_expr (expr
);
3642 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3644 return match_variable (result
, equiv_flag
, 1);
3649 gfc_match_equiv_variable (gfc_expr
**result
)
3651 return match_variable (result
, 1, 0);