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 gfc_pop_error (&old_error
);
1361 /* If m is error, then something was wrong with the real part and we
1362 assume we have a complex constant because we've seen the ','. An
1363 ambiguous case here is the start of an iterator list of some
1364 sort. These sort of lists are matched prior to coming here. */
1366 if (m
== MATCH_ERROR
)
1368 gfc_free_error (&old_error
);
1371 gfc_pop_error (&old_error
);
1373 m
= match_complex_part (&imag
);
1376 if (m
== MATCH_ERROR
)
1379 m
= gfc_match_char (')');
1382 /* Give the matcher for implied do-loops a chance to run. This
1383 yields a much saner error message for (/ (i, 4=i, 6) /). */
1384 if (gfc_peek_ascii_char () == '=')
1393 if (m
== MATCH_ERROR
)
1396 /* Decide on the kind of this complex number. */
1397 if (real
->ts
.type
== BT_REAL
)
1399 if (imag
->ts
.type
== BT_REAL
)
1400 kind
= gfc_kind_max (real
, imag
);
1402 kind
= real
->ts
.kind
;
1406 if (imag
->ts
.type
== BT_REAL
)
1407 kind
= imag
->ts
.kind
;
1409 kind
= gfc_default_real_kind
;
1411 gfc_clear_ts (&target
);
1412 target
.type
= BT_REAL
;
1415 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1416 gfc_convert_type (real
, &target
, 2);
1417 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1418 gfc_convert_type (imag
, &target
, 2);
1420 e
= gfc_convert_complex (real
, imag
, kind
);
1421 e
->where
= gfc_current_locus
;
1423 gfc_free_expr (real
);
1424 gfc_free_expr (imag
);
1430 gfc_error ("Syntax error in COMPLEX constant at %C");
1435 gfc_free_expr (real
);
1436 gfc_free_expr (imag
);
1437 gfc_current_locus
= old_loc
;
1443 /* Match constants in any of several forms. Returns nonzero for a
1444 match, zero for no match. */
1447 gfc_match_literal_constant (gfc_expr
**result
, int signflag
)
1451 m
= match_complex_constant (result
);
1455 m
= match_string_constant (result
);
1459 m
= match_boz_constant (result
);
1463 m
= match_real_constant (result
, signflag
);
1467 m
= match_hollerith_constant (result
);
1471 m
= match_integer_constant (result
, signflag
);
1475 m
= match_logical_constant (result
);
1483 /* This checks if a symbol is the return value of an encompassing function.
1484 Function nesting can be maximally two levels deep, but we may have
1485 additional local namespaces like BLOCK etc. */
1488 gfc_is_function_return_value (gfc_symbol
*sym
, gfc_namespace
*ns
)
1490 if (!sym
->attr
.function
|| (sym
->result
!= sym
))
1494 if (ns
->proc_name
== sym
)
1502 /* Match a single actual argument value. An actual argument is
1503 usually an expression, but can also be a procedure name. If the
1504 argument is a single name, it is not always possible to tell
1505 whether the name is a dummy procedure or not. We treat these cases
1506 by creating an argument that looks like a dummy procedure and
1507 fixing things later during resolution. */
1510 match_actual_arg (gfc_expr
**result
)
1512 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1513 gfc_symtree
*symtree
;
1518 gfc_gobble_whitespace ();
1519 where
= gfc_current_locus
;
1521 switch (gfc_match_name (name
))
1530 w
= gfc_current_locus
;
1531 gfc_gobble_whitespace ();
1532 c
= gfc_next_ascii_char ();
1533 gfc_current_locus
= w
;
1535 if (c
!= ',' && c
!= ')')
1538 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1540 /* Handle error elsewhere. */
1542 /* Eliminate a couple of common cases where we know we don't
1543 have a function argument. */
1544 if (symtree
== NULL
)
1546 gfc_get_sym_tree (name
, NULL
, &symtree
, false);
1547 gfc_set_sym_referenced (symtree
->n
.sym
);
1553 sym
= symtree
->n
.sym
;
1554 gfc_set_sym_referenced (sym
);
1555 if (sym
->attr
.flavor
== FL_NAMELIST
)
1557 gfc_error ("Namelist '%s' can not be an argument at %L",
1561 if (sym
->attr
.flavor
!= FL_PROCEDURE
1562 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1565 if (sym
->attr
.in_common
&& !sym
->attr
.proc_pointer
)
1567 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1568 sym
->name
, &sym
->declared_at
))
1573 /* If the symbol is a function with itself as the result and
1574 is being defined, then we have a variable. */
1575 if (sym
->attr
.function
&& sym
->result
== sym
)
1577 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
1581 && (sym
->ns
== gfc_current_ns
1582 || sym
->ns
== gfc_current_ns
->parent
))
1584 gfc_entry_list
*el
= NULL
;
1586 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1596 e
= gfc_get_expr (); /* Leave it unknown for now */
1597 e
->symtree
= symtree
;
1598 e
->expr_type
= EXPR_VARIABLE
;
1599 e
->ts
.type
= BT_PROCEDURE
;
1606 gfc_current_locus
= where
;
1607 return gfc_match_expr (result
);
1611 /* Match a keyword argument. */
1614 match_keyword_arg (gfc_actual_arglist
*actual
, gfc_actual_arglist
*base
)
1616 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1617 gfc_actual_arglist
*a
;
1621 name_locus
= gfc_current_locus
;
1622 m
= gfc_match_name (name
);
1626 if (gfc_match_char ('=') != MATCH_YES
)
1632 m
= match_actual_arg (&actual
->expr
);
1636 /* Make sure this name has not appeared yet. */
1638 if (name
[0] != '\0')
1640 for (a
= base
; a
; a
= a
->next
)
1641 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1643 gfc_error ("Keyword %qs at %C has already appeared in the "
1644 "current argument list", name
);
1649 actual
->name
= gfc_get_string (name
);
1653 gfc_current_locus
= name_locus
;
1658 /* Match an argument list function, such as %VAL. */
1661 match_arg_list_function (gfc_actual_arglist
*result
)
1663 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1667 old_locus
= gfc_current_locus
;
1669 if (gfc_match_char ('%') != MATCH_YES
)
1675 m
= gfc_match ("%n (", name
);
1679 if (name
[0] != '\0')
1684 if (strncmp (name
, "loc", 3) == 0)
1686 result
->name
= "%LOC";
1691 if (strncmp (name
, "ref", 3) == 0)
1693 result
->name
= "%REF";
1698 if (strncmp (name
, "val", 3) == 0)
1700 result
->name
= "%VAL";
1710 if (!gfc_notify_std (GFC_STD_GNU
, "argument list function at %C"))
1716 m
= match_actual_arg (&result
->expr
);
1720 if (gfc_match_char (')') != MATCH_YES
)
1729 gfc_current_locus
= old_locus
;
1734 /* Matches an actual argument list of a function or subroutine, from
1735 the opening parenthesis to the closing parenthesis. The argument
1736 list is assumed to allow keyword arguments because we don't know if
1737 the symbol associated with the procedure has an implicit interface
1738 or not. We make sure keywords are unique. If sub_flag is set,
1739 we're matching the argument list of a subroutine. */
1742 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
**argp
)
1744 gfc_actual_arglist
*head
, *tail
;
1746 gfc_st_label
*label
;
1750 *argp
= tail
= NULL
;
1751 old_loc
= gfc_current_locus
;
1755 if (gfc_match_char ('(') == MATCH_NO
)
1756 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1758 if (gfc_match_char (')') == MATCH_YES
)
1762 matching_actual_arglist
++;
1767 head
= tail
= gfc_get_actual_arglist ();
1770 tail
->next
= gfc_get_actual_arglist ();
1774 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1776 m
= gfc_match_st_label (&label
);
1778 gfc_error ("Expected alternate return label at %C");
1782 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
1786 tail
->label
= label
;
1790 /* After the first keyword argument is seen, the following
1791 arguments must also have keywords. */
1794 m
= match_keyword_arg (tail
, head
);
1796 if (m
== MATCH_ERROR
)
1800 gfc_error ("Missing keyword name in actual argument list at %C");
1807 /* Try an argument list function, like %VAL. */
1808 m
= match_arg_list_function (tail
);
1809 if (m
== MATCH_ERROR
)
1812 /* See if we have the first keyword argument. */
1815 m
= match_keyword_arg (tail
, head
);
1818 if (m
== MATCH_ERROR
)
1824 /* Try for a non-keyword argument. */
1825 m
= match_actual_arg (&tail
->expr
);
1826 if (m
== MATCH_ERROR
)
1835 if (gfc_match_char (')') == MATCH_YES
)
1837 if (gfc_match_char (',') != MATCH_YES
)
1842 matching_actual_arglist
--;
1846 gfc_error ("Syntax error in argument list at %C");
1849 gfc_free_actual_arglist (head
);
1850 gfc_current_locus
= old_loc
;
1851 matching_actual_arglist
--;
1856 /* Used by gfc_match_varspec() to extend the reference list by one
1860 extend_ref (gfc_expr
*primary
, gfc_ref
*tail
)
1862 if (primary
->ref
== NULL
)
1863 primary
->ref
= tail
= gfc_get_ref ();
1867 gfc_internal_error ("extend_ref(): Bad tail");
1868 tail
->next
= gfc_get_ref ();
1876 /* Match any additional specifications associated with the current
1877 variable like member references or substrings. If equiv_flag is
1878 set we only match stuff that is allowed inside an EQUIVALENCE
1879 statement. sub_flag tells whether we expect a type-bound procedure found
1880 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1881 components, 'ppc_arg' determines whether the PPC may be called (with an
1882 argument list), or whether it may just be referred to as a pointer. */
1885 gfc_match_varspec (gfc_expr
*primary
, int equiv_flag
, bool sub_flag
,
1888 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1889 gfc_ref
*substring
, *tail
, *tmp
;
1890 gfc_component
*component
;
1891 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1898 gfc_gobble_whitespace ();
1900 if (gfc_peek_ascii_char () == '[')
1902 if ((sym
->ts
.type
!= BT_CLASS
&& sym
->attr
.dimension
)
1903 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1904 && CLASS_DATA (sym
)->attr
.dimension
))
1906 gfc_error ("Array section designator, e.g. '(:)', is required "
1907 "besides the coarray designator '[...]' at %C");
1910 if ((sym
->ts
.type
!= BT_CLASS
&& !sym
->attr
.codimension
)
1911 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
1912 && !CLASS_DATA (sym
)->attr
.codimension
))
1914 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1920 /* For associate names, we may not yet know whether they are arrays or not.
1921 Thus if we have one and parentheses follow, we have to assume that it
1922 actually is one for now. The final decision will be made at
1923 resolution time, of course. */
1924 if (sym
->assoc
&& gfc_peek_ascii_char () == '('
1925 && !(sym
->assoc
->dangling
&& sym
->assoc
->st
1926 && sym
->assoc
->st
->n
.sym
1927 && sym
->assoc
->st
->n
.sym
->attr
.dimension
== 0)
1928 && sym
->ts
.type
!= BT_CLASS
)
1929 sym
->attr
.dimension
= 1;
1931 if ((equiv_flag
&& gfc_peek_ascii_char () == '(')
1932 || gfc_peek_ascii_char () == '[' || sym
->attr
.codimension
1933 || (sym
->attr
.dimension
&& sym
->ts
.type
!= BT_CLASS
1934 && !sym
->attr
.proc_pointer
&& !gfc_is_proc_ptr_comp (primary
)
1935 && !(gfc_matching_procptr_assignment
1936 && sym
->attr
.flavor
== FL_PROCEDURE
))
1937 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1938 && (CLASS_DATA (sym
)->attr
.dimension
1939 || CLASS_DATA (sym
)->attr
.codimension
)))
1943 tail
= extend_ref (primary
, tail
);
1944 tail
->type
= REF_ARRAY
;
1946 /* In EQUIVALENCE, we don't know yet whether we are seeing
1947 an array, character variable or array of character
1948 variables. We'll leave the decision till resolve time. */
1952 else if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
1953 as
= CLASS_DATA (sym
)->as
;
1957 m
= gfc_match_array_ref (&tail
->u
.ar
, as
, equiv_flag
,
1958 as
? as
->corank
: 0);
1962 gfc_gobble_whitespace ();
1963 if (equiv_flag
&& gfc_peek_ascii_char () == '(')
1965 tail
= extend_ref (primary
, tail
);
1966 tail
->type
= REF_ARRAY
;
1968 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
, 0);
1974 primary
->ts
= sym
->ts
;
1979 /* With DEC extensions, member separator may be '.' or '%'. */
1980 sep
= gfc_peek_ascii_char ();
1981 m
= gfc_match_member_sep (sym
);
1982 if (m
== MATCH_ERROR
)
1985 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
1986 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
1987 gfc_set_default_type (sym
, 0, sym
->ns
);
1989 if (sym
->ts
.type
== BT_UNKNOWN
&& m
== MATCH_YES
)
1991 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym
->name
);
1994 else if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
1997 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2002 if ((sym
->ts
.type
!= BT_DERIVED
&& sym
->ts
.type
!= BT_CLASS
)
2004 goto check_substring
;
2006 sym
= sym
->ts
.u
.derived
;
2013 m
= gfc_match_name (name
);
2015 gfc_error ("Expected structure component name at %C");
2019 if (sym
->f2k_derived
)
2020 tbp
= gfc_find_typebound_proc (sym
, &t
, name
, false, &gfc_current_locus
);
2026 gfc_symbol
* tbp_sym
;
2031 gcc_assert (!tail
|| !tail
->next
);
2033 if (!(primary
->expr_type
== EXPR_VARIABLE
2034 || (primary
->expr_type
== EXPR_STRUCTURE
2035 && primary
->symtree
&& primary
->symtree
->n
.sym
2036 && primary
->symtree
->n
.sym
->attr
.flavor
)))
2039 if (tbp
->n
.tb
->is_generic
)
2042 tbp_sym
= tbp
->n
.tb
->u
.specific
->n
.sym
;
2044 primary
->expr_type
= EXPR_COMPCALL
;
2045 primary
->value
.compcall
.tbp
= tbp
->n
.tb
;
2046 primary
->value
.compcall
.name
= tbp
->name
;
2047 primary
->value
.compcall
.ignore_pass
= 0;
2048 primary
->value
.compcall
.assign
= 0;
2049 primary
->value
.compcall
.base_object
= NULL
;
2050 gcc_assert (primary
->symtree
->n
.sym
->attr
.referenced
);
2052 primary
->ts
= tbp_sym
->ts
;
2054 gfc_clear_ts (&primary
->ts
);
2056 m
= gfc_match_actual_arglist (tbp
->n
.tb
->subroutine
,
2057 &primary
->value
.compcall
.actual
);
2058 if (m
== MATCH_ERROR
)
2063 primary
->value
.compcall
.actual
= NULL
;
2066 gfc_error ("Expected argument list at %C");
2074 component
= gfc_find_component (sym
, name
, false, false, &tmp
);
2075 if (component
== NULL
)
2078 /* Extend the reference chain determined by gfc_find_component. */
2079 if (primary
->ref
== NULL
)
2083 /* Set by the for loop below for the last component ref. */
2084 gcc_assert (tail
!= NULL
);
2088 /* The reference chain may be longer than one hop for union
2089 subcomponents; find the new tail. */
2090 for (tail
= tmp
; tail
->next
; tail
= tail
->next
)
2093 primary
->ts
= component
->ts
;
2095 if (component
->attr
.proc_pointer
&& ppc_arg
)
2097 /* Procedure pointer component call: Look for argument list. */
2098 m
= gfc_match_actual_arglist (sub_flag
,
2099 &primary
->value
.compcall
.actual
);
2100 if (m
== MATCH_ERROR
)
2103 if (m
== MATCH_NO
&& !gfc_matching_ptr_assignment
2104 && !gfc_matching_procptr_assignment
&& !matching_actual_arglist
)
2106 gfc_error ("Procedure pointer component %qs requires an "
2107 "argument list at %C", component
->name
);
2112 primary
->expr_type
= EXPR_PPC
;
2117 if (component
->as
!= NULL
&& !component
->attr
.proc_pointer
)
2119 tail
= extend_ref (primary
, tail
);
2120 tail
->type
= REF_ARRAY
;
2122 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
,
2123 component
->as
->corank
);
2127 else if (component
->ts
.type
== BT_CLASS
&& component
->attr
.class_ok
2128 && CLASS_DATA (component
)->as
&& !component
->attr
.proc_pointer
)
2130 tail
= extend_ref (primary
, tail
);
2131 tail
->type
= REF_ARRAY
;
2133 m
= gfc_match_array_ref (&tail
->u
.ar
, CLASS_DATA (component
)->as
,
2135 CLASS_DATA (component
)->as
->corank
);
2140 if ((component
->ts
.type
!= BT_DERIVED
&& component
->ts
.type
!= BT_CLASS
)
2141 || gfc_match_member_sep (component
->ts
.u
.derived
) != MATCH_YES
)
2144 sym
= component
->ts
.u
.derived
;
2149 if (primary
->ts
.type
== BT_UNKNOWN
&& !gfc_fl_struct (sym
->attr
.flavor
))
2151 if (gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_CHARACTER
)
2153 gfc_set_default_type (sym
, 0, sym
->ns
);
2154 primary
->ts
= sym
->ts
;
2159 if (primary
->ts
.type
== BT_CHARACTER
)
2161 bool def
= primary
->ts
.deferred
== 1;
2162 switch (match_substring (primary
->ts
.u
.cl
, equiv_flag
, &substring
, def
))
2166 primary
->ref
= substring
;
2168 tail
->next
= substring
;
2170 if (primary
->expr_type
== EXPR_CONSTANT
)
2171 primary
->expr_type
= EXPR_SUBSTRING
;
2174 primary
->ts
.u
.cl
= NULL
;
2181 gfc_clear_ts (&primary
->ts
);
2182 gfc_clear_ts (&sym
->ts
);
2192 if (primary
->expr_type
== EXPR_PPC
&& gfc_is_coindexed (primary
))
2194 gfc_error ("Coindexed procedure-pointer component at %C");
2202 /* Given an expression that is a variable, figure out what the
2203 ultimate variable's type and attribute is, traversing the reference
2204 structures if necessary.
2206 This subroutine is trickier than it looks. We start at the base
2207 symbol and store the attribute. Component references load a
2208 completely new attribute.
2210 A couple of rules come into play. Subobjects of targets are always
2211 targets themselves. If we see a component that goes through a
2212 pointer, then the expression must also be a target, since the
2213 pointer is associated with something (if it isn't core will soon be
2214 dumped). If we see a full part or section of an array, the
2215 expression is also an array.
2217 We can have at most one full array reference. */
2220 gfc_variable_attr (gfc_expr
*expr
, gfc_typespec
*ts
)
2222 int dimension
, codimension
, pointer
, allocatable
, target
;
2223 symbol_attribute attr
;
2226 gfc_component
*comp
;
2228 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2229 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2231 sym
= expr
->symtree
->n
.sym
;
2234 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2236 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2237 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2238 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2239 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2243 dimension
= attr
.dimension
;
2244 codimension
= attr
.codimension
;
2245 pointer
= attr
.pointer
;
2246 allocatable
= attr
.allocatable
;
2249 target
= attr
.target
;
2250 if (pointer
|| attr
.proc_pointer
)
2253 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
2256 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2261 switch (ref
->u
.ar
.type
)
2268 allocatable
= pointer
= 0;
2273 /* Handle coarrays. */
2274 if (ref
->u
.ar
.dimen
> 0)
2275 allocatable
= pointer
= 0;
2279 /* If any of start, end or stride is not integer, there will
2280 already have been an error issued. */
2282 gfc_get_errors (NULL
, &errors
);
2284 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2290 comp
= ref
->u
.c
.component
;
2295 /* Don't set the string length if a substring reference
2297 if (ts
->type
== BT_CHARACTER
2298 && ref
->next
&& ref
->next
->type
== REF_SUBSTRING
)
2302 if (comp
->ts
.type
== BT_CLASS
)
2304 codimension
= CLASS_DATA (comp
)->attr
.codimension
;
2305 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2306 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2310 codimension
= comp
->attr
.codimension
;
2311 pointer
= comp
->attr
.pointer
;
2312 allocatable
= comp
->attr
.allocatable
;
2314 if (pointer
|| attr
.proc_pointer
)
2320 allocatable
= pointer
= 0;
2324 attr
.dimension
= dimension
;
2325 attr
.codimension
= codimension
;
2326 attr
.pointer
= pointer
;
2327 attr
.allocatable
= allocatable
;
2328 attr
.target
= target
;
2329 attr
.save
= sym
->attr
.save
;
2335 /* Return the attribute from a general expression. */
2338 gfc_expr_attr (gfc_expr
*e
)
2340 symbol_attribute attr
;
2342 switch (e
->expr_type
)
2345 attr
= gfc_variable_attr (e
, NULL
);
2349 gfc_clear_attr (&attr
);
2351 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2353 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2355 if (sym
->ts
.type
== BT_CLASS
)
2357 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2358 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2359 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2362 else if (e
->value
.function
.isym
2363 && e
->value
.function
.isym
->transformational
2364 && e
->ts
.type
== BT_CLASS
)
2365 attr
= CLASS_DATA (e
)->attr
;
2367 attr
= gfc_variable_attr (e
, NULL
);
2369 /* TODO: NULL() returns pointers. May have to take care of this
2375 gfc_clear_attr (&attr
);
2383 /* Given an expression, figure out what the ultimate expression
2384 attribute is. This routine is similar to gfc_variable_attr with
2385 parts of gfc_expr_attr, but focuses more on the needs of
2386 coarrays. For coarrays a codimension attribute is kind of
2387 "infectious" being propagated once set and never cleared. */
2389 static symbol_attribute
2390 caf_variable_attr (gfc_expr
*expr
, bool in_allocate
)
2392 int dimension
, codimension
, pointer
, allocatable
, target
, coarray_comp
,
2394 symbol_attribute attr
;
2397 gfc_component
*comp
;
2399 if (expr
->expr_type
!= EXPR_VARIABLE
&& expr
->expr_type
!= EXPR_FUNCTION
)
2400 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2402 sym
= expr
->symtree
->n
.sym
;
2403 gfc_clear_attr (&attr
);
2405 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
2407 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2408 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
2409 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2410 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2411 coarray_comp
= CLASS_DATA (sym
)->attr
.coarray_comp
;
2412 alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2416 dimension
= sym
->attr
.dimension
;
2417 codimension
= sym
->attr
.codimension
;
2418 pointer
= sym
->attr
.pointer
;
2419 allocatable
= sym
->attr
.allocatable
;
2420 coarray_comp
= sym
->attr
.coarray_comp
;
2421 alloc_comp
= sym
->ts
.type
== BT_DERIVED
2422 ? sym
->ts
.u
.derived
->attr
.alloc_comp
: 0;
2425 target
= attr
.target
;
2426 if (pointer
|| attr
.proc_pointer
)
2429 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
2434 switch (ref
->u
.ar
.type
)
2442 /* Handle coarrays. */
2443 if (ref
->u
.ar
.dimen
> 0 && !in_allocate
)
2444 allocatable
= pointer
= 0;
2448 /* If any of start, end or stride is not integer, there will
2449 already have been an error issued. */
2451 gfc_get_errors (NULL
, &errors
);
2453 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2459 comp
= ref
->u
.c
.component
;
2461 if (comp
->ts
.type
== BT_CLASS
)
2463 codimension
|= CLASS_DATA (comp
)->attr
.codimension
;
2464 pointer
= CLASS_DATA (comp
)->attr
.class_pointer
;
2465 allocatable
= CLASS_DATA (comp
)->attr
.allocatable
;
2466 coarray_comp
|= CLASS_DATA (comp
)->attr
.coarray_comp
;
2470 codimension
|= comp
->attr
.codimension
;
2471 pointer
= comp
->attr
.pointer
;
2472 allocatable
= comp
->attr
.allocatable
;
2473 coarray_comp
|= comp
->attr
.coarray_comp
;
2476 if (pointer
|| attr
.proc_pointer
)
2482 allocatable
= pointer
= 0;
2486 attr
.dimension
= dimension
;
2487 attr
.codimension
= codimension
;
2488 attr
.pointer
= pointer
;
2489 attr
.allocatable
= allocatable
;
2490 attr
.target
= target
;
2491 attr
.save
= sym
->attr
.save
;
2492 attr
.coarray_comp
= coarray_comp
;
2493 attr
.alloc_comp
= alloc_comp
;
2500 gfc_caf_attr (gfc_expr
*e
, bool in_allocate
)
2502 symbol_attribute attr
;
2504 switch (e
->expr_type
)
2507 attr
= caf_variable_attr (e
, in_allocate
);
2511 gfc_clear_attr (&attr
);
2513 if (e
->value
.function
.esym
&& e
->value
.function
.esym
->result
)
2515 gfc_symbol
*sym
= e
->value
.function
.esym
->result
;
2517 if (sym
->ts
.type
== BT_CLASS
)
2519 attr
.dimension
= CLASS_DATA (sym
)->attr
.dimension
;
2520 attr
.pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
2521 attr
.allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
2522 attr
.alloc_comp
= CLASS_DATA (sym
)->ts
.u
.derived
->attr
.alloc_comp
;
2525 else if (e
->symtree
)
2526 attr
= caf_variable_attr (e
, in_allocate
);
2528 gfc_clear_attr (&attr
);
2532 gfc_clear_attr (&attr
);
2540 /* Match a structure constructor. The initial symbol has already been
2543 typedef struct gfc_structure_ctor_component
2548 struct gfc_structure_ctor_component
* next
;
2550 gfc_structure_ctor_component
;
2552 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2555 gfc_free_structure_ctor_component (gfc_structure_ctor_component
*comp
)
2558 gfc_free_expr (comp
->val
);
2563 /* Translate the component list into the actual constructor by sorting it in
2564 the order required; this also checks along the way that each and every
2565 component actually has an initializer and handles default initializers
2566 for components without explicit value given. */
2568 build_actual_constructor (gfc_structure_ctor_component
**comp_head
,
2569 gfc_constructor_base
*ctor_head
, gfc_symbol
*sym
)
2571 gfc_structure_ctor_component
*comp_iter
;
2572 gfc_component
*comp
;
2574 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
2576 gfc_structure_ctor_component
**next_ptr
;
2577 gfc_expr
*value
= NULL
;
2579 /* Try to find the initializer for the current component by name. */
2580 next_ptr
= comp_head
;
2581 for (comp_iter
= *comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2583 if (!strcmp (comp_iter
->name
, comp
->name
))
2585 next_ptr
= &comp_iter
->next
;
2588 /* If an extension, try building the parent derived type by building
2589 a value expression for the parent derived type and calling self. */
2590 if (!comp_iter
&& comp
== sym
->components
&& sym
->attr
.extension
)
2592 value
= gfc_get_structure_constructor_expr (comp
->ts
.type
,
2594 &gfc_current_locus
);
2595 value
->ts
= comp
->ts
;
2597 if (!build_actual_constructor (comp_head
,
2598 &value
->value
.constructor
,
2599 comp
->ts
.u
.derived
))
2601 gfc_free_expr (value
);
2605 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2609 /* If it was not found, try the default initializer if there's any;
2610 otherwise, it's an error unless this is a deferred parameter. */
2613 if (comp
->initializer
)
2615 if (!gfc_notify_std (GFC_STD_F2003
, "Structure constructor "
2616 "with missing optional arguments at %C"))
2618 value
= gfc_copy_expr (comp
->initializer
);
2620 else if (comp
->attr
.allocatable
2621 || (comp
->ts
.type
== BT_CLASS
2622 && CLASS_DATA (comp
)->attr
.allocatable
))
2624 if (!gfc_notify_std (GFC_STD_F2008
, "No initializer for "
2625 "allocatable component '%qs' given in the "
2626 "structure constructor at %C", comp
->name
))
2629 else if (!comp
->attr
.artificial
)
2631 gfc_error ("No initializer for component %qs given in the"
2632 " structure constructor at %C!", comp
->name
);
2637 value
= comp_iter
->val
;
2639 /* Add the value to the constructor chain built. */
2640 gfc_constructor_append_expr (ctor_head
, value
, NULL
);
2642 /* Remove the entry from the component list. We don't want the expression
2643 value to be free'd, so set it to NULL. */
2646 *next_ptr
= comp_iter
->next
;
2647 comp_iter
->val
= NULL
;
2648 gfc_free_structure_ctor_component (comp_iter
);
2656 gfc_convert_to_structure_constructor (gfc_expr
*e
, gfc_symbol
*sym
, gfc_expr
**cexpr
,
2657 gfc_actual_arglist
**arglist
,
2660 gfc_actual_arglist
*actual
;
2661 gfc_structure_ctor_component
*comp_tail
, *comp_head
, *comp_iter
;
2662 gfc_constructor_base ctor_head
= NULL
;
2663 gfc_component
*comp
; /* Is set NULL when named component is first seen */
2664 const char* last_name
= NULL
;
2668 expr
= parent
? *cexpr
: e
;
2669 old_locus
= gfc_current_locus
;
2671 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2673 gfc_current_locus
= expr
->where
;
2675 comp_tail
= comp_head
= NULL
;
2677 if (!parent
&& sym
->attr
.abstract
)
2679 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2680 sym
->name
, &expr
->where
);
2684 comp
= sym
->components
;
2685 actual
= parent
? *arglist
: expr
->value
.function
.actual
;
2688 gfc_component
*this_comp
= NULL
;
2691 comp_tail
= comp_head
= gfc_get_structure_ctor_component ();
2694 comp_tail
->next
= gfc_get_structure_ctor_component ();
2695 comp_tail
= comp_tail
->next
;
2699 if (!gfc_notify_std (GFC_STD_F2003
, "Structure"
2700 " constructor with named arguments at %C"))
2703 comp_tail
->name
= xstrdup (actual
->name
);
2704 last_name
= comp_tail
->name
;
2709 /* Components without name are not allowed after the first named
2710 component initializer! */
2711 if (!comp
|| comp
->attr
.artificial
)
2714 gfc_error ("Component initializer without name after component"
2715 " named %s at %L!", last_name
,
2716 actual
->expr
? &actual
->expr
->where
2717 : &gfc_current_locus
);
2719 gfc_error ("Too many components in structure constructor at "
2720 "%L!", actual
->expr
? &actual
->expr
->where
2721 : &gfc_current_locus
);
2725 comp_tail
->name
= xstrdup (comp
->name
);
2728 /* Find the current component in the structure definition and check
2729 its access is not private. */
2731 this_comp
= gfc_find_component (sym
, comp
->name
, false, false, NULL
);
2734 this_comp
= gfc_find_component (sym
, (const char *)comp_tail
->name
,
2735 false, false, NULL
);
2736 comp
= NULL
; /* Reset needed! */
2739 /* Here we can check if a component name is given which does not
2740 correspond to any component of the defined structure. */
2744 comp_tail
->val
= actual
->expr
;
2745 if (actual
->expr
!= NULL
)
2746 comp_tail
->where
= actual
->expr
->where
;
2747 actual
->expr
= NULL
;
2749 /* Check if this component is already given a value. */
2750 for (comp_iter
= comp_head
; comp_iter
!= comp_tail
;
2751 comp_iter
= comp_iter
->next
)
2753 gcc_assert (comp_iter
);
2754 if (!strcmp (comp_iter
->name
, comp_tail
->name
))
2756 gfc_error ("Component %qs is initialized twice in the structure"
2757 " constructor at %L!", comp_tail
->name
,
2758 comp_tail
->val
? &comp_tail
->where
2759 : &gfc_current_locus
);
2764 /* F2008, R457/C725, for PURE C1283. */
2765 if (this_comp
->attr
.pointer
&& comp_tail
->val
2766 && gfc_is_coindexed (comp_tail
->val
))
2768 gfc_error ("Coindexed expression to pointer component %qs in "
2769 "structure constructor at %L!", comp_tail
->name
,
2774 /* If not explicitly a parent constructor, gather up the components
2776 if (comp
&& comp
== sym
->components
2777 && sym
->attr
.extension
2779 && (!gfc_bt_struct (comp_tail
->val
->ts
.type
)
2781 comp_tail
->val
->ts
.u
.derived
!= this_comp
->ts
.u
.derived
))
2784 gfc_actual_arglist
*arg_null
= NULL
;
2786 actual
->expr
= comp_tail
->val
;
2787 comp_tail
->val
= NULL
;
2789 m
= gfc_convert_to_structure_constructor (NULL
,
2790 comp
->ts
.u
.derived
, &comp_tail
->val
,
2791 comp
->ts
.u
.derived
->attr
.zero_comp
2792 ? &arg_null
: &actual
, true);
2796 if (comp
->ts
.u
.derived
->attr
.zero_comp
)
2805 if (parent
&& !comp
)
2809 actual
= actual
->next
;
2812 if (!build_actual_constructor (&comp_head
, &ctor_head
, sym
))
2815 /* No component should be left, as this should have caused an error in the
2816 loop constructing the component-list (name that does not correspond to any
2817 component in the structure definition). */
2818 if (comp_head
&& sym
->attr
.extension
)
2820 for (comp_iter
= comp_head
; comp_iter
; comp_iter
= comp_iter
->next
)
2822 gfc_error ("component %qs at %L has already been set by a "
2823 "parent derived type constructor", comp_iter
->name
,
2829 gcc_assert (!comp_head
);
2833 expr
= gfc_get_structure_constructor_expr (BT_DERIVED
, 0, &gfc_current_locus
);
2834 expr
->ts
.u
.derived
= sym
;
2835 expr
->value
.constructor
= ctor_head
;
2840 expr
->ts
.u
.derived
= sym
;
2842 expr
->ts
.type
= BT_DERIVED
;
2843 expr
->value
.constructor
= ctor_head
;
2844 expr
->expr_type
= EXPR_STRUCTURE
;
2847 gfc_current_locus
= old_locus
;
2853 gfc_current_locus
= old_locus
;
2855 for (comp_iter
= comp_head
; comp_iter
; )
2857 gfc_structure_ctor_component
*next
= comp_iter
->next
;
2858 gfc_free_structure_ctor_component (comp_iter
);
2861 gfc_constructor_free (ctor_head
);
2868 gfc_match_structure_constructor (gfc_symbol
*sym
, gfc_expr
**result
)
2872 gfc_symtree
*symtree
;
2874 gfc_get_ha_sym_tree (sym
->name
, &symtree
);
2876 e
= gfc_get_expr ();
2877 e
->symtree
= symtree
;
2878 e
->expr_type
= EXPR_FUNCTION
;
2880 gcc_assert (gfc_fl_struct (sym
->attr
.flavor
)
2881 && symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
);
2882 e
->value
.function
.esym
= sym
;
2883 e
->symtree
->n
.sym
->attr
.generic
= 1;
2885 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2892 if (!gfc_convert_to_structure_constructor (e
, sym
, NULL
, NULL
, false))
2898 /* If a structure constructor is in a DATA statement, then each entity
2899 in the structure constructor must be a constant. Try to reduce the
2901 if (gfc_in_match_data ())
2902 gfc_reduce_init_expr (e
);
2909 /* If the symbol is an implicit do loop index and implicitly typed,
2910 it should not be host associated. Provide a symtree from the
2911 current namespace. */
2913 check_for_implicit_index (gfc_symtree
**st
, gfc_symbol
**sym
)
2915 if ((*sym
)->attr
.flavor
== FL_VARIABLE
2916 && (*sym
)->ns
!= gfc_current_ns
2917 && (*sym
)->attr
.implied_index
2918 && (*sym
)->attr
.implicit_type
2919 && !(*sym
)->attr
.use_assoc
)
2922 i
= gfc_get_sym_tree ((*sym
)->name
, NULL
, st
, false);
2925 *sym
= (*st
)->n
.sym
;
2931 /* Procedure pointer as function result: Replace the function symbol by the
2932 auto-generated hidden result variable named "ppr@". */
2935 replace_hidden_procptr_result (gfc_symbol
**sym
, gfc_symtree
**st
)
2937 /* Check for procedure pointer result variable. */
2938 if ((*sym
)->attr
.function
&& !(*sym
)->attr
.external
2939 && (*sym
)->result
&& (*sym
)->result
!= *sym
2940 && (*sym
)->result
->attr
.proc_pointer
2941 && (*sym
) == gfc_current_ns
->proc_name
2942 && (*sym
) == (*sym
)->result
->ns
->proc_name
2943 && strcmp ("ppr@", (*sym
)->result
->name
) == 0)
2945 /* Automatic replacement with "hidden" result variable. */
2946 (*sym
)->result
->attr
.referenced
= (*sym
)->attr
.referenced
;
2947 *sym
= (*sym
)->result
;
2948 *st
= gfc_find_symtree ((*sym
)->ns
->sym_root
, (*sym
)->name
);
2955 /* Matches a variable name followed by anything that might follow it--
2956 array reference, argument list of a function, etc. */
2959 gfc_match_rvalue (gfc_expr
**result
)
2961 gfc_actual_arglist
*actual_arglist
;
2962 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
2965 gfc_symtree
*symtree
;
2966 locus where
, old_loc
;
2974 m
= gfc_match ("%%loc");
2977 if (!gfc_notify_std (GFC_STD_LEGACY
, "%%LOC() as an rvalue at %C"))
2979 strncpy (name
, "loc", 4);
2984 m
= gfc_match_name (name
);
2989 /* Check if the symbol exists. */
2990 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
2993 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
2994 type. For derived types we create a generic symbol which links to the
2995 derived type symbol; STRUCTUREs are simpler and must not conflict with
2998 if (gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
))
3000 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3002 if (gfc_find_state (COMP_INTERFACE
)
3003 && !gfc_current_ns
->has_import_set
)
3004 i
= gfc_get_sym_tree (name
, NULL
, &symtree
, false);
3006 i
= gfc_get_ha_sym_tree (name
, &symtree
);
3012 sym
= symtree
->n
.sym
;
3014 where
= gfc_current_locus
;
3016 replace_hidden_procptr_result (&sym
, &symtree
);
3018 /* If this is an implicit do loop index and implicitly typed,
3019 it should not be host associated. */
3020 m
= check_for_implicit_index (&symtree
, &sym
);
3024 gfc_set_sym_referenced (sym
);
3025 sym
->attr
.implied_index
= 0;
3027 if (sym
->attr
.function
&& sym
->result
== sym
)
3029 /* See if this is a directly recursive function call. */
3030 gfc_gobble_whitespace ();
3031 if (sym
->attr
.recursive
3032 && gfc_peek_ascii_char () == '('
3033 && gfc_current_ns
->proc_name
== sym
3034 && !sym
->attr
.dimension
)
3036 gfc_error ("%qs at %C is the name of a recursive function "
3037 "and so refers to the result variable. Use an "
3038 "explicit RESULT variable for direct recursion "
3039 "(12.5.2.1)", sym
->name
);
3043 if (gfc_is_function_return_value (sym
, gfc_current_ns
))
3047 && (sym
->ns
== gfc_current_ns
3048 || sym
->ns
== gfc_current_ns
->parent
))
3050 gfc_entry_list
*el
= NULL
;
3052 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
3058 if (gfc_matching_procptr_assignment
)
3061 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
3064 if (sym
->attr
.generic
)
3065 goto generic_function
;
3067 switch (sym
->attr
.flavor
)
3071 e
= gfc_get_expr ();
3073 e
->expr_type
= EXPR_VARIABLE
;
3074 e
->symtree
= symtree
;
3076 m
= gfc_match_varspec (e
, 0, false, true);
3080 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3081 end up here. Unfortunately, sym->value->expr_type is set to
3082 EXPR_CONSTANT, and so the if () branch would be followed without
3083 the !sym->as check. */
3084 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
3085 e
= gfc_copy_expr (sym
->value
);
3088 e
= gfc_get_expr ();
3089 e
->expr_type
= EXPR_VARIABLE
;
3092 e
->symtree
= symtree
;
3093 m
= gfc_match_varspec (e
, 0, false, true);
3095 if (sym
->ts
.is_c_interop
|| sym
->ts
.is_iso_c
)
3098 /* Variable array references to derived type parameters cause
3099 all sorts of headaches in simplification. Treating such
3100 expressions as variable works just fine for all array
3102 if (sym
->value
&& sym
->ts
.type
== BT_DERIVED
&& e
->ref
)
3104 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3105 if (ref
->type
== REF_ARRAY
)
3108 if (ref
== NULL
|| ref
->u
.ar
.type
== AR_FULL
)
3114 e
= gfc_get_expr ();
3115 e
->expr_type
= EXPR_VARIABLE
;
3116 e
->symtree
= symtree
;
3124 sym
= gfc_use_derived (sym
);
3128 goto generic_function
;
3131 /* If we're here, then the name is known to be the name of a
3132 procedure, yet it is not sure to be the name of a function. */
3135 /* Procedure Pointer Assignments. */
3137 if (gfc_matching_procptr_assignment
)
3139 gfc_gobble_whitespace ();
3140 if (!sym
->attr
.dimension
&& gfc_peek_ascii_char () == '(')
3141 /* Parse functions returning a procptr. */
3144 e
= gfc_get_expr ();
3145 e
->expr_type
= EXPR_VARIABLE
;
3146 e
->symtree
= symtree
;
3147 m
= gfc_match_varspec (e
, 0, false, true);
3148 if (!e
->ref
&& sym
->attr
.flavor
== FL_UNKNOWN
3149 && sym
->ts
.type
== BT_UNKNOWN
3150 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
3158 if (sym
->attr
.subroutine
)
3160 gfc_error ("Unexpected use of subroutine name %qs at %C",
3166 /* At this point, the name has to be a non-statement function.
3167 If the name is the same as the current function being
3168 compiled, then we have a variable reference (to the function
3169 result) if the name is non-recursive. */
3171 st
= gfc_enclosing_unit (NULL
);
3174 && st
->state
== COMP_FUNCTION
3176 && !sym
->attr
.recursive
)
3178 e
= gfc_get_expr ();
3179 e
->symtree
= symtree
;
3180 e
->expr_type
= EXPR_VARIABLE
;
3182 m
= gfc_match_varspec (e
, 0, false, true);
3186 /* Match a function reference. */
3188 m
= gfc_match_actual_arglist (0, &actual_arglist
);
3191 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
3192 gfc_error ("Statement function %qs requires argument list at %C",
3195 gfc_error ("Function %qs requires an argument list at %C",
3208 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
3209 sym
= symtree
->n
.sym
;
3211 replace_hidden_procptr_result (&sym
, &symtree
);
3213 e
= gfc_get_expr ();
3214 e
->symtree
= symtree
;
3215 e
->expr_type
= EXPR_FUNCTION
;
3216 e
->value
.function
.actual
= actual_arglist
;
3217 e
->where
= gfc_current_locus
;
3219 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3220 && CLASS_DATA (sym
)->as
)
3221 e
->rank
= CLASS_DATA (sym
)->as
->rank
;
3222 else if (sym
->as
!= NULL
)
3223 e
->rank
= sym
->as
->rank
;
3225 if (!sym
->attr
.function
3226 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3232 /* Check here for the existence of at least one argument for the
3233 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3234 argument(s) given will be checked in gfc_iso_c_func_interface,
3235 during resolution of the function call. */
3236 if (sym
->attr
.is_iso_c
== 1
3237 && (sym
->from_intmod
== INTMOD_ISO_C_BINDING
3238 && (sym
->intmod_sym_id
== ISOCBINDING_LOC
3239 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
3240 || sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)))
3242 /* make sure we were given a param */
3243 if (actual_arglist
== NULL
)
3245 gfc_error ("Missing argument to %qs at %C", sym
->name
);
3251 if (sym
->result
== NULL
)
3259 /* Special case for derived type variables that get their types
3260 via an IMPLICIT statement. This can't wait for the
3261 resolution phase. */
3263 old_loc
= gfc_current_locus
;
3264 if (gfc_match_member_sep (sym
) == MATCH_YES
3265 && sym
->ts
.type
== BT_UNKNOWN
3266 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_DERIVED
)
3267 gfc_set_default_type (sym
, 0, sym
->ns
);
3268 gfc_current_locus
= old_loc
;
3270 /* If the symbol has a (co)dimension attribute, the expression is a
3273 if (sym
->attr
.dimension
|| sym
->attr
.codimension
)
3275 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3281 e
= gfc_get_expr ();
3282 e
->symtree
= symtree
;
3283 e
->expr_type
= EXPR_VARIABLE
;
3284 m
= gfc_match_varspec (e
, 0, false, true);
3288 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
3289 && (CLASS_DATA (sym
)->attr
.dimension
3290 || CLASS_DATA (sym
)->attr
.codimension
))
3292 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3298 e
= gfc_get_expr ();
3299 e
->symtree
= symtree
;
3300 e
->expr_type
= EXPR_VARIABLE
;
3301 m
= gfc_match_varspec (e
, 0, false, true);
3305 /* Name is not an array, so we peek to see if a '(' implies a
3306 function call or a substring reference. Otherwise the
3307 variable is just a scalar. */
3309 gfc_gobble_whitespace ();
3310 if (gfc_peek_ascii_char () != '(')
3312 /* Assume a scalar variable */
3313 e
= gfc_get_expr ();
3314 e
->symtree
= symtree
;
3315 e
->expr_type
= EXPR_VARIABLE
;
3317 if (!gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, NULL
))
3323 /*FIXME:??? gfc_match_varspec does set this for us: */
3325 m
= gfc_match_varspec (e
, 0, false, true);
3329 /* See if this is a function reference with a keyword argument
3330 as first argument. We do this because otherwise a spurious
3331 symbol would end up in the symbol table. */
3333 old_loc
= gfc_current_locus
;
3334 m2
= gfc_match (" ( %n =", argname
);
3335 gfc_current_locus
= old_loc
;
3337 e
= gfc_get_expr ();
3338 e
->symtree
= symtree
;
3340 if (m2
!= MATCH_YES
)
3342 /* Try to figure out whether we're dealing with a character type.
3343 We're peeking ahead here, because we don't want to call
3344 match_substring if we're dealing with an implicitly typed
3345 non-character variable. */
3346 implicit_char
= false;
3347 if (sym
->ts
.type
== BT_UNKNOWN
)
3349 ts
= gfc_get_default_type (sym
->name
, NULL
);
3350 if (ts
->type
== BT_CHARACTER
)
3351 implicit_char
= true;
3354 /* See if this could possibly be a substring reference of a name
3355 that we're not sure is a variable yet. */
3357 if ((implicit_char
|| sym
->ts
.type
== BT_CHARACTER
)
3358 && match_substring (sym
->ts
.u
.cl
, 0, &e
->ref
, false) == MATCH_YES
)
3361 e
->expr_type
= EXPR_VARIABLE
;
3363 if (sym
->attr
.flavor
!= FL_VARIABLE
3364 && !gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
3371 if (sym
->ts
.type
== BT_UNKNOWN
3372 && !gfc_set_default_type (sym
, 1, NULL
))
3386 /* Give up, assume we have a function. */
3388 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3389 sym
= symtree
->n
.sym
;
3390 e
->expr_type
= EXPR_FUNCTION
;
3392 if (!sym
->attr
.function
3393 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3401 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3403 gfc_error ("Missing argument list in function %qs at %C", sym
->name
);
3411 /* If our new function returns a character, array or structure
3412 type, it might have subsequent references. */
3414 m
= gfc_match_varspec (e
, 0, false, true);
3421 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3422 specially. Creates a generic symbol for derived types. */
3423 gfc_find_sym_tree (name
, NULL
, 1, &symtree
);
3425 gfc_find_sym_tree (gfc_dt_upper_string (name
), NULL
, 1, &symtree
);
3426 if (!symtree
|| symtree
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
3427 gfc_get_sym_tree (name
, NULL
, &symtree
, false); /* Can't fail */
3429 e
= gfc_get_expr ();
3430 e
->symtree
= symtree
;
3431 e
->expr_type
= EXPR_FUNCTION
;
3433 if (gfc_fl_struct (sym
->attr
.flavor
))
3435 e
->value
.function
.esym
= sym
;
3436 e
->symtree
->n
.sym
->attr
.generic
= 1;
3439 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
3447 gfc_error ("Symbol at %C is not appropriate for an expression");
3463 /* Match a variable, i.e. something that can be assigned to. This
3464 starts as a symbol, can be a structure component or an array
3465 reference. It can be a function if the function doesn't have a
3466 separate RESULT variable. If the symbol has not been previously
3467 seen, we assume it is a variable.
3469 This function is called by two interface functions:
3470 gfc_match_variable, which has host_flag = 1, and
3471 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3472 match of the symbol to the local scope. */
3475 match_variable (gfc_expr
**result
, int equiv_flag
, int host_flag
)
3477 gfc_symbol
*sym
, *dt_sym
;
3480 locus where
, old_loc
;
3483 /* Since nothing has any business being an lvalue in a module
3484 specification block, an interface block or a contains section,
3485 we force the changed_symbols mechanism to work by setting
3486 host_flag to 0. This prevents valid symbols that have the name
3487 of keywords, such as 'end', being turned into variables by
3488 failed matching to assignments for, e.g., END INTERFACE. */
3489 if (gfc_current_state () == COMP_MODULE
3490 || gfc_current_state () == COMP_SUBMODULE
3491 || gfc_current_state () == COMP_INTERFACE
3492 || gfc_current_state () == COMP_CONTAINS
)
3495 where
= gfc_current_locus
;
3496 m
= gfc_match_sym_tree (&st
, host_flag
);
3502 /* If this is an implicit do loop index and implicitly typed,
3503 it should not be host associated. */
3504 m
= check_for_implicit_index (&st
, &sym
);
3508 sym
->attr
.implied_index
= 0;
3510 gfc_set_sym_referenced (sym
);
3512 /* STRUCTUREs may share names with variables, but derived types may not. */
3513 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->generic
3514 && (dt_sym
= gfc_find_dt_in_generic (sym
)))
3516 if (dt_sym
->attr
.flavor
== FL_DERIVED
)
3517 gfc_error ("Derived type '%s' cannot be used as a variable at %C",
3522 switch (sym
->attr
.flavor
)
3525 /* Everything is alright. */
3530 sym_flavor flavor
= FL_UNKNOWN
;
3532 gfc_gobble_whitespace ();
3534 if (sym
->attr
.external
|| sym
->attr
.procedure
3535 || sym
->attr
.function
|| sym
->attr
.subroutine
)
3536 flavor
= FL_PROCEDURE
;
3538 /* If it is not a procedure, is not typed and is host associated,
3539 we cannot give it a flavor yet. */
3540 else if (sym
->ns
== gfc_current_ns
->parent
3541 && sym
->ts
.type
== BT_UNKNOWN
)
3544 /* These are definitive indicators that this is a variable. */
3545 else if (gfc_peek_ascii_char () != '(' || sym
->ts
.type
!= BT_UNKNOWN
3546 || sym
->attr
.pointer
|| sym
->as
!= NULL
)
3547 flavor
= FL_VARIABLE
;
3549 if (flavor
!= FL_UNKNOWN
3550 && !gfc_add_flavor (&sym
->attr
, flavor
, sym
->name
, NULL
))
3558 gfc_error ("Named constant at %C in an EQUIVALENCE");
3561 /* Otherwise this is checked for and an error given in the
3562 variable definition context checks. */
3566 /* Check for a nonrecursive function result variable. */
3567 if (sym
->attr
.function
3568 && !sym
->attr
.external
3569 && sym
->result
== sym
3570 && (gfc_is_function_return_value (sym
, gfc_current_ns
)
3572 && sym
->ns
== gfc_current_ns
)
3574 && sym
->ns
== gfc_current_ns
->parent
)))
3576 /* If a function result is a derived type, then the derived
3577 type may still have to be resolved. */
3579 if (sym
->ts
.type
== BT_DERIVED
3580 && gfc_use_derived (sym
->ts
.u
.derived
) == NULL
)
3585 if (sym
->attr
.proc_pointer
3586 || replace_hidden_procptr_result (&sym
, &st
))
3589 /* Fall through to error */
3593 gfc_error ("%qs at %C is not a variable", sym
->name
);
3597 /* Special case for derived type variables that get their types
3598 via an IMPLICIT statement. This can't wait for the
3599 resolution phase. */
3602 gfc_namespace
* implicit_ns
;
3604 if (gfc_current_ns
->proc_name
== sym
)
3605 implicit_ns
= gfc_current_ns
;
3607 implicit_ns
= sym
->ns
;
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
, implicit_ns
)->type
== BT_DERIVED
)
3613 gfc_set_default_type (sym
, 0, implicit_ns
);
3614 gfc_current_locus
= old_loc
;
3617 expr
= gfc_get_expr ();
3619 expr
->expr_type
= EXPR_VARIABLE
;
3622 expr
->where
= where
;
3624 /* Now see if we have to do more. */
3625 m
= gfc_match_varspec (expr
, equiv_flag
, false, false);
3628 gfc_free_expr (expr
);
3638 gfc_match_variable (gfc_expr
**result
, int equiv_flag
)
3640 return match_variable (result
, equiv_flag
, 1);
3645 gfc_match_equiv_variable (gfc_expr
**result
)
3647 return match_variable (result
, 1, 0);