1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
32 int matching_actual_arglist = 0;
34 /* Matches a kind-parameter expression, which is either a named
35 symbolic constant or a nonnegative integer constant. If
36 successful, sets the kind value to the correct integer.
37 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
38 symbol like e.g. 'c_int'. */
41 match_kind_param (int *kind, int *is_iso_c)
43 char name[GFC_MAX_SYMBOL_LEN + 1];
50 m = gfc_match_small_literal_int (kind, NULL);
54 m = gfc_match_name (name);
58 if (gfc_find_symbol (name, NULL, 1, &sym))
64 *is_iso_c = sym->attr.is_iso_c;
66 if (sym->attr.flavor != FL_PARAMETER)
69 if (sym->value == NULL)
72 p = gfc_extract_int (sym->value, kind);
76 gfc_set_sym_referenced (sym);
85 /* Get a trailing kind-specification for non-character variables.
87 * the integer kind value or
88 * -1 if an error was generated,
89 * -2 if no kind was found.
90 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
91 symbol like e.g. 'c_int'. */
94 get_kind (int *is_iso_c)
101 if (gfc_match_char ('_') != MATCH_YES)
104 m = match_kind_param (&kind, is_iso_c);
106 gfc_error ("Missing kind-parameter at %C");
108 return (m == MATCH_YES) ? kind : -1;
112 /* Given a character and a radix, see if the character is a valid
113 digit in that radix. */
116 gfc_check_digit (char c, int radix)
123 r = ('0' <= c && c <= '1');
127 r = ('0' <= c && c <= '7');
131 r = ('0' <= c && c <= '9');
139 gfc_internal_error ("gfc_check_digit(): bad radix");
146 /* Match the digit string part of an integer if signflag is not set,
147 the signed digit string part if signflag is set. If the buffer
148 is NULL, we just count characters for the resolution pass. Returns
149 the number of characters matched, -1 for no match. */
152 match_digits (int signflag, int radix, char *buffer)
159 c = gfc_next_ascii_char ();
161 if (signflag && (c == '+' || c == '-'))
165 gfc_gobble_whitespace ();
166 c = gfc_next_ascii_char ();
170 if (!gfc_check_digit (c, radix))
179 old_loc = gfc_current_locus;
180 c = gfc_next_ascii_char ();
182 if (!gfc_check_digit (c, radix))
190 gfc_current_locus = old_loc;
196 /* Match an integer (digit string and optional kind).
197 A sign will be accepted if signflag is set. */
200 match_integer_constant (gfc_expr **result, int signflag)
202 int length, kind, is_iso_c;
207 old_loc = gfc_current_locus;
208 gfc_gobble_whitespace ();
210 length = match_digits (signflag, 10, NULL);
211 gfc_current_locus = old_loc;
215 buffer = (char *) alloca (length + 1);
216 memset (buffer, '\0', length + 1);
218 gfc_gobble_whitespace ();
220 match_digits (signflag, 10, buffer);
222 kind = get_kind (&is_iso_c);
224 kind = gfc_default_integer_kind;
228 if (kind == 4 && gfc_option.flag_integer4_kind == 8)
231 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
233 gfc_error ("Integer kind %d at %C not available", kind);
237 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
238 e->ts.is_c_interop = is_iso_c;
240 if (gfc_range_check (e) != ARITH_OK)
242 gfc_error ("Integer too big for its kind at %C. This check can be "
243 "disabled with the option -fno-range-check");
254 /* Match a Hollerith constant. */
257 match_hollerith_constant (gfc_expr **result)
265 old_loc = gfc_current_locus;
266 gfc_gobble_whitespace ();
268 if (match_integer_constant (&e, 0) == MATCH_YES
269 && gfc_match_char ('h') == MATCH_YES)
271 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
275 msg = gfc_extract_int (e, &num);
283 gfc_error ("Invalid Hollerith constant: %L must contain at least "
284 "one character", &old_loc);
287 if (e->ts.kind != gfc_default_integer_kind)
289 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
290 "should be default", &old_loc);
296 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
299 /* Calculate padding needed to fit default integer memory. */
300 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
302 e->representation.string = XCNEWVEC (char, num + pad + 1);
304 for (i = 0; i < num; i++)
306 gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
307 if (! gfc_wide_fits_in_byte (c))
309 gfc_error ("Invalid Hollerith constant at %L contains a "
310 "wide character", &old_loc);
314 e->representation.string[i] = (unsigned char) c;
317 /* Now pad with blanks and end with a null char. */
318 for (i = 0; i < pad; i++)
319 e->representation.string[num + i] = ' ';
321 e->representation.string[num + i] = '\0';
322 e->representation.length = num + pad;
331 gfc_current_locus = old_loc;
340 /* Match a binary, octal or hexadecimal constant that can be found in
341 a DATA statement. The standard permits b'010...', o'73...', and
342 z'a1...' where b, o, and z can be capital letters. This function
343 also accepts postfixed forms of the constants: '01...'b, '73...'o,
344 and 'a1...'z. An additional extension is the use of x for z. */
347 match_boz_constant (gfc_expr **result)
349 int radix, length, x_hex, kind;
350 locus old_loc, start_loc;
351 char *buffer, post, delim;
354 start_loc = old_loc = gfc_current_locus;
355 gfc_gobble_whitespace ();
358 switch (post = gfc_next_ascii_char ())
380 radix = 16; /* Set to accept any valid digit string. */
386 /* No whitespace allowed here. */
389 delim = gfc_next_ascii_char ();
391 if (delim != '\'' && delim != '\"')
395 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
396 "constant at %C uses non-standard syntax")
400 old_loc = gfc_current_locus;
402 length = match_digits (0, radix, NULL);
405 gfc_error ("Empty set of digits in BOZ constant at %C");
409 if (gfc_next_ascii_char () != delim)
411 gfc_error ("Illegal character in BOZ constant at %C");
417 switch (gfc_next_ascii_char ())
434 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
435 "at %C uses non-standard postfix syntax")
440 gfc_current_locus = old_loc;
442 buffer = (char *) alloca (length + 1);
443 memset (buffer, '\0', length + 1);
445 match_digits (0, radix, buffer);
446 gfc_next_ascii_char (); /* Eat delimiter. */
448 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
450 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
451 "If a data-stmt-constant is a boz-literal-constant, the corresponding
452 variable shall be of type integer. The boz-literal-constant is treated
453 as if it were an int-literal-constant with a kind-param that specifies
454 the representation method with the largest decimal exponent range
455 supported by the processor." */
457 kind = gfc_max_integer_kind;
458 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
460 /* Mark as boz variable. */
463 if (gfc_range_check (e) != ARITH_OK)
465 gfc_error ("Integer too big for integer kind %i at %C", kind);
470 if (!gfc_in_match_data ()
471 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
480 gfc_current_locus = start_loc;
485 /* Match a real constant of some sort. Allow a signed constant if signflag
489 match_real_constant (gfc_expr **result, int signflag)
491 int kind, count, seen_dp, seen_digits, is_iso_c;
492 locus old_loc, temp_loc;
493 char *p, *buffer, c, exp_char;
497 old_loc = gfc_current_locus;
498 gfc_gobble_whitespace ();
508 c = gfc_next_ascii_char ();
509 if (signflag && (c == '+' || c == '-'))
514 gfc_gobble_whitespace ();
515 c = gfc_next_ascii_char ();
518 /* Scan significand. */
519 for (;; c = gfc_next_ascii_char (), count++)
526 /* Check to see if "." goes with a following operator like
528 temp_loc = gfc_current_locus;
529 c = gfc_next_ascii_char ();
531 if (c == 'e' || c == 'd' || c == 'q')
533 c = gfc_next_ascii_char ();
535 goto done; /* Operator named .e. or .d. */
539 goto done; /* Distinguish 1.e9 from 1.eq.2 */
541 gfc_current_locus = temp_loc;
555 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
562 if (gfc_notify_std (GFC_STD_GNU, "Extension: exponent-letter 'q' in "
563 "real-literal-constant at %C") == FAILURE)
565 else if (gfc_option.warn_real_q_constant)
566 gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
571 c = gfc_next_ascii_char ();
574 if (c == '+' || c == '-')
575 { /* optional sign */
576 c = gfc_next_ascii_char ();
582 gfc_error ("Missing exponent in real number at %C");
588 c = gfc_next_ascii_char ();
593 /* Check that we have a numeric constant. */
594 if (!seen_digits || (!seen_dp && exp_char == ' '))
596 gfc_current_locus = old_loc;
600 /* Convert the number. */
601 gfc_current_locus = old_loc;
602 gfc_gobble_whitespace ();
604 buffer = (char *) alloca (count + 1);
605 memset (buffer, '\0', count + 1);
608 c = gfc_next_ascii_char ();
609 if (c == '+' || c == '-')
611 gfc_gobble_whitespace ();
612 c = gfc_next_ascii_char ();
615 /* Hack for mpfr_set_str(). */
618 if (c == 'd' || c == 'q')
626 c = gfc_next_ascii_char ();
629 kind = get_kind (&is_iso_c);
638 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
642 kind = gfc_default_double_kind;
646 if (gfc_option.flag_real4_kind == 8)
648 if (gfc_option.flag_real4_kind == 10)
650 if (gfc_option.flag_real4_kind == 16)
656 if (gfc_option.flag_real8_kind == 4)
658 if (gfc_option.flag_real8_kind == 10)
660 if (gfc_option.flag_real8_kind == 16)
668 gfc_error ("Real number at %C has a 'q' exponent and an explicit "
673 /* The maximum possible real kind type parameter is 16. First, try
674 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
675 extended precision. If neither value works, just given up. */
677 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
680 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
682 gfc_error ("Invalid exponent-letter 'q' in "
683 "real-literal-constant at %C");
691 kind = gfc_default_real_kind;
695 if (gfc_option.flag_real4_kind == 8)
697 if (gfc_option.flag_real4_kind == 10)
699 if (gfc_option.flag_real4_kind == 16)
705 if (gfc_option.flag_real8_kind == 4)
707 if (gfc_option.flag_real8_kind == 10)
709 if (gfc_option.flag_real8_kind == 16)
713 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
715 gfc_error ("Invalid real kind %d at %C", kind);
720 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
722 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
723 e->ts.is_c_interop = is_iso_c;
725 switch (gfc_range_check (e))
730 gfc_error ("Real constant overflows its kind at %C");
733 case ARITH_UNDERFLOW:
734 if (gfc_option.warn_underflow)
735 gfc_warning ("Real constant underflows its kind at %C");
736 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
740 gfc_internal_error ("gfc_range_check() returned bad value");
752 /* Match a substring reference. */
755 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
757 gfc_expr *start, *end;
765 old_loc = gfc_current_locus;
767 m = gfc_match_char ('(');
771 if (gfc_match_char (':') != MATCH_YES)
774 m = gfc_match_init_expr (&start);
776 m = gfc_match_expr (&start);
784 m = gfc_match_char (':');
789 if (gfc_match_char (')') != MATCH_YES)
792 m = gfc_match_init_expr (&end);
794 m = gfc_match_expr (&end);
798 if (m == MATCH_ERROR)
801 m = gfc_match_char (')');
806 /* Optimize away the (:) reference. */
807 if (start == NULL && end == NULL)
811 ref = gfc_get_ref ();
813 ref->type = REF_SUBSTRING;
815 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
816 ref->u.ss.start = start;
817 if (end == NULL && cl)
818 end = gfc_copy_expr (cl->length);
820 ref->u.ss.length = cl;
827 gfc_error ("Syntax error in SUBSTRING specification at %C");
831 gfc_free_expr (start);
834 gfc_current_locus = old_loc;
839 /* Reads the next character of a string constant, taking care to
840 return doubled delimiters on the input as a single instance of
843 Special return values for "ret" argument are:
844 -1 End of the string, as determined by the delimiter
845 -2 Unterminated string detected
847 Backslash codes are also expanded at this time. */
850 next_string_char (gfc_char_t delimiter, int *ret)
855 c = gfc_next_char_literal (INSTRING_WARN);
864 if (gfc_option.flag_backslash && c == '\\')
866 old_locus = gfc_current_locus;
868 if (gfc_match_special_char (&c) == MATCH_NO)
869 gfc_current_locus = old_locus;
871 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
872 gfc_warning ("Extension: backslash character at %C");
878 old_locus = gfc_current_locus;
879 c = gfc_next_char_literal (NONSTRING);
883 gfc_current_locus = old_locus;
890 /* Special case of gfc_match_name() that matches a parameter kind name
891 before a string constant. This takes case of the weird but legal
896 where kind____ is a parameter. gfc_match_name() will happily slurp
897 up all the underscores, which leads to problems. If we return
898 MATCH_YES, the parse pointer points to the final underscore, which
899 is not part of the name. We never return MATCH_ERROR-- errors in
900 the name will be detected later. */
903 match_charkind_name (char *name)
909 gfc_gobble_whitespace ();
910 c = gfc_next_ascii_char ();
919 old_loc = gfc_current_locus;
920 c = gfc_next_ascii_char ();
924 peek = gfc_peek_ascii_char ();
926 if (peek == '\'' || peek == '\"')
928 gfc_current_locus = old_loc;
936 && (c != '$' || !gfc_option.flag_dollar_ok))
940 if (++len > GFC_MAX_SYMBOL_LEN)
948 /* See if the current input matches a character constant. Lots of
949 contortions have to be done to match the kind parameter which comes
950 before the actual string. The main consideration is that we don't
951 want to error out too quickly. For example, we don't actually do
952 any validation of the kinds until we have actually seen a legal
953 delimiter. Using match_kind_param() generates errors too quickly. */
956 match_string_constant (gfc_expr **result)
958 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
959 int i, kind, length, warn_ampersand, ret;
960 locus old_locus, start_locus;
965 gfc_char_t c, delimiter, *p;
967 old_locus = gfc_current_locus;
969 gfc_gobble_whitespace ();
971 c = gfc_next_char ();
972 if (c == '\'' || c == '"')
974 kind = gfc_default_character_kind;
975 start_locus = gfc_current_locus;
979 if (gfc_wide_is_digit (c))
983 while (gfc_wide_is_digit (c))
985 kind = kind * 10 + c - '0';
988 c = gfc_next_char ();
994 gfc_current_locus = old_locus;
996 m = match_charkind_name (name);
1000 if (gfc_find_symbol (name, NULL, 1, &sym)
1002 || sym->attr.flavor != FL_PARAMETER)
1006 c = gfc_next_char ();
1011 gfc_gobble_whitespace ();
1012 c = gfc_next_char ();
1018 gfc_gobble_whitespace ();
1020 c = gfc_next_char ();
1021 if (c != '\'' && c != '"')
1024 start_locus = gfc_current_locus;
1028 q = gfc_extract_int (sym->value, &kind);
1034 gfc_set_sym_referenced (sym);
1037 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1039 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
1044 /* Scan the string into a block of memory by first figuring out how
1045 long it is, allocating the structure, then re-reading it. This
1046 isn't particularly efficient, but string constants aren't that
1047 common in most code. TODO: Use obstacks? */
1054 c = next_string_char (delimiter, &ret);
1059 gfc_current_locus = start_locus;
1060 gfc_error ("Unterminated character constant beginning at %C");
1067 /* Peek at the next character to see if it is a b, o, z, or x for the
1068 postfixed BOZ literal constants. */
1069 peek = gfc_peek_ascii_char ();
1070 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
1073 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
1075 gfc_current_locus = start_locus;
1077 /* We disable the warning for the following loop as the warning has already
1078 been printed in the loop above. */
1079 warn_ampersand = gfc_option.warn_ampersand;
1080 gfc_option.warn_ampersand = 0;
1082 p = e->value.character.string;
1083 for (i = 0; i < length; i++)
1085 c = next_string_char (delimiter, &ret);
1087 if (!gfc_check_character_range (c, kind))
1089 gfc_error ("Character '%s' in string at %C is not representable "
1090 "in character kind %d", gfc_print_wide_char (c), kind);
1097 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1098 gfc_option.warn_ampersand = warn_ampersand;
1100 next_string_char (delimiter, &ret);
1102 gfc_internal_error ("match_string_constant(): Delimiter not found");
1104 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1105 e->expr_type = EXPR_SUBSTRING;
1112 gfc_current_locus = old_locus;
1117 /* Match a .true. or .false. Returns 1 if a .true. was found,
1118 0 if a .false. was found, and -1 otherwise. */
1120 match_logical_constant_string (void)
1122 locus orig_loc = gfc_current_locus;
1124 gfc_gobble_whitespace ();
1125 if (gfc_next_ascii_char () == '.')
1127 char ch = gfc_next_ascii_char ();
1130 if (gfc_next_ascii_char () == 'a'
1131 && gfc_next_ascii_char () == 'l'
1132 && gfc_next_ascii_char () == 's'
1133 && gfc_next_ascii_char () == 'e'
1134 && gfc_next_ascii_char () == '.')
1135 /* Matched ".false.". */
1140 if (gfc_next_ascii_char () == 'r'
1141 && gfc_next_ascii_char () == 'u'
1142 && gfc_next_ascii_char () == 'e'
1143 && gfc_next_ascii_char () == '.')
1144 /* Matched ".true.". */
1148 gfc_current_locus = orig_loc;
1152 /* Match a .true. or .false. */
1155 match_logical_constant (gfc_expr **result)
1158 int i, kind, is_iso_c;
1160 i = match_logical_constant_string ();
1164 kind = get_kind (&is_iso_c);
1168 kind = gfc_default_logical_kind;
1170 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1172 gfc_error ("Bad kind for logical constant at %C");
1176 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1177 e->ts.is_c_interop = is_iso_c;
1184 /* Match a real or imaginary part of a complex constant that is a
1185 symbolic constant. */
1188 match_sym_complex_part (gfc_expr **result)
1190 char name[GFC_MAX_SYMBOL_LEN + 1];
1195 m = gfc_match_name (name);
1199 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1202 if (sym->attr.flavor != FL_PARAMETER)
1204 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1208 if (!gfc_numeric_ts (&sym->value->ts))
1210 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1214 if (sym->value->rank != 0)
1216 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1220 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1221 "complex constant at %C") == FAILURE)
1224 switch (sym->value->ts.type)
1227 e = gfc_copy_expr (sym->value);
1231 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1237 e = gfc_int2real (sym->value, gfc_default_real_kind);
1243 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1246 *result = e; /* e is a scalar, real, constant expression. */
1250 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1255 /* Match a real or imaginary part of a complex number. */
1258 match_complex_part (gfc_expr **result)
1262 m = match_sym_complex_part (result);
1266 m = match_real_constant (result, 1);
1270 return match_integer_constant (result, 1);
1274 /* Try to match a complex constant. */
1277 match_complex_constant (gfc_expr **result)
1279 gfc_expr *e, *real, *imag;
1280 gfc_error_buf old_error;
1281 gfc_typespec target;
1286 old_loc = gfc_current_locus;
1287 real = imag = e = NULL;
1289 m = gfc_match_char ('(');
1293 gfc_push_error (&old_error);
1295 m = match_complex_part (&real);
1298 gfc_free_error (&old_error);
1302 if (gfc_match_char (',') == MATCH_NO)
1304 gfc_pop_error (&old_error);
1309 /* If m is error, then something was wrong with the real part and we
1310 assume we have a complex constant because we've seen the ','. An
1311 ambiguous case here is the start of an iterator list of some
1312 sort. These sort of lists are matched prior to coming here. */
1314 if (m == MATCH_ERROR)
1316 gfc_free_error (&old_error);
1319 gfc_pop_error (&old_error);
1321 m = match_complex_part (&imag);
1324 if (m == MATCH_ERROR)
1327 m = gfc_match_char (')');
1330 /* Give the matcher for implied do-loops a chance to run. This
1331 yields a much saner error message for (/ (i, 4=i, 6) /). */
1332 if (gfc_peek_ascii_char () == '=')
1341 if (m == MATCH_ERROR)
1344 /* Decide on the kind of this complex number. */
1345 if (real->ts.type == BT_REAL)
1347 if (imag->ts.type == BT_REAL)
1348 kind = gfc_kind_max (real, imag);
1350 kind = real->ts.kind;
1354 if (imag->ts.type == BT_REAL)
1355 kind = imag->ts.kind;
1357 kind = gfc_default_real_kind;
1359 gfc_clear_ts (&target);
1360 target.type = BT_REAL;
1363 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1364 gfc_convert_type (real, &target, 2);
1365 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1366 gfc_convert_type (imag, &target, 2);
1368 e = gfc_convert_complex (real, imag, kind);
1369 e->where = gfc_current_locus;
1371 gfc_free_expr (real);
1372 gfc_free_expr (imag);
1378 gfc_error ("Syntax error in COMPLEX constant at %C");
1383 gfc_free_expr (real);
1384 gfc_free_expr (imag);
1385 gfc_current_locus = old_loc;
1391 /* Match constants in any of several forms. Returns nonzero for a
1392 match, zero for no match. */
1395 gfc_match_literal_constant (gfc_expr **result, int signflag)
1399 m = match_complex_constant (result);
1403 m = match_string_constant (result);
1407 m = match_boz_constant (result);
1411 m = match_real_constant (result, signflag);
1415 m = match_hollerith_constant (result);
1419 m = match_integer_constant (result, signflag);
1423 m = match_logical_constant (result);
1431 /* This checks if a symbol is the return value of an encompassing function.
1432 Function nesting can be maximally two levels deep, but we may have
1433 additional local namespaces like BLOCK etc. */
1436 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1438 if (!sym->attr.function || (sym->result != sym))
1442 if (ns->proc_name == sym)
1450 /* Match a single actual argument value. An actual argument is
1451 usually an expression, but can also be a procedure name. If the
1452 argument is a single name, it is not always possible to tell
1453 whether the name is a dummy procedure or not. We treat these cases
1454 by creating an argument that looks like a dummy procedure and
1455 fixing things later during resolution. */
1458 match_actual_arg (gfc_expr **result)
1460 char name[GFC_MAX_SYMBOL_LEN + 1];
1461 gfc_symtree *symtree;
1466 gfc_gobble_whitespace ();
1467 where = gfc_current_locus;
1469 switch (gfc_match_name (name))
1478 w = gfc_current_locus;
1479 gfc_gobble_whitespace ();
1480 c = gfc_next_ascii_char ();
1481 gfc_current_locus = w;
1483 if (c != ',' && c != ')')
1486 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1488 /* Handle error elsewhere. */
1490 /* Eliminate a couple of common cases where we know we don't
1491 have a function argument. */
1492 if (symtree == NULL)
1494 gfc_get_sym_tree (name, NULL, &symtree, false);
1495 gfc_set_sym_referenced (symtree->n.sym);
1501 sym = symtree->n.sym;
1502 gfc_set_sym_referenced (sym);
1503 if (sym->attr.flavor != FL_PROCEDURE
1504 && sym->attr.flavor != FL_UNKNOWN)
1507 if (sym->attr.in_common && !sym->attr.proc_pointer)
1509 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1514 /* If the symbol is a function with itself as the result and
1515 is being defined, then we have a variable. */
1516 if (sym->attr.function && sym->result == sym)
1518 if (gfc_is_function_return_value (sym, gfc_current_ns))
1522 && (sym->ns == gfc_current_ns
1523 || sym->ns == gfc_current_ns->parent))
1525 gfc_entry_list *el = NULL;
1527 for (el = sym->ns->entries; el; el = el->next)
1537 e = gfc_get_expr (); /* Leave it unknown for now */
1538 e->symtree = symtree;
1539 e->expr_type = EXPR_VARIABLE;
1540 e->ts.type = BT_PROCEDURE;
1547 gfc_current_locus = where;
1548 return gfc_match_expr (result);
1552 /* Match a keyword argument. */
1555 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1557 char name[GFC_MAX_SYMBOL_LEN + 1];
1558 gfc_actual_arglist *a;
1562 name_locus = gfc_current_locus;
1563 m = gfc_match_name (name);
1567 if (gfc_match_char ('=') != MATCH_YES)
1573 m = match_actual_arg (&actual->expr);
1577 /* Make sure this name has not appeared yet. */
1579 if (name[0] != '\0')
1581 for (a = base; a; a = a->next)
1582 if (a->name != NULL && strcmp (a->name, name) == 0)
1584 gfc_error ("Keyword '%s' at %C has already appeared in the "
1585 "current argument list", name);
1590 actual->name = gfc_get_string (name);
1594 gfc_current_locus = name_locus;
1599 /* Match an argument list function, such as %VAL. */
1602 match_arg_list_function (gfc_actual_arglist *result)
1604 char name[GFC_MAX_SYMBOL_LEN + 1];
1608 old_locus = gfc_current_locus;
1610 if (gfc_match_char ('%') != MATCH_YES)
1616 m = gfc_match ("%n (", name);
1620 if (name[0] != '\0')
1625 if (strncmp (name, "loc", 3) == 0)
1627 result->name = "%LOC";
1631 if (strncmp (name, "ref", 3) == 0)
1633 result->name = "%REF";
1637 if (strncmp (name, "val", 3) == 0)
1639 result->name = "%VAL";
1648 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1649 "function at %C") == FAILURE)
1655 m = match_actual_arg (&result->expr);
1659 if (gfc_match_char (')') != MATCH_YES)
1668 gfc_current_locus = old_locus;
1673 /* Matches an actual argument list of a function or subroutine, from
1674 the opening parenthesis to the closing parenthesis. The argument
1675 list is assumed to allow keyword arguments because we don't know if
1676 the symbol associated with the procedure has an implicit interface
1677 or not. We make sure keywords are unique. If sub_flag is set,
1678 we're matching the argument list of a subroutine. */
1681 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1683 gfc_actual_arglist *head, *tail;
1685 gfc_st_label *label;
1689 *argp = tail = NULL;
1690 old_loc = gfc_current_locus;
1694 if (gfc_match_char ('(') == MATCH_NO)
1695 return (sub_flag) ? MATCH_YES : MATCH_NO;
1697 if (gfc_match_char (')') == MATCH_YES)
1701 matching_actual_arglist++;
1706 head = tail = gfc_get_actual_arglist ();
1709 tail->next = gfc_get_actual_arglist ();
1713 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1715 m = gfc_match_st_label (&label);
1717 gfc_error ("Expected alternate return label at %C");
1721 tail->label = label;
1725 /* After the first keyword argument is seen, the following
1726 arguments must also have keywords. */
1729 m = match_keyword_arg (tail, head);
1731 if (m == MATCH_ERROR)
1735 gfc_error ("Missing keyword name in actual argument list at %C");
1742 /* Try an argument list function, like %VAL. */
1743 m = match_arg_list_function (tail);
1744 if (m == MATCH_ERROR)
1747 /* See if we have the first keyword argument. */
1750 m = match_keyword_arg (tail, head);
1753 if (m == MATCH_ERROR)
1759 /* Try for a non-keyword argument. */
1760 m = match_actual_arg (&tail->expr);
1761 if (m == MATCH_ERROR)
1770 if (gfc_match_char (')') == MATCH_YES)
1772 if (gfc_match_char (',') != MATCH_YES)
1777 matching_actual_arglist--;
1781 gfc_error ("Syntax error in argument list at %C");
1784 gfc_free_actual_arglist (head);
1785 gfc_current_locus = old_loc;
1786 matching_actual_arglist--;
1791 /* Used by gfc_match_varspec() to extend the reference list by one
1795 extend_ref (gfc_expr *primary, gfc_ref *tail)
1797 if (primary->ref == NULL)
1798 primary->ref = tail = gfc_get_ref ();
1802 gfc_internal_error ("extend_ref(): Bad tail");
1803 tail->next = gfc_get_ref ();
1811 /* Match any additional specifications associated with the current
1812 variable like member references or substrings. If equiv_flag is
1813 set we only match stuff that is allowed inside an EQUIVALENCE
1814 statement. sub_flag tells whether we expect a type-bound procedure found
1815 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1816 components, 'ppc_arg' determines whether the PPC may be called (with an
1817 argument list), or whether it may just be referred to as a pointer. */
1820 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1823 char name[GFC_MAX_SYMBOL_LEN + 1];
1824 gfc_ref *substring, *tail;
1825 gfc_component *component;
1826 gfc_symbol *sym = primary->symtree->n.sym;
1832 gfc_gobble_whitespace ();
1834 if (gfc_peek_ascii_char () == '[')
1836 if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
1837 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
1838 && CLASS_DATA (sym)->attr.dimension))
1840 gfc_error ("Array section designator, e.g. '(:)', is required "
1841 "besides the coarray designator '[...]' at %C");
1844 if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
1845 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
1846 && !CLASS_DATA (sym)->attr.codimension))
1848 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1854 /* For associate names, we may not yet know whether they are arrays or not.
1855 Thus if we have one and parentheses follow, we have to assume that it
1856 actually is one for now. The final decision will be made at
1857 resolution time, of course. */
1858 if (sym->assoc && gfc_peek_ascii_char () == '(')
1859 sym->attr.dimension = 1;
1861 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1862 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1863 || (sym->attr.dimension && sym->ts.type != BT_CLASS
1864 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL)
1865 && !(gfc_matching_procptr_assignment
1866 && sym->attr.flavor == FL_PROCEDURE))
1867 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1868 && (CLASS_DATA (sym)->attr.dimension
1869 || CLASS_DATA (sym)->attr.codimension)))
1873 tail = extend_ref (primary, tail);
1874 tail->type = REF_ARRAY;
1876 /* In EQUIVALENCE, we don't know yet whether we are seeing
1877 an array, character variable or array of character
1878 variables. We'll leave the decision till resolve time. */
1882 else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
1883 as = CLASS_DATA (sym)->as;
1887 m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
1888 as ? as->corank : 0);
1892 gfc_gobble_whitespace ();
1893 if (equiv_flag && gfc_peek_ascii_char () == '(')
1895 tail = extend_ref (primary, tail);
1896 tail->type = REF_ARRAY;
1898 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1904 primary->ts = sym->ts;
1909 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1910 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1911 gfc_set_default_type (sym, 0, sym->ns);
1913 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1914 || gfc_match_char ('%') != MATCH_YES)
1915 goto check_substring;
1917 sym = sym->ts.u.derived;
1924 m = gfc_match_name (name);
1926 gfc_error ("Expected structure component name at %C");
1930 if (sym->f2k_derived)
1931 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1937 gfc_symbol* tbp_sym;
1942 gcc_assert (!tail || !tail->next);
1943 gcc_assert (primary->expr_type == EXPR_VARIABLE
1944 || (primary->expr_type == EXPR_STRUCTURE
1945 && primary->symtree && primary->symtree->n.sym
1946 && primary->symtree->n.sym->attr.flavor));
1948 if (tbp->n.tb->is_generic)
1951 tbp_sym = tbp->n.tb->u.specific->n.sym;
1953 primary->expr_type = EXPR_COMPCALL;
1954 primary->value.compcall.tbp = tbp->n.tb;
1955 primary->value.compcall.name = tbp->name;
1956 primary->value.compcall.ignore_pass = 0;
1957 primary->value.compcall.assign = 0;
1958 primary->value.compcall.base_object = NULL;
1959 gcc_assert (primary->symtree->n.sym->attr.referenced);
1961 primary->ts = tbp_sym->ts;
1963 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1964 &primary->value.compcall.actual);
1965 if (m == MATCH_ERROR)
1970 primary->value.compcall.actual = NULL;
1973 gfc_error ("Expected argument list at %C");
1981 component = gfc_find_component (sym, name, false, false);
1982 if (component == NULL)
1985 tail = extend_ref (primary, tail);
1986 tail->type = REF_COMPONENT;
1988 tail->u.c.component = component;
1989 tail->u.c.sym = sym;
1991 primary->ts = component->ts;
1993 if (component->attr.proc_pointer && ppc_arg
1994 && !gfc_matching_procptr_assignment)
1996 /* Procedure pointer component call: Look for argument list. */
1997 m = gfc_match_actual_arglist (sub_flag,
1998 &primary->value.compcall.actual);
1999 if (m == MATCH_ERROR)
2002 if (m == MATCH_NO && !gfc_matching_ptr_assignment
2003 && !matching_actual_arglist)
2005 gfc_error ("Procedure pointer component '%s' requires an "
2006 "argument list at %C", component->name);
2011 primary->expr_type = EXPR_PPC;
2016 if (component->as != NULL && !component->attr.proc_pointer)
2018 tail = extend_ref (primary, tail);
2019 tail->type = REF_ARRAY;
2021 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
2022 component->as->corank);
2026 else if (component->ts.type == BT_CLASS
2027 && CLASS_DATA (component)->as != NULL
2028 && !component->attr.proc_pointer)
2030 tail = extend_ref (primary, tail);
2031 tail->type = REF_ARRAY;
2033 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
2035 CLASS_DATA (component)->as->corank);
2040 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
2041 || gfc_match_char ('%') != MATCH_YES)
2044 sym = component->ts.u.derived;
2049 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
2051 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
2053 gfc_set_default_type (sym, 0, sym->ns);
2054 primary->ts = sym->ts;
2059 if (primary->ts.type == BT_CHARACTER)
2061 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
2065 primary->ref = substring;
2067 tail->next = substring;
2069 if (primary->expr_type == EXPR_CONSTANT)
2070 primary->expr_type = EXPR_SUBSTRING;
2073 primary->ts.u.cl = NULL;
2080 gfc_clear_ts (&primary->ts);
2081 gfc_clear_ts (&sym->ts);
2091 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
2093 gfc_error ("Coindexed procedure-pointer component at %C");
2101 /* Given an expression that is a variable, figure out what the
2102 ultimate variable's type and attribute is, traversing the reference
2103 structures if necessary.
2105 This subroutine is trickier than it looks. We start at the base
2106 symbol and store the attribute. Component references load a
2107 completely new attribute.
2109 A couple of rules come into play. Subobjects of targets are always
2110 targets themselves. If we see a component that goes through a
2111 pointer, then the expression must also be a target, since the
2112 pointer is associated with something (if it isn't core will soon be
2113 dumped). If we see a full part or section of an array, the
2114 expression is also an array.
2116 We can have at most one full array reference. */
2119 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2121 int dimension, pointer, allocatable, target;
2122 symbol_attribute attr;
2125 gfc_component *comp;
2127 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2128 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2130 sym = expr->symtree->n.sym;
2133 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2135 dimension = CLASS_DATA (sym)->attr.dimension;
2136 pointer = CLASS_DATA (sym)->attr.class_pointer;
2137 allocatable = CLASS_DATA (sym)->attr.allocatable;
2141 dimension = attr.dimension;
2142 pointer = attr.pointer;
2143 allocatable = attr.allocatable;
2146 target = attr.target;
2147 if (pointer || attr.proc_pointer)
2150 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2153 for (ref = expr->ref; ref; ref = ref->next)
2158 switch (ref->u.ar.type)
2165 allocatable = pointer = 0;
2170 /* Handle coarrays. */
2171 if (ref->u.ar.dimen > 0)
2172 allocatable = pointer = 0;
2176 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2182 comp = ref->u.c.component;
2187 /* Don't set the string length if a substring reference
2189 if (ts->type == BT_CHARACTER
2190 && ref->next && ref->next->type == REF_SUBSTRING)
2194 if (comp->ts.type == BT_CLASS)
2196 pointer = CLASS_DATA (comp)->attr.class_pointer;
2197 allocatable = CLASS_DATA (comp)->attr.allocatable;
2201 pointer = comp->attr.pointer;
2202 allocatable = comp->attr.allocatable;
2204 if (pointer || attr.proc_pointer)
2210 allocatable = pointer = 0;
2214 attr.dimension = dimension;
2215 attr.pointer = pointer;
2216 attr.allocatable = allocatable;
2217 attr.target = target;
2218 attr.save = sym->attr.save;
2224 /* Return the attribute from a general expression. */
2227 gfc_expr_attr (gfc_expr *e)
2229 symbol_attribute attr;
2231 switch (e->expr_type)
2234 attr = gfc_variable_attr (e, NULL);
2238 gfc_clear_attr (&attr);
2240 if (e->value.function.esym != NULL)
2242 gfc_symbol *sym = e->value.function.esym->result;
2244 if (sym->ts.type == BT_CLASS)
2246 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2247 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2248 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2252 attr = gfc_variable_attr (e, NULL);
2254 /* TODO: NULL() returns pointers. May have to take care of this
2260 gfc_clear_attr (&attr);
2268 /* Match a structure constructor. The initial symbol has already been
2271 typedef struct gfc_structure_ctor_component
2276 struct gfc_structure_ctor_component* next;
2278 gfc_structure_ctor_component;
2280 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2283 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2286 gfc_free_expr (comp->val);
2291 /* Translate the component list into the actual constructor by sorting it in
2292 the order required; this also checks along the way that each and every
2293 component actually has an initializer and handles default initializers
2294 for components without explicit value given. */
2296 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2297 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2299 gfc_structure_ctor_component *comp_iter;
2300 gfc_component *comp;
2302 for (comp = sym->components; comp; comp = comp->next)
2304 gfc_structure_ctor_component **next_ptr;
2305 gfc_expr *value = NULL;
2307 /* Try to find the initializer for the current component by name. */
2308 next_ptr = comp_head;
2309 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2311 if (!strcmp (comp_iter->name, comp->name))
2313 next_ptr = &comp_iter->next;
2316 /* If an extension, try building the parent derived type by building
2317 a value expression for the parent derived type and calling self. */
2318 if (!comp_iter && comp == sym->components && sym->attr.extension)
2320 value = gfc_get_structure_constructor_expr (comp->ts.type,
2322 &gfc_current_locus);
2323 value->ts = comp->ts;
2325 if (build_actual_constructor (comp_head, &value->value.constructor,
2326 comp->ts.u.derived) == FAILURE)
2328 gfc_free_expr (value);
2332 gfc_constructor_append_expr (ctor_head, value, NULL);
2336 /* If it was not found, try the default initializer if there's any;
2337 otherwise, it's an error. */
2340 if (comp->initializer)
2342 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2343 " constructor with missing optional arguments"
2344 " at %C") == FAILURE)
2346 value = gfc_copy_expr (comp->initializer);
2350 gfc_error ("No initializer for component '%s' given in the"
2351 " structure constructor at %C!", comp->name);
2356 value = comp_iter->val;
2358 /* Add the value to the constructor chain built. */
2359 gfc_constructor_append_expr (ctor_head, value, NULL);
2361 /* Remove the entry from the component list. We don't want the expression
2362 value to be free'd, so set it to NULL. */
2365 *next_ptr = comp_iter->next;
2366 comp_iter->val = NULL;
2367 gfc_free_structure_ctor_component (comp_iter);
2375 gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
2376 gfc_actual_arglist **arglist,
2379 gfc_actual_arglist *actual;
2380 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2381 gfc_constructor_base ctor_head = NULL;
2382 gfc_component *comp; /* Is set NULL when named component is first seen */
2383 const char* last_name = NULL;
2387 expr = parent ? *cexpr : e;
2388 old_locus = gfc_current_locus;
2390 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2392 gfc_current_locus = expr->where;
2394 comp_tail = comp_head = NULL;
2396 if (!parent && sym->attr.abstract)
2398 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2399 sym->name, &expr->where);
2403 comp = sym->components;
2404 actual = parent ? *arglist : expr->value.function.actual;
2407 gfc_component *this_comp = NULL;
2410 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2413 comp_tail->next = gfc_get_structure_ctor_component ();
2414 comp_tail = comp_tail->next;
2418 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2419 " constructor with named arguments at %C")
2423 comp_tail->name = xstrdup (actual->name);
2424 last_name = comp_tail->name;
2429 /* Components without name are not allowed after the first named
2430 component initializer! */
2434 gfc_error ("Component initializer without name after component"
2435 " named %s at %L!", last_name,
2436 actual->expr ? &actual->expr->where
2437 : &gfc_current_locus);
2439 gfc_error ("Too many components in structure constructor at "
2440 "%L!", actual->expr ? &actual->expr->where
2441 : &gfc_current_locus);
2445 comp_tail->name = xstrdup (comp->name);
2448 /* Find the current component in the structure definition and check
2449 its access is not private. */
2451 this_comp = gfc_find_component (sym, comp->name, false, false);
2454 this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2456 comp = NULL; /* Reset needed! */
2459 /* Here we can check if a component name is given which does not
2460 correspond to any component of the defined structure. */
2464 comp_tail->val = actual->expr;
2465 if (actual->expr != NULL)
2466 comp_tail->where = actual->expr->where;
2467 actual->expr = NULL;
2469 /* Check if this component is already given a value. */
2470 for (comp_iter = comp_head; comp_iter != comp_tail;
2471 comp_iter = comp_iter->next)
2473 gcc_assert (comp_iter);
2474 if (!strcmp (comp_iter->name, comp_tail->name))
2476 gfc_error ("Component '%s' is initialized twice in the structure"
2477 " constructor at %L!", comp_tail->name,
2478 comp_tail->val ? &comp_tail->where
2479 : &gfc_current_locus);
2484 /* F2008, R457/C725, for PURE C1283. */
2485 if (this_comp->attr.pointer && comp_tail->val
2486 && gfc_is_coindexed (comp_tail->val))
2488 gfc_error ("Coindexed expression to pointer component '%s' in "
2489 "structure constructor at %L!", comp_tail->name,
2494 /* If not explicitly a parent constructor, gather up the components
2496 if (comp && comp == sym->components
2497 && sym->attr.extension
2499 && (comp_tail->val->ts.type != BT_DERIVED
2501 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2504 gfc_actual_arglist *arg_null = NULL;
2506 actual->expr = comp_tail->val;
2507 comp_tail->val = NULL;
2509 m = gfc_convert_to_structure_constructor (NULL,
2510 comp->ts.u.derived, &comp_tail->val,
2511 comp->ts.u.derived->attr.zero_comp
2512 ? &arg_null : &actual, true);
2516 if (comp->ts.u.derived->attr.zero_comp)
2525 if (parent && !comp)
2528 actual = actual->next;
2531 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2534 /* No component should be left, as this should have caused an error in the
2535 loop constructing the component-list (name that does not correspond to any
2536 component in the structure definition). */
2537 if (comp_head && sym->attr.extension)
2539 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2541 gfc_error ("component '%s' at %L has already been set by a "
2542 "parent derived type constructor", comp_iter->name,
2548 gcc_assert (!comp_head);
2552 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
2553 expr->ts.u.derived = sym;
2554 expr->value.constructor = ctor_head;
2559 expr->ts.u.derived = sym;
2561 expr->ts.type = BT_DERIVED;
2562 expr->value.constructor = ctor_head;
2563 expr->expr_type = EXPR_STRUCTURE;
2566 gfc_current_locus = old_locus;
2572 gfc_current_locus = old_locus;
2574 for (comp_iter = comp_head; comp_iter; )
2576 gfc_structure_ctor_component *next = comp_iter->next;
2577 gfc_free_structure_ctor_component (comp_iter);
2580 gfc_constructor_free (ctor_head);
2587 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
2591 gfc_symtree *symtree;
2593 gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */
2595 e = gfc_get_expr ();
2596 e->symtree = symtree;
2597 e->expr_type = EXPR_FUNCTION;
2599 gcc_assert (sym->attr.flavor == FL_DERIVED
2600 && symtree->n.sym->attr.flavor == FL_PROCEDURE);
2601 e->value.function.esym = sym;
2602 e->symtree->n.sym->attr.generic = 1;
2604 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2611 if (gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)
2623 /* If the symbol is an implicit do loop index and implicitly typed,
2624 it should not be host associated. Provide a symtree from the
2625 current namespace. */
2627 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2629 if ((*sym)->attr.flavor == FL_VARIABLE
2630 && (*sym)->ns != gfc_current_ns
2631 && (*sym)->attr.implied_index
2632 && (*sym)->attr.implicit_type
2633 && !(*sym)->attr.use_assoc)
2636 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2639 *sym = (*st)->n.sym;
2645 /* Procedure pointer as function result: Replace the function symbol by the
2646 auto-generated hidden result variable named "ppr@". */
2649 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2651 /* Check for procedure pointer result variable. */
2652 if ((*sym)->attr.function && !(*sym)->attr.external
2653 && (*sym)->result && (*sym)->result != *sym
2654 && (*sym)->result->attr.proc_pointer
2655 && (*sym) == gfc_current_ns->proc_name
2656 && (*sym) == (*sym)->result->ns->proc_name
2657 && strcmp ("ppr@", (*sym)->result->name) == 0)
2659 /* Automatic replacement with "hidden" result variable. */
2660 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2661 *sym = (*sym)->result;
2662 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2669 /* Matches a variable name followed by anything that might follow it--
2670 array reference, argument list of a function, etc. */
2673 gfc_match_rvalue (gfc_expr **result)
2675 gfc_actual_arglist *actual_arglist;
2676 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2679 gfc_symtree *symtree;
2680 locus where, old_loc;
2688 m = gfc_match_name (name);
2692 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2693 && !gfc_current_ns->has_import_set)
2694 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2696 i = gfc_get_ha_sym_tree (name, &symtree);
2701 sym = symtree->n.sym;
2703 where = gfc_current_locus;
2705 replace_hidden_procptr_result (&sym, &symtree);
2707 /* If this is an implicit do loop index and implicitly typed,
2708 it should not be host associated. */
2709 m = check_for_implicit_index (&symtree, &sym);
2713 gfc_set_sym_referenced (sym);
2714 sym->attr.implied_index = 0;
2716 if (sym->attr.function && sym->result == sym)
2718 /* See if this is a directly recursive function call. */
2719 gfc_gobble_whitespace ();
2720 if (sym->attr.recursive
2721 && gfc_peek_ascii_char () == '('
2722 && gfc_current_ns->proc_name == sym
2723 && !sym->attr.dimension)
2725 gfc_error ("'%s' at %C is the name of a recursive function "
2726 "and so refers to the result variable. Use an "
2727 "explicit RESULT variable for direct recursion "
2728 "(12.5.2.1)", sym->name);
2732 if (gfc_is_function_return_value (sym, gfc_current_ns))
2736 && (sym->ns == gfc_current_ns
2737 || sym->ns == gfc_current_ns->parent))
2739 gfc_entry_list *el = NULL;
2741 for (el = sym->ns->entries; el; el = el->next)
2747 if (gfc_matching_procptr_assignment)
2750 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2753 if (sym->attr.generic)
2754 goto generic_function;
2756 switch (sym->attr.flavor)
2760 e = gfc_get_expr ();
2762 e->expr_type = EXPR_VARIABLE;
2763 e->symtree = symtree;
2765 m = gfc_match_varspec (e, 0, false, true);
2769 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2770 end up here. Unfortunately, sym->value->expr_type is set to
2771 EXPR_CONSTANT, and so the if () branch would be followed without
2772 the !sym->as check. */
2773 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2774 e = gfc_copy_expr (sym->value);
2777 e = gfc_get_expr ();
2778 e->expr_type = EXPR_VARIABLE;
2781 e->symtree = symtree;
2782 m = gfc_match_varspec (e, 0, false, true);
2784 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2787 /* Variable array references to derived type parameters cause
2788 all sorts of headaches in simplification. Treating such
2789 expressions as variable works just fine for all array
2791 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2793 for (ref = e->ref; ref; ref = ref->next)
2794 if (ref->type == REF_ARRAY)
2797 if (ref == NULL || ref->u.ar.type == AR_FULL)
2803 e = gfc_get_expr ();
2804 e->expr_type = EXPR_VARIABLE;
2805 e->symtree = symtree;
2812 sym = gfc_use_derived (sym);
2816 goto generic_function;
2819 /* If we're here, then the name is known to be the name of a
2820 procedure, yet it is not sure to be the name of a function. */
2823 /* Procedure Pointer Assignments. */
2825 if (gfc_matching_procptr_assignment)
2827 gfc_gobble_whitespace ();
2828 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2829 /* Parse functions returning a procptr. */
2832 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2833 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2834 sym->attr.intrinsic = 1;
2835 e = gfc_get_expr ();
2836 e->expr_type = EXPR_VARIABLE;
2837 e->symtree = symtree;
2838 m = gfc_match_varspec (e, 0, false, true);
2842 if (sym->attr.subroutine)
2844 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2850 /* At this point, the name has to be a non-statement function.
2851 If the name is the same as the current function being
2852 compiled, then we have a variable reference (to the function
2853 result) if the name is non-recursive. */
2855 st = gfc_enclosing_unit (NULL);
2857 if (st != NULL && st->state == COMP_FUNCTION
2859 && !sym->attr.recursive)
2861 e = gfc_get_expr ();
2862 e->symtree = symtree;
2863 e->expr_type = EXPR_VARIABLE;
2865 m = gfc_match_varspec (e, 0, false, true);
2869 /* Match a function reference. */
2871 m = gfc_match_actual_arglist (0, &actual_arglist);
2874 if (sym->attr.proc == PROC_ST_FUNCTION)
2875 gfc_error ("Statement function '%s' requires argument list at %C",
2878 gfc_error ("Function '%s' requires an argument list at %C",
2891 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2892 sym = symtree->n.sym;
2894 replace_hidden_procptr_result (&sym, &symtree);
2896 e = gfc_get_expr ();
2897 e->symtree = symtree;
2898 e->expr_type = EXPR_FUNCTION;
2899 e->value.function.actual = actual_arglist;
2900 e->where = gfc_current_locus;
2902 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
2903 && CLASS_DATA (sym)->as)
2904 e->rank = CLASS_DATA (sym)->as->rank;
2905 else if (sym->as != NULL)
2906 e->rank = sym->as->rank;
2908 if (!sym->attr.function
2909 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2915 /* Check here for the existence of at least one argument for the
2916 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2917 argument(s) given will be checked in gfc_iso_c_func_interface,
2918 during resolution of the function call. */
2919 if (sym->attr.is_iso_c == 1
2920 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2921 && (sym->intmod_sym_id == ISOCBINDING_LOC
2922 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2923 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2925 /* make sure we were given a param */
2926 if (actual_arglist == NULL)
2928 gfc_error ("Missing argument to '%s' at %C", sym->name);
2934 if (sym->result == NULL)
2942 /* Special case for derived type variables that get their types
2943 via an IMPLICIT statement. This can't wait for the
2944 resolution phase. */
2946 if (gfc_peek_ascii_char () == '%'
2947 && sym->ts.type == BT_UNKNOWN
2948 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2949 gfc_set_default_type (sym, 0, sym->ns);
2951 /* If the symbol has a (co)dimension attribute, the expression is a
2954 if (sym->attr.dimension || sym->attr.codimension)
2956 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2957 sym->name, NULL) == FAILURE)
2963 e = gfc_get_expr ();
2964 e->symtree = symtree;
2965 e->expr_type = EXPR_VARIABLE;
2966 m = gfc_match_varspec (e, 0, false, true);
2970 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
2971 && (CLASS_DATA (sym)->attr.dimension
2972 || CLASS_DATA (sym)->attr.codimension))
2974 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2975 sym->name, NULL) == FAILURE)
2981 e = gfc_get_expr ();
2982 e->symtree = symtree;
2983 e->expr_type = EXPR_VARIABLE;
2984 m = gfc_match_varspec (e, 0, false, true);
2988 /* Name is not an array, so we peek to see if a '(' implies a
2989 function call or a substring reference. Otherwise the
2990 variable is just a scalar. */
2992 gfc_gobble_whitespace ();
2993 if (gfc_peek_ascii_char () != '(')
2995 /* Assume a scalar variable */
2996 e = gfc_get_expr ();
2997 e->symtree = symtree;
2998 e->expr_type = EXPR_VARIABLE;
3000 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
3001 sym->name, NULL) == FAILURE)
3007 /*FIXME:??? gfc_match_varspec does set this for us: */
3009 m = gfc_match_varspec (e, 0, false, true);
3013 /* See if this is a function reference with a keyword argument
3014 as first argument. We do this because otherwise a spurious
3015 symbol would end up in the symbol table. */
3017 old_loc = gfc_current_locus;
3018 m2 = gfc_match (" ( %n =", argname);
3019 gfc_current_locus = old_loc;
3021 e = gfc_get_expr ();
3022 e->symtree = symtree;
3024 if (m2 != MATCH_YES)
3026 /* Try to figure out whether we're dealing with a character type.
3027 We're peeking ahead here, because we don't want to call
3028 match_substring if we're dealing with an implicitly typed
3029 non-character variable. */
3030 implicit_char = false;
3031 if (sym->ts.type == BT_UNKNOWN)
3033 ts = gfc_get_default_type (sym->name, NULL);
3034 if (ts->type == BT_CHARACTER)
3035 implicit_char = true;
3038 /* See if this could possibly be a substring reference of a name
3039 that we're not sure is a variable yet. */
3041 if ((implicit_char || sym->ts.type == BT_CHARACTER)
3042 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
3045 e->expr_type = EXPR_VARIABLE;
3047 if (sym->attr.flavor != FL_VARIABLE
3048 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
3049 sym->name, NULL) == FAILURE)
3055 if (sym->ts.type == BT_UNKNOWN
3056 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3070 /* Give up, assume we have a function. */
3072 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3073 sym = symtree->n.sym;
3074 e->expr_type = EXPR_FUNCTION;
3076 if (!sym->attr.function
3077 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
3085 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3087 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
3095 /* If our new function returns a character, array or structure
3096 type, it might have subsequent references. */
3098 m = gfc_match_varspec (e, 0, false, true);
3105 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3107 e = gfc_get_expr ();
3108 e->symtree = symtree;
3109 e->expr_type = EXPR_FUNCTION;
3111 if (sym->attr.flavor == FL_DERIVED)
3113 e->value.function.esym = sym;
3114 e->symtree->n.sym->attr.generic = 1;
3117 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3121 gfc_error ("Symbol at %C is not appropriate for an expression");
3137 /* Match a variable, i.e. something that can be assigned to. This
3138 starts as a symbol, can be a structure component or an array
3139 reference. It can be a function if the function doesn't have a
3140 separate RESULT variable. If the symbol has not been previously
3141 seen, we assume it is a variable.
3143 This function is called by two interface functions:
3144 gfc_match_variable, which has host_flag = 1, and
3145 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3146 match of the symbol to the local scope. */
3149 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
3157 /* Since nothing has any business being an lvalue in a module
3158 specification block, an interface block or a contains section,
3159 we force the changed_symbols mechanism to work by setting
3160 host_flag to 0. This prevents valid symbols that have the name
3161 of keywords, such as 'end', being turned into variables by
3162 failed matching to assignments for, e.g., END INTERFACE. */
3163 if (gfc_current_state () == COMP_MODULE
3164 || gfc_current_state () == COMP_INTERFACE
3165 || gfc_current_state () == COMP_CONTAINS)
3168 where = gfc_current_locus;
3169 m = gfc_match_sym_tree (&st, host_flag);
3175 /* If this is an implicit do loop index and implicitly typed,
3176 it should not be host associated. */
3177 m = check_for_implicit_index (&st, &sym);
3181 sym->attr.implied_index = 0;
3183 gfc_set_sym_referenced (sym);
3184 switch (sym->attr.flavor)
3187 /* Everything is alright. */
3192 sym_flavor flavor = FL_UNKNOWN;
3194 gfc_gobble_whitespace ();
3196 if (sym->attr.external || sym->attr.procedure
3197 || sym->attr.function || sym->attr.subroutine)
3198 flavor = FL_PROCEDURE;
3200 /* If it is not a procedure, is not typed and is host associated,
3201 we cannot give it a flavor yet. */
3202 else if (sym->ns == gfc_current_ns->parent
3203 && sym->ts.type == BT_UNKNOWN)
3206 /* These are definitive indicators that this is a variable. */
3207 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3208 || sym->attr.pointer || sym->as != NULL)
3209 flavor = FL_VARIABLE;
3211 if (flavor != FL_UNKNOWN
3212 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3220 gfc_error ("Named constant at %C in an EQUIVALENCE");
3223 /* Otherwise this is checked for and an error given in the
3224 variable definition context checks. */
3228 /* Check for a nonrecursive function result variable. */
3229 if (sym->attr.function
3230 && !sym->attr.external
3231 && sym->result == sym
3232 && (gfc_is_function_return_value (sym, gfc_current_ns)
3234 && sym->ns == gfc_current_ns)
3236 && sym->ns == gfc_current_ns->parent)))
3238 /* If a function result is a derived type, then the derived
3239 type may still have to be resolved. */
3241 if (sym->ts.type == BT_DERIVED
3242 && gfc_use_derived (sym->ts.u.derived) == NULL)
3247 if (sym->attr.proc_pointer
3248 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3251 /* Fall through to error */
3254 gfc_error ("'%s' at %C is not a variable", sym->name);
3258 /* Special case for derived type variables that get their types
3259 via an IMPLICIT statement. This can't wait for the
3260 resolution phase. */
3263 gfc_namespace * implicit_ns;
3265 if (gfc_current_ns->proc_name == sym)
3266 implicit_ns = gfc_current_ns;
3268 implicit_ns = sym->ns;
3270 if (gfc_peek_ascii_char () == '%'
3271 && sym->ts.type == BT_UNKNOWN
3272 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3273 gfc_set_default_type (sym, 0, implicit_ns);
3276 expr = gfc_get_expr ();
3278 expr->expr_type = EXPR_VARIABLE;
3281 expr->where = where;
3283 /* Now see if we have to do more. */
3284 m = gfc_match_varspec (expr, equiv_flag, false, false);
3287 gfc_free_expr (expr);
3297 gfc_match_variable (gfc_expr **result, int equiv_flag)
3299 return match_variable (result, equiv_flag, 1);
3304 gfc_match_equiv_variable (gfc_expr **result)
3306 return match_variable (result, 1, 0);