1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
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 (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
229 gfc_error ("Integer kind %d at %C not available", kind);
233 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
234 e->ts.is_c_interop = is_iso_c;
236 if (gfc_range_check (e) != ARITH_OK)
238 gfc_error ("Integer too big for its kind at %C. This check can be "
239 "disabled with the option -fno-range-check");
250 /* Match a Hollerith constant. */
253 match_hollerith_constant (gfc_expr **result)
261 old_loc = gfc_current_locus;
262 gfc_gobble_whitespace ();
264 if (match_integer_constant (&e, 0) == MATCH_YES
265 && gfc_match_char ('h') == MATCH_YES)
267 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
271 msg = gfc_extract_int (e, &num);
279 gfc_error ("Invalid Hollerith constant: %L must contain at least "
280 "one character", &old_loc);
283 if (e->ts.kind != gfc_default_integer_kind)
285 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
286 "should be default", &old_loc);
292 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
295 /* Calculate padding needed to fit default integer memory. */
296 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
298 e->representation.string = XCNEWVEC (char, num + pad + 1);
300 for (i = 0; i < num; i++)
302 gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
303 if (! gfc_wide_fits_in_byte (c))
305 gfc_error ("Invalid Hollerith constant at %L contains a "
306 "wide character", &old_loc);
310 e->representation.string[i] = (unsigned char) c;
313 /* Now pad with blanks and end with a null char. */
314 for (i = 0; i < pad; i++)
315 e->representation.string[num + i] = ' ';
317 e->representation.string[num + i] = '\0';
318 e->representation.length = num + pad;
327 gfc_current_locus = old_loc;
336 /* Match a binary, octal or hexadecimal constant that can be found in
337 a DATA statement. The standard permits b'010...', o'73...', and
338 z'a1...' where b, o, and z can be capital letters. This function
339 also accepts postfixed forms of the constants: '01...'b, '73...'o,
340 and 'a1...'z. An additional extension is the use of x for z. */
343 match_boz_constant (gfc_expr **result)
345 int radix, length, x_hex, kind;
346 locus old_loc, start_loc;
347 char *buffer, post, delim;
350 start_loc = old_loc = gfc_current_locus;
351 gfc_gobble_whitespace ();
354 switch (post = gfc_next_ascii_char ())
376 radix = 16; /* Set to accept any valid digit string. */
382 /* No whitespace allowed here. */
385 delim = gfc_next_ascii_char ();
387 if (delim != '\'' && delim != '\"')
391 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
392 "constant at %C uses non-standard syntax")
396 old_loc = gfc_current_locus;
398 length = match_digits (0, radix, NULL);
401 gfc_error ("Empty set of digits in BOZ constant at %C");
405 if (gfc_next_ascii_char () != delim)
407 gfc_error ("Illegal character in BOZ constant at %C");
413 switch (gfc_next_ascii_char ())
430 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
431 "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, "Fortran 2003: BOZ used outside a DATA "
476 gfc_current_locus = start_loc;
481 /* Match a real constant of some sort. Allow a signed constant if signflag
485 match_real_constant (gfc_expr **result, int signflag)
487 int kind, count, seen_dp, seen_digits, is_iso_c;
488 locus old_loc, temp_loc;
489 char *p, *buffer, c, exp_char;
493 old_loc = gfc_current_locus;
494 gfc_gobble_whitespace ();
504 c = gfc_next_ascii_char ();
505 if (signflag && (c == '+' || c == '-'))
510 gfc_gobble_whitespace ();
511 c = gfc_next_ascii_char ();
514 /* Scan significand. */
515 for (;; c = gfc_next_ascii_char (), count++)
522 /* Check to see if "." goes with a following operator like
524 temp_loc = gfc_current_locus;
525 c = gfc_next_ascii_char ();
527 if (c == 'e' || c == 'd' || c == 'q')
529 c = gfc_next_ascii_char ();
531 goto done; /* Operator named .e. or .d. */
535 goto done; /* Distinguish 1.e9 from 1.eq.2 */
537 gfc_current_locus = temp_loc;
551 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
558 if (gfc_notify_std (GFC_STD_GNU, "Extension: exponent-letter 'q' in "
559 "real-literal-constant at %C") == FAILURE)
561 else if (gfc_option.warn_real_q_constant)
562 gfc_warning("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;
644 gfc_error ("Real number at %C has a 'q' exponent and an explicit "
649 /* The maximum possible real kind type parameter is 16. First, try
650 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
651 extended precision. If neither value works, just given up. */
653 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
656 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
658 gfc_error ("Invalid exponent-letter 'q' in "
659 "real-literal-constant at %C");
667 kind = gfc_default_real_kind;
669 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
671 gfc_error ("Invalid real kind %d at %C", kind);
676 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
678 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
679 e->ts.is_c_interop = is_iso_c;
681 switch (gfc_range_check (e))
686 gfc_error ("Real constant overflows its kind at %C");
689 case ARITH_UNDERFLOW:
690 if (gfc_option.warn_underflow)
691 gfc_warning ("Real constant underflows its kind at %C");
692 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
696 gfc_internal_error ("gfc_range_check() returned bad value");
708 /* Match a substring reference. */
711 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
713 gfc_expr *start, *end;
721 old_loc = gfc_current_locus;
723 m = gfc_match_char ('(');
727 if (gfc_match_char (':') != MATCH_YES)
730 m = gfc_match_init_expr (&start);
732 m = gfc_match_expr (&start);
740 m = gfc_match_char (':');
745 if (gfc_match_char (')') != MATCH_YES)
748 m = gfc_match_init_expr (&end);
750 m = gfc_match_expr (&end);
754 if (m == MATCH_ERROR)
757 m = gfc_match_char (')');
762 /* Optimize away the (:) reference. */
763 if (start == NULL && end == NULL)
767 ref = gfc_get_ref ();
769 ref->type = REF_SUBSTRING;
771 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
772 ref->u.ss.start = start;
773 if (end == NULL && cl)
774 end = gfc_copy_expr (cl->length);
776 ref->u.ss.length = cl;
783 gfc_error ("Syntax error in SUBSTRING specification at %C");
787 gfc_free_expr (start);
790 gfc_current_locus = old_loc;
795 /* Reads the next character of a string constant, taking care to
796 return doubled delimiters on the input as a single instance of
799 Special return values for "ret" argument are:
800 -1 End of the string, as determined by the delimiter
801 -2 Unterminated string detected
803 Backslash codes are also expanded at this time. */
806 next_string_char (gfc_char_t delimiter, int *ret)
811 c = gfc_next_char_literal (INSTRING_WARN);
820 if (gfc_option.flag_backslash && c == '\\')
822 old_locus = gfc_current_locus;
824 if (gfc_match_special_char (&c) == MATCH_NO)
825 gfc_current_locus = old_locus;
827 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
828 gfc_warning ("Extension: backslash character at %C");
834 old_locus = gfc_current_locus;
835 c = gfc_next_char_literal (NONSTRING);
839 gfc_current_locus = old_locus;
846 /* Special case of gfc_match_name() that matches a parameter kind name
847 before a string constant. This takes case of the weird but legal
852 where kind____ is a parameter. gfc_match_name() will happily slurp
853 up all the underscores, which leads to problems. If we return
854 MATCH_YES, the parse pointer points to the final underscore, which
855 is not part of the name. We never return MATCH_ERROR-- errors in
856 the name will be detected later. */
859 match_charkind_name (char *name)
865 gfc_gobble_whitespace ();
866 c = gfc_next_ascii_char ();
875 old_loc = gfc_current_locus;
876 c = gfc_next_ascii_char ();
880 peek = gfc_peek_ascii_char ();
882 if (peek == '\'' || peek == '\"')
884 gfc_current_locus = old_loc;
892 && (c != '$' || !gfc_option.flag_dollar_ok))
896 if (++len > GFC_MAX_SYMBOL_LEN)
904 /* See if the current input matches a character constant. Lots of
905 contortions have to be done to match the kind parameter which comes
906 before the actual string. The main consideration is that we don't
907 want to error out too quickly. For example, we don't actually do
908 any validation of the kinds until we have actually seen a legal
909 delimiter. Using match_kind_param() generates errors too quickly. */
912 match_string_constant (gfc_expr **result)
914 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
915 int i, kind, length, warn_ampersand, ret;
916 locus old_locus, start_locus;
921 gfc_char_t c, delimiter, *p;
923 old_locus = gfc_current_locus;
925 gfc_gobble_whitespace ();
927 c = gfc_next_char ();
928 if (c == '\'' || c == '"')
930 kind = gfc_default_character_kind;
931 start_locus = gfc_current_locus;
935 if (gfc_wide_is_digit (c))
939 while (gfc_wide_is_digit (c))
941 kind = kind * 10 + c - '0';
944 c = gfc_next_char ();
950 gfc_current_locus = old_locus;
952 m = match_charkind_name (name);
956 if (gfc_find_symbol (name, NULL, 1, &sym)
958 || sym->attr.flavor != FL_PARAMETER)
962 c = gfc_next_char ();
967 gfc_gobble_whitespace ();
968 c = gfc_next_char ();
974 gfc_gobble_whitespace ();
976 c = gfc_next_char ();
977 if (c != '\'' && c != '"')
980 start_locus = gfc_current_locus;
984 q = gfc_extract_int (sym->value, &kind);
990 gfc_set_sym_referenced (sym);
993 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
995 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
1000 /* Scan the string into a block of memory by first figuring out how
1001 long it is, allocating the structure, then re-reading it. This
1002 isn't particularly efficient, but string constants aren't that
1003 common in most code. TODO: Use obstacks? */
1010 c = next_string_char (delimiter, &ret);
1015 gfc_current_locus = start_locus;
1016 gfc_error ("Unterminated character constant beginning at %C");
1023 /* Peek at the next character to see if it is a b, o, z, or x for the
1024 postfixed BOZ literal constants. */
1025 peek = gfc_peek_ascii_char ();
1026 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
1029 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
1031 gfc_current_locus = start_locus;
1033 /* We disable the warning for the following loop as the warning has already
1034 been printed in the loop above. */
1035 warn_ampersand = gfc_option.warn_ampersand;
1036 gfc_option.warn_ampersand = 0;
1038 p = e->value.character.string;
1039 for (i = 0; i < length; i++)
1041 c = next_string_char (delimiter, &ret);
1043 if (!gfc_check_character_range (c, kind))
1045 gfc_error ("Character '%s' in string at %C is not representable "
1046 "in character kind %d", gfc_print_wide_char (c), kind);
1053 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1054 gfc_option.warn_ampersand = warn_ampersand;
1056 next_string_char (delimiter, &ret);
1058 gfc_internal_error ("match_string_constant(): Delimiter not found");
1060 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1061 e->expr_type = EXPR_SUBSTRING;
1068 gfc_current_locus = old_locus;
1073 /* Match a .true. or .false. Returns 1 if a .true. was found,
1074 0 if a .false. was found, and -1 otherwise. */
1076 match_logical_constant_string (void)
1078 locus orig_loc = gfc_current_locus;
1080 gfc_gobble_whitespace ();
1081 if (gfc_next_ascii_char () == '.')
1083 char ch = gfc_next_ascii_char ();
1086 if (gfc_next_ascii_char () == 'a'
1087 && gfc_next_ascii_char () == 'l'
1088 && gfc_next_ascii_char () == 's'
1089 && gfc_next_ascii_char () == 'e'
1090 && gfc_next_ascii_char () == '.')
1091 /* Matched ".false.". */
1096 if (gfc_next_ascii_char () == 'r'
1097 && gfc_next_ascii_char () == 'u'
1098 && gfc_next_ascii_char () == 'e'
1099 && gfc_next_ascii_char () == '.')
1100 /* Matched ".true.". */
1104 gfc_current_locus = orig_loc;
1108 /* Match a .true. or .false. */
1111 match_logical_constant (gfc_expr **result)
1114 int i, kind, is_iso_c;
1116 i = match_logical_constant_string ();
1120 kind = get_kind (&is_iso_c);
1124 kind = gfc_default_logical_kind;
1126 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1128 gfc_error ("Bad kind for logical constant at %C");
1132 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1133 e->ts.is_c_interop = is_iso_c;
1140 /* Match a real or imaginary part of a complex constant that is a
1141 symbolic constant. */
1144 match_sym_complex_part (gfc_expr **result)
1146 char name[GFC_MAX_SYMBOL_LEN + 1];
1151 m = gfc_match_name (name);
1155 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1158 if (sym->attr.flavor != FL_PARAMETER)
1160 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1164 if (!gfc_numeric_ts (&sym->value->ts))
1166 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1170 if (sym->value->rank != 0)
1172 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1176 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1177 "complex constant at %C") == FAILURE)
1180 switch (sym->value->ts.type)
1183 e = gfc_copy_expr (sym->value);
1187 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1193 e = gfc_int2real (sym->value, gfc_default_real_kind);
1199 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1202 *result = e; /* e is a scalar, real, constant expression. */
1206 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1211 /* Match a real or imaginary part of a complex number. */
1214 match_complex_part (gfc_expr **result)
1218 m = match_sym_complex_part (result);
1222 m = match_real_constant (result, 1);
1226 return match_integer_constant (result, 1);
1230 /* Try to match a complex constant. */
1233 match_complex_constant (gfc_expr **result)
1235 gfc_expr *e, *real, *imag;
1236 gfc_error_buf old_error;
1237 gfc_typespec target;
1242 old_loc = gfc_current_locus;
1243 real = imag = e = NULL;
1245 m = gfc_match_char ('(');
1249 gfc_push_error (&old_error);
1251 m = match_complex_part (&real);
1254 gfc_free_error (&old_error);
1258 if (gfc_match_char (',') == MATCH_NO)
1260 gfc_pop_error (&old_error);
1265 /* If m is error, then something was wrong with the real part and we
1266 assume we have a complex constant because we've seen the ','. An
1267 ambiguous case here is the start of an iterator list of some
1268 sort. These sort of lists are matched prior to coming here. */
1270 if (m == MATCH_ERROR)
1272 gfc_free_error (&old_error);
1275 gfc_pop_error (&old_error);
1277 m = match_complex_part (&imag);
1280 if (m == MATCH_ERROR)
1283 m = gfc_match_char (')');
1286 /* Give the matcher for implied do-loops a chance to run. This
1287 yields a much saner error message for (/ (i, 4=i, 6) /). */
1288 if (gfc_peek_ascii_char () == '=')
1297 if (m == MATCH_ERROR)
1300 /* Decide on the kind of this complex number. */
1301 if (real->ts.type == BT_REAL)
1303 if (imag->ts.type == BT_REAL)
1304 kind = gfc_kind_max (real, imag);
1306 kind = real->ts.kind;
1310 if (imag->ts.type == BT_REAL)
1311 kind = imag->ts.kind;
1313 kind = gfc_default_real_kind;
1315 gfc_clear_ts (&target);
1316 target.type = BT_REAL;
1319 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1320 gfc_convert_type (real, &target, 2);
1321 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1322 gfc_convert_type (imag, &target, 2);
1324 e = gfc_convert_complex (real, imag, kind);
1325 e->where = gfc_current_locus;
1327 gfc_free_expr (real);
1328 gfc_free_expr (imag);
1334 gfc_error ("Syntax error in COMPLEX constant at %C");
1339 gfc_free_expr (real);
1340 gfc_free_expr (imag);
1341 gfc_current_locus = old_loc;
1347 /* Match constants in any of several forms. Returns nonzero for a
1348 match, zero for no match. */
1351 gfc_match_literal_constant (gfc_expr **result, int signflag)
1355 m = match_complex_constant (result);
1359 m = match_string_constant (result);
1363 m = match_boz_constant (result);
1367 m = match_real_constant (result, signflag);
1371 m = match_hollerith_constant (result);
1375 m = match_integer_constant (result, signflag);
1379 m = match_logical_constant (result);
1387 /* This checks if a symbol is the return value of an encompassing function.
1388 Function nesting can be maximally two levels deep, but we may have
1389 additional local namespaces like BLOCK etc. */
1392 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1394 if (!sym->attr.function || (sym->result != sym))
1398 if (ns->proc_name == sym)
1406 /* Match a single actual argument value. An actual argument is
1407 usually an expression, but can also be a procedure name. If the
1408 argument is a single name, it is not always possible to tell
1409 whether the name is a dummy procedure or not. We treat these cases
1410 by creating an argument that looks like a dummy procedure and
1411 fixing things later during resolution. */
1414 match_actual_arg (gfc_expr **result)
1416 char name[GFC_MAX_SYMBOL_LEN + 1];
1417 gfc_symtree *symtree;
1422 gfc_gobble_whitespace ();
1423 where = gfc_current_locus;
1425 switch (gfc_match_name (name))
1434 w = gfc_current_locus;
1435 gfc_gobble_whitespace ();
1436 c = gfc_next_ascii_char ();
1437 gfc_current_locus = w;
1439 if (c != ',' && c != ')')
1442 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1444 /* Handle error elsewhere. */
1446 /* Eliminate a couple of common cases where we know we don't
1447 have a function argument. */
1448 if (symtree == NULL)
1450 gfc_get_sym_tree (name, NULL, &symtree, false);
1451 gfc_set_sym_referenced (symtree->n.sym);
1457 sym = symtree->n.sym;
1458 gfc_set_sym_referenced (sym);
1459 if (sym->attr.flavor != FL_PROCEDURE
1460 && sym->attr.flavor != FL_UNKNOWN)
1463 if (sym->attr.in_common && !sym->attr.proc_pointer)
1465 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1470 /* If the symbol is a function with itself as the result and
1471 is being defined, then we have a variable. */
1472 if (sym->attr.function && sym->result == sym)
1474 if (gfc_is_function_return_value (sym, gfc_current_ns))
1478 && (sym->ns == gfc_current_ns
1479 || sym->ns == gfc_current_ns->parent))
1481 gfc_entry_list *el = NULL;
1483 for (el = sym->ns->entries; el; el = el->next)
1493 e = gfc_get_expr (); /* Leave it unknown for now */
1494 e->symtree = symtree;
1495 e->expr_type = EXPR_VARIABLE;
1496 e->ts.type = BT_PROCEDURE;
1503 gfc_current_locus = where;
1504 return gfc_match_expr (result);
1508 /* Match a keyword argument. */
1511 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1513 char name[GFC_MAX_SYMBOL_LEN + 1];
1514 gfc_actual_arglist *a;
1518 name_locus = gfc_current_locus;
1519 m = gfc_match_name (name);
1523 if (gfc_match_char ('=') != MATCH_YES)
1529 m = match_actual_arg (&actual->expr);
1533 /* Make sure this name has not appeared yet. */
1535 if (name[0] != '\0')
1537 for (a = base; a; a = a->next)
1538 if (a->name != NULL && strcmp (a->name, name) == 0)
1540 gfc_error ("Keyword '%s' at %C has already appeared in the "
1541 "current argument list", name);
1546 actual->name = gfc_get_string (name);
1550 gfc_current_locus = name_locus;
1555 /* Match an argument list function, such as %VAL. */
1558 match_arg_list_function (gfc_actual_arglist *result)
1560 char name[GFC_MAX_SYMBOL_LEN + 1];
1564 old_locus = gfc_current_locus;
1566 if (gfc_match_char ('%') != MATCH_YES)
1572 m = gfc_match ("%n (", name);
1576 if (name[0] != '\0')
1581 if (strncmp (name, "loc", 3) == 0)
1583 result->name = "%LOC";
1587 if (strncmp (name, "ref", 3) == 0)
1589 result->name = "%REF";
1593 if (strncmp (name, "val", 3) == 0)
1595 result->name = "%VAL";
1604 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1605 "function at %C") == FAILURE)
1611 m = match_actual_arg (&result->expr);
1615 if (gfc_match_char (')') != MATCH_YES)
1624 gfc_current_locus = old_locus;
1629 /* Matches an actual argument list of a function or subroutine, from
1630 the opening parenthesis to the closing parenthesis. The argument
1631 list is assumed to allow keyword arguments because we don't know if
1632 the symbol associated with the procedure has an implicit interface
1633 or not. We make sure keywords are unique. If sub_flag is set,
1634 we're matching the argument list of a subroutine. */
1637 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1639 gfc_actual_arglist *head, *tail;
1641 gfc_st_label *label;
1645 *argp = tail = NULL;
1646 old_loc = gfc_current_locus;
1650 if (gfc_match_char ('(') == MATCH_NO)
1651 return (sub_flag) ? MATCH_YES : MATCH_NO;
1653 if (gfc_match_char (')') == MATCH_YES)
1657 matching_actual_arglist++;
1662 head = tail = gfc_get_actual_arglist ();
1665 tail->next = gfc_get_actual_arglist ();
1669 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1671 m = gfc_match_st_label (&label);
1673 gfc_error ("Expected alternate return label at %C");
1677 tail->label = label;
1681 /* After the first keyword argument is seen, the following
1682 arguments must also have keywords. */
1685 m = match_keyword_arg (tail, head);
1687 if (m == MATCH_ERROR)
1691 gfc_error ("Missing keyword name in actual argument list at %C");
1698 /* Try an argument list function, like %VAL. */
1699 m = match_arg_list_function (tail);
1700 if (m == MATCH_ERROR)
1703 /* See if we have the first keyword argument. */
1706 m = match_keyword_arg (tail, head);
1709 if (m == MATCH_ERROR)
1715 /* Try for a non-keyword argument. */
1716 m = match_actual_arg (&tail->expr);
1717 if (m == MATCH_ERROR)
1726 if (gfc_match_char (')') == MATCH_YES)
1728 if (gfc_match_char (',') != MATCH_YES)
1733 matching_actual_arglist--;
1737 gfc_error ("Syntax error in argument list at %C");
1740 gfc_free_actual_arglist (head);
1741 gfc_current_locus = old_loc;
1742 matching_actual_arglist--;
1747 /* Used by gfc_match_varspec() to extend the reference list by one
1751 extend_ref (gfc_expr *primary, gfc_ref *tail)
1753 if (primary->ref == NULL)
1754 primary->ref = tail = gfc_get_ref ();
1758 gfc_internal_error ("extend_ref(): Bad tail");
1759 tail->next = gfc_get_ref ();
1767 /* Match any additional specifications associated with the current
1768 variable like member references or substrings. If equiv_flag is
1769 set we only match stuff that is allowed inside an EQUIVALENCE
1770 statement. sub_flag tells whether we expect a type-bound procedure found
1771 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1772 components, 'ppc_arg' determines whether the PPC may be called (with an
1773 argument list), or whether it may just be referred to as a pointer. */
1776 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1779 char name[GFC_MAX_SYMBOL_LEN + 1];
1780 gfc_ref *substring, *tail;
1781 gfc_component *component;
1782 gfc_symbol *sym = primary->symtree->n.sym;
1788 gfc_gobble_whitespace ();
1790 if (gfc_peek_ascii_char () == '[')
1792 if (sym->attr.dimension)
1794 gfc_error ("Array section designator, e.g. '(:)', is required "
1795 "besides the coarray designator '[...]' at %C");
1798 if (!sym->attr.codimension)
1800 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1806 /* For associate names, we may not yet know whether they are arrays or not.
1807 Thus if we have one and parentheses follow, we have to assume that it
1808 actually is one for now. The final decision will be made at
1809 resolution time, of course. */
1810 if (sym->assoc && gfc_peek_ascii_char () == '(')
1811 sym->attr.dimension = 1;
1813 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1814 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1815 || (sym->attr.dimension && sym->ts.type != BT_CLASS
1816 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL)
1817 && !(gfc_matching_procptr_assignment
1818 && sym->attr.flavor == FL_PROCEDURE))
1819 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1820 && CLASS_DATA (sym)->attr.dimension))
1822 /* In EQUIVALENCE, we don't know yet whether we are seeing
1823 an array, character variable or array of character
1824 variables. We'll leave the decision till resolve time. */
1825 tail = extend_ref (primary, tail);
1826 tail->type = REF_ARRAY;
1828 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1830 sym->ts.type == BT_CLASS
1831 ? (CLASS_DATA (sym)->as
1832 ? CLASS_DATA (sym)->as->corank : 0)
1833 : (sym->as ? sym->as->corank : 0));
1837 gfc_gobble_whitespace ();
1838 if (equiv_flag && gfc_peek_ascii_char () == '(')
1840 tail = extend_ref (primary, tail);
1841 tail->type = REF_ARRAY;
1843 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1849 primary->ts = sym->ts;
1854 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1855 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1856 gfc_set_default_type (sym, 0, sym->ns);
1858 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1859 || gfc_match_char ('%') != MATCH_YES)
1860 goto check_substring;
1862 sym = sym->ts.u.derived;
1869 m = gfc_match_name (name);
1871 gfc_error ("Expected structure component name at %C");
1875 if (sym->f2k_derived)
1876 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1882 gfc_symbol* tbp_sym;
1887 gcc_assert (!tail || !tail->next);
1888 gcc_assert (primary->expr_type == EXPR_VARIABLE
1889 || (primary->expr_type == EXPR_STRUCTURE
1890 && primary->symtree && primary->symtree->n.sym
1891 && primary->symtree->n.sym->attr.flavor));
1893 if (tbp->n.tb->is_generic)
1896 tbp_sym = tbp->n.tb->u.specific->n.sym;
1898 primary->expr_type = EXPR_COMPCALL;
1899 primary->value.compcall.tbp = tbp->n.tb;
1900 primary->value.compcall.name = tbp->name;
1901 primary->value.compcall.ignore_pass = 0;
1902 primary->value.compcall.assign = 0;
1903 primary->value.compcall.base_object = NULL;
1904 gcc_assert (primary->symtree->n.sym->attr.referenced);
1906 primary->ts = tbp_sym->ts;
1908 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1909 &primary->value.compcall.actual);
1910 if (m == MATCH_ERROR)
1915 primary->value.compcall.actual = NULL;
1918 gfc_error ("Expected argument list at %C");
1926 component = gfc_find_component (sym, name, false, false);
1927 if (component == NULL)
1930 tail = extend_ref (primary, tail);
1931 tail->type = REF_COMPONENT;
1933 tail->u.c.component = component;
1934 tail->u.c.sym = sym;
1936 primary->ts = component->ts;
1938 if (component->attr.proc_pointer && ppc_arg
1939 && !gfc_matching_procptr_assignment)
1941 /* Procedure pointer component call: Look for argument list. */
1942 m = gfc_match_actual_arglist (sub_flag,
1943 &primary->value.compcall.actual);
1944 if (m == MATCH_ERROR)
1947 if (m == MATCH_NO && !gfc_matching_ptr_assignment
1948 && !matching_actual_arglist)
1950 gfc_error ("Procedure pointer component '%s' requires an "
1951 "argument list at %C", component->name);
1956 primary->expr_type = EXPR_PPC;
1961 if (component->as != NULL && !component->attr.proc_pointer)
1963 tail = extend_ref (primary, tail);
1964 tail->type = REF_ARRAY;
1966 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
1967 component->as->corank);
1971 else if (component->ts.type == BT_CLASS
1972 && CLASS_DATA (component)->as != NULL
1973 && !component->attr.proc_pointer)
1975 tail = extend_ref (primary, tail);
1976 tail->type = REF_ARRAY;
1978 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
1980 CLASS_DATA (component)->as->corank);
1985 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1986 || gfc_match_char ('%') != MATCH_YES)
1989 sym = component->ts.u.derived;
1994 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1996 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1998 gfc_set_default_type (sym, 0, sym->ns);
1999 primary->ts = sym->ts;
2004 if (primary->ts.type == BT_CHARACTER)
2006 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
2010 primary->ref = substring;
2012 tail->next = substring;
2014 if (primary->expr_type == EXPR_CONSTANT)
2015 primary->expr_type = EXPR_SUBSTRING;
2018 primary->ts.u.cl = NULL;
2025 gfc_clear_ts (&primary->ts);
2026 gfc_clear_ts (&sym->ts);
2036 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
2038 gfc_error ("Coindexed procedure-pointer component at %C");
2046 /* Given an expression that is a variable, figure out what the
2047 ultimate variable's type and attribute is, traversing the reference
2048 structures if necessary.
2050 This subroutine is trickier than it looks. We start at the base
2051 symbol and store the attribute. Component references load a
2052 completely new attribute.
2054 A couple of rules come into play. Subobjects of targets are always
2055 targets themselves. If we see a component that goes through a
2056 pointer, then the expression must also be a target, since the
2057 pointer is associated with something (if it isn't core will soon be
2058 dumped). If we see a full part or section of an array, the
2059 expression is also an array.
2061 We can have at most one full array reference. */
2064 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2066 int dimension, pointer, allocatable, target;
2067 symbol_attribute attr;
2070 gfc_component *comp;
2072 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2073 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2075 sym = expr->symtree->n.sym;
2078 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2080 dimension = CLASS_DATA (sym)->attr.dimension;
2081 pointer = CLASS_DATA (sym)->attr.class_pointer;
2082 allocatable = CLASS_DATA (sym)->attr.allocatable;
2086 dimension = attr.dimension;
2087 pointer = attr.pointer;
2088 allocatable = attr.allocatable;
2091 target = attr.target;
2092 if (pointer || attr.proc_pointer)
2095 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2098 for (ref = expr->ref; ref; ref = ref->next)
2103 switch (ref->u.ar.type)
2110 allocatable = pointer = 0;
2115 /* Handle coarrays. */
2116 if (ref->u.ar.dimen > 0)
2117 allocatable = pointer = 0;
2121 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2127 comp = ref->u.c.component;
2132 /* Don't set the string length if a substring reference
2134 if (ts->type == BT_CHARACTER
2135 && ref->next && ref->next->type == REF_SUBSTRING)
2139 if (comp->ts.type == BT_CLASS)
2141 pointer = CLASS_DATA (comp)->attr.class_pointer;
2142 allocatable = CLASS_DATA (comp)->attr.allocatable;
2146 pointer = comp->attr.pointer;
2147 allocatable = comp->attr.allocatable;
2149 if (pointer || attr.proc_pointer)
2155 allocatable = pointer = 0;
2159 attr.dimension = dimension;
2160 attr.pointer = pointer;
2161 attr.allocatable = allocatable;
2162 attr.target = target;
2163 attr.save = sym->attr.save;
2169 /* Return the attribute from a general expression. */
2172 gfc_expr_attr (gfc_expr *e)
2174 symbol_attribute attr;
2176 switch (e->expr_type)
2179 attr = gfc_variable_attr (e, NULL);
2183 gfc_clear_attr (&attr);
2185 if (e->value.function.esym != NULL)
2187 gfc_symbol *sym = e->value.function.esym->result;
2189 if (sym->ts.type == BT_CLASS)
2191 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2192 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2193 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2197 attr = gfc_variable_attr (e, NULL);
2199 /* TODO: NULL() returns pointers. May have to take care of this
2205 gfc_clear_attr (&attr);
2213 /* Match a structure constructor. The initial symbol has already been
2216 typedef struct gfc_structure_ctor_component
2221 struct gfc_structure_ctor_component* next;
2223 gfc_structure_ctor_component;
2225 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2228 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2231 gfc_free_expr (comp->val);
2236 /* Translate the component list into the actual constructor by sorting it in
2237 the order required; this also checks along the way that each and every
2238 component actually has an initializer and handles default initializers
2239 for components without explicit value given. */
2241 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2242 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2244 gfc_structure_ctor_component *comp_iter;
2245 gfc_component *comp;
2247 for (comp = sym->components; comp; comp = comp->next)
2249 gfc_structure_ctor_component **next_ptr;
2250 gfc_expr *value = NULL;
2252 /* Try to find the initializer for the current component by name. */
2253 next_ptr = comp_head;
2254 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2256 if (!strcmp (comp_iter->name, comp->name))
2258 next_ptr = &comp_iter->next;
2261 /* If an extension, try building the parent derived type by building
2262 a value expression for the parent derived type and calling self. */
2263 if (!comp_iter && comp == sym->components && sym->attr.extension)
2265 value = gfc_get_structure_constructor_expr (comp->ts.type,
2267 &gfc_current_locus);
2268 value->ts = comp->ts;
2270 if (build_actual_constructor (comp_head, &value->value.constructor,
2271 comp->ts.u.derived) == FAILURE)
2273 gfc_free_expr (value);
2277 gfc_constructor_append_expr (ctor_head, value, NULL);
2281 /* If it was not found, try the default initializer if there's any;
2282 otherwise, it's an error. */
2285 if (comp->initializer)
2287 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2288 " constructor with missing optional arguments"
2289 " at %C") == FAILURE)
2291 value = gfc_copy_expr (comp->initializer);
2295 gfc_error ("No initializer for component '%s' given in the"
2296 " structure constructor at %C!", comp->name);
2301 value = comp_iter->val;
2303 /* Add the value to the constructor chain built. */
2304 gfc_constructor_append_expr (ctor_head, value, NULL);
2306 /* Remove the entry from the component list. We don't want the expression
2307 value to be free'd, so set it to NULL. */
2310 *next_ptr = comp_iter->next;
2311 comp_iter->val = NULL;
2312 gfc_free_structure_ctor_component (comp_iter);
2320 gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
2321 gfc_actual_arglist **arglist,
2324 gfc_actual_arglist *actual;
2325 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2326 gfc_constructor_base ctor_head = NULL;
2327 gfc_component *comp; /* Is set NULL when named component is first seen */
2328 const char* last_name = NULL;
2332 expr = parent ? *cexpr : e;
2333 old_locus = gfc_current_locus;
2335 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2337 gfc_current_locus = expr->where;
2339 comp_tail = comp_head = NULL;
2341 if (!parent && sym->attr.abstract)
2343 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2344 sym->name, &expr->where);
2348 comp = sym->components;
2349 actual = parent ? *arglist : expr->value.function.actual;
2352 gfc_component *this_comp = NULL;
2355 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2358 comp_tail->next = gfc_get_structure_ctor_component ();
2359 comp_tail = comp_tail->next;
2363 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2364 " constructor with named arguments at %C")
2368 comp_tail->name = xstrdup (actual->name);
2369 last_name = comp_tail->name;
2374 /* Components without name are not allowed after the first named
2375 component initializer! */
2379 gfc_error ("Component initializer without name after component"
2380 " named %s at %L!", last_name,
2381 actual->expr ? &actual->expr->where
2382 : &gfc_current_locus);
2384 gfc_error ("Too many components in structure constructor at "
2385 "%L!", actual->expr ? &actual->expr->where
2386 : &gfc_current_locus);
2390 comp_tail->name = xstrdup (comp->name);
2393 /* Find the current component in the structure definition and check
2394 its access is not private. */
2396 this_comp = gfc_find_component (sym, comp->name, false, false);
2399 this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2401 comp = NULL; /* Reset needed! */
2404 /* Here we can check if a component name is given which does not
2405 correspond to any component of the defined structure. */
2409 comp_tail->val = actual->expr;
2410 if (actual->expr != NULL)
2411 comp_tail->where = actual->expr->where;
2412 actual->expr = NULL;
2414 /* Check if this component is already given a value. */
2415 for (comp_iter = comp_head; comp_iter != comp_tail;
2416 comp_iter = comp_iter->next)
2418 gcc_assert (comp_iter);
2419 if (!strcmp (comp_iter->name, comp_tail->name))
2421 gfc_error ("Component '%s' is initialized twice in the structure"
2422 " constructor at %L!", comp_tail->name,
2423 comp_tail->val ? &comp_tail->where
2424 : &gfc_current_locus);
2429 /* F2008, R457/C725, for PURE C1283. */
2430 if (this_comp->attr.pointer && comp_tail->val
2431 && gfc_is_coindexed (comp_tail->val))
2433 gfc_error ("Coindexed expression to pointer component '%s' in "
2434 "structure constructor at %L!", comp_tail->name,
2439 /* If not explicitly a parent constructor, gather up the components
2441 if (comp && comp == sym->components
2442 && sym->attr.extension
2444 && (comp_tail->val->ts.type != BT_DERIVED
2446 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2449 gfc_actual_arglist *arg_null = NULL;
2451 actual->expr = comp_tail->val;
2452 comp_tail->val = NULL;
2454 m = gfc_convert_to_structure_constructor (NULL,
2455 comp->ts.u.derived, &comp_tail->val,
2456 comp->ts.u.derived->attr.zero_comp
2457 ? &arg_null : &actual, true);
2461 if (comp->ts.u.derived->attr.zero_comp)
2470 if (parent && !comp)
2473 actual = actual->next;
2476 if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2479 /* No component should be left, as this should have caused an error in the
2480 loop constructing the component-list (name that does not correspond to any
2481 component in the structure definition). */
2482 if (comp_head && sym->attr.extension)
2484 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2486 gfc_error ("component '%s' at %L has already been set by a "
2487 "parent derived type constructor", comp_iter->name,
2493 gcc_assert (!comp_head);
2497 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
2498 expr->ts.u.derived = sym;
2499 expr->value.constructor = ctor_head;
2504 expr->ts.u.derived = sym;
2506 expr->ts.type = BT_DERIVED;
2507 expr->value.constructor = ctor_head;
2508 expr->expr_type = EXPR_STRUCTURE;
2511 gfc_current_locus = old_locus;
2517 gfc_current_locus = old_locus;
2519 for (comp_iter = comp_head; comp_iter; )
2521 gfc_structure_ctor_component *next = comp_iter->next;
2522 gfc_free_structure_ctor_component (comp_iter);
2525 gfc_constructor_free (ctor_head);
2532 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
2536 gfc_symtree *symtree;
2538 gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */
2540 e = gfc_get_expr ();
2541 e->symtree = symtree;
2542 e->expr_type = EXPR_FUNCTION;
2544 gcc_assert (sym->attr.flavor == FL_DERIVED
2545 && symtree->n.sym->attr.flavor == FL_PROCEDURE);
2546 e->value.function.esym = sym;
2547 e->symtree->n.sym->attr.generic = 1;
2549 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2556 if (gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)
2568 /* If the symbol is an implicit do loop index and implicitly typed,
2569 it should not be host associated. Provide a symtree from the
2570 current namespace. */
2572 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2574 if ((*sym)->attr.flavor == FL_VARIABLE
2575 && (*sym)->ns != gfc_current_ns
2576 && (*sym)->attr.implied_index
2577 && (*sym)->attr.implicit_type
2578 && !(*sym)->attr.use_assoc)
2581 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2584 *sym = (*st)->n.sym;
2590 /* Procedure pointer as function result: Replace the function symbol by the
2591 auto-generated hidden result variable named "ppr@". */
2594 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2596 /* Check for procedure pointer result variable. */
2597 if ((*sym)->attr.function && !(*sym)->attr.external
2598 && (*sym)->result && (*sym)->result != *sym
2599 && (*sym)->result->attr.proc_pointer
2600 && (*sym) == gfc_current_ns->proc_name
2601 && (*sym) == (*sym)->result->ns->proc_name
2602 && strcmp ("ppr@", (*sym)->result->name) == 0)
2604 /* Automatic replacement with "hidden" result variable. */
2605 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2606 *sym = (*sym)->result;
2607 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2614 /* Matches a variable name followed by anything that might follow it--
2615 array reference, argument list of a function, etc. */
2618 gfc_match_rvalue (gfc_expr **result)
2620 gfc_actual_arglist *actual_arglist;
2621 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2624 gfc_symtree *symtree;
2625 locus where, old_loc;
2633 m = gfc_match_name (name);
2637 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2638 && !gfc_current_ns->has_import_set)
2639 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2641 i = gfc_get_ha_sym_tree (name, &symtree);
2646 sym = symtree->n.sym;
2648 where = gfc_current_locus;
2650 replace_hidden_procptr_result (&sym, &symtree);
2652 /* If this is an implicit do loop index and implicitly typed,
2653 it should not be host associated. */
2654 m = check_for_implicit_index (&symtree, &sym);
2658 gfc_set_sym_referenced (sym);
2659 sym->attr.implied_index = 0;
2661 if (sym->attr.function && sym->result == sym)
2663 /* See if this is a directly recursive function call. */
2664 gfc_gobble_whitespace ();
2665 if (sym->attr.recursive
2666 && gfc_peek_ascii_char () == '('
2667 && gfc_current_ns->proc_name == sym
2668 && !sym->attr.dimension)
2670 gfc_error ("'%s' at %C is the name of a recursive function "
2671 "and so refers to the result variable. Use an "
2672 "explicit RESULT variable for direct recursion "
2673 "(12.5.2.1)", sym->name);
2677 if (gfc_is_function_return_value (sym, gfc_current_ns))
2681 && (sym->ns == gfc_current_ns
2682 || sym->ns == gfc_current_ns->parent))
2684 gfc_entry_list *el = NULL;
2686 for (el = sym->ns->entries; el; el = el->next)
2692 if (gfc_matching_procptr_assignment)
2695 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2698 if (sym->attr.generic)
2699 goto generic_function;
2701 switch (sym->attr.flavor)
2705 e = gfc_get_expr ();
2707 e->expr_type = EXPR_VARIABLE;
2708 e->symtree = symtree;
2710 m = gfc_match_varspec (e, 0, false, true);
2714 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2715 end up here. Unfortunately, sym->value->expr_type is set to
2716 EXPR_CONSTANT, and so the if () branch would be followed without
2717 the !sym->as check. */
2718 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2719 e = gfc_copy_expr (sym->value);
2722 e = gfc_get_expr ();
2723 e->expr_type = EXPR_VARIABLE;
2726 e->symtree = symtree;
2727 m = gfc_match_varspec (e, 0, false, true);
2729 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2732 /* Variable array references to derived type parameters cause
2733 all sorts of headaches in simplification. Treating such
2734 expressions as variable works just fine for all array
2736 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2738 for (ref = e->ref; ref; ref = ref->next)
2739 if (ref->type == REF_ARRAY)
2742 if (ref == NULL || ref->u.ar.type == AR_FULL)
2748 e = gfc_get_expr ();
2749 e->expr_type = EXPR_VARIABLE;
2750 e->symtree = symtree;
2757 sym = gfc_use_derived (sym);
2761 goto generic_function;
2764 /* If we're here, then the name is known to be the name of a
2765 procedure, yet it is not sure to be the name of a function. */
2768 /* Procedure Pointer Assignments. */
2770 if (gfc_matching_procptr_assignment)
2772 gfc_gobble_whitespace ();
2773 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2774 /* Parse functions returning a procptr. */
2777 if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2778 || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2779 sym->attr.intrinsic = 1;
2780 e = gfc_get_expr ();
2781 e->expr_type = EXPR_VARIABLE;
2782 e->symtree = symtree;
2783 m = gfc_match_varspec (e, 0, false, true);
2787 if (sym->attr.subroutine)
2789 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2795 /* At this point, the name has to be a non-statement function.
2796 If the name is the same as the current function being
2797 compiled, then we have a variable reference (to the function
2798 result) if the name is non-recursive. */
2800 st = gfc_enclosing_unit (NULL);
2802 if (st != NULL && st->state == COMP_FUNCTION
2804 && !sym->attr.recursive)
2806 e = gfc_get_expr ();
2807 e->symtree = symtree;
2808 e->expr_type = EXPR_VARIABLE;
2810 m = gfc_match_varspec (e, 0, false, true);
2814 /* Match a function reference. */
2816 m = gfc_match_actual_arglist (0, &actual_arglist);
2819 if (sym->attr.proc == PROC_ST_FUNCTION)
2820 gfc_error ("Statement function '%s' requires argument list at %C",
2823 gfc_error ("Function '%s' requires an argument list at %C",
2836 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2837 sym = symtree->n.sym;
2839 replace_hidden_procptr_result (&sym, &symtree);
2841 e = gfc_get_expr ();
2842 e->symtree = symtree;
2843 e->expr_type = EXPR_FUNCTION;
2844 e->value.function.actual = actual_arglist;
2845 e->where = gfc_current_locus;
2847 if (sym->as != NULL)
2848 e->rank = sym->as->rank;
2850 if (!sym->attr.function
2851 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2857 /* Check here for the existence of at least one argument for the
2858 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2859 argument(s) given will be checked in gfc_iso_c_func_interface,
2860 during resolution of the function call. */
2861 if (sym->attr.is_iso_c == 1
2862 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2863 && (sym->intmod_sym_id == ISOCBINDING_LOC
2864 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2865 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2867 /* make sure we were given a param */
2868 if (actual_arglist == NULL)
2870 gfc_error ("Missing argument to '%s' at %C", sym->name);
2876 if (sym->result == NULL)
2884 /* Special case for derived type variables that get their types
2885 via an IMPLICIT statement. This can't wait for the
2886 resolution phase. */
2888 if (gfc_peek_ascii_char () == '%'
2889 && sym->ts.type == BT_UNKNOWN
2890 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2891 gfc_set_default_type (sym, 0, sym->ns);
2893 /* If the symbol has a dimension attribute, the expression is a
2896 if (sym->attr.dimension)
2898 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2899 sym->name, NULL) == FAILURE)
2905 e = gfc_get_expr ();
2906 e->symtree = symtree;
2907 e->expr_type = EXPR_VARIABLE;
2908 m = gfc_match_varspec (e, 0, false, true);
2912 /* Name is not an array, so we peek to see if a '(' implies a
2913 function call or a substring reference. Otherwise the
2914 variable is just a scalar. */
2916 gfc_gobble_whitespace ();
2917 if (gfc_peek_ascii_char () != '(')
2919 /* Assume a scalar variable */
2920 e = gfc_get_expr ();
2921 e->symtree = symtree;
2922 e->expr_type = EXPR_VARIABLE;
2924 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2925 sym->name, NULL) == FAILURE)
2931 /*FIXME:??? gfc_match_varspec does set this for us: */
2933 m = gfc_match_varspec (e, 0, false, true);
2937 /* See if this is a function reference with a keyword argument
2938 as first argument. We do this because otherwise a spurious
2939 symbol would end up in the symbol table. */
2941 old_loc = gfc_current_locus;
2942 m2 = gfc_match (" ( %n =", argname);
2943 gfc_current_locus = old_loc;
2945 e = gfc_get_expr ();
2946 e->symtree = symtree;
2948 if (m2 != MATCH_YES)
2950 /* Try to figure out whether we're dealing with a character type.
2951 We're peeking ahead here, because we don't want to call
2952 match_substring if we're dealing with an implicitly typed
2953 non-character variable. */
2954 implicit_char = false;
2955 if (sym->ts.type == BT_UNKNOWN)
2957 ts = gfc_get_default_type (sym->name, NULL);
2958 if (ts->type == BT_CHARACTER)
2959 implicit_char = true;
2962 /* See if this could possibly be a substring reference of a name
2963 that we're not sure is a variable yet. */
2965 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2966 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2969 e->expr_type = EXPR_VARIABLE;
2971 if (sym->attr.flavor != FL_VARIABLE
2972 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2973 sym->name, NULL) == FAILURE)
2979 if (sym->ts.type == BT_UNKNOWN
2980 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2994 /* Give up, assume we have a function. */
2996 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
2997 sym = symtree->n.sym;
2998 e->expr_type = EXPR_FUNCTION;
3000 if (!sym->attr.function
3001 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
3009 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3011 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
3019 /* If our new function returns a character, array or structure
3020 type, it might have subsequent references. */
3022 m = gfc_match_varspec (e, 0, false, true);
3029 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3031 e = gfc_get_expr ();
3032 e->symtree = symtree;
3033 e->expr_type = EXPR_FUNCTION;
3035 if (sym->attr.flavor == FL_DERIVED)
3037 e->value.function.esym = sym;
3038 e->symtree->n.sym->attr.generic = 1;
3041 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3045 gfc_error ("Symbol at %C is not appropriate for an expression");
3061 /* Match a variable, i.e. something that can be assigned to. This
3062 starts as a symbol, can be a structure component or an array
3063 reference. It can be a function if the function doesn't have a
3064 separate RESULT variable. If the symbol has not been previously
3065 seen, we assume it is a variable.
3067 This function is called by two interface functions:
3068 gfc_match_variable, which has host_flag = 1, and
3069 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3070 match of the symbol to the local scope. */
3073 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
3081 /* Since nothing has any business being an lvalue in a module
3082 specification block, an interface block or a contains section,
3083 we force the changed_symbols mechanism to work by setting
3084 host_flag to 0. This prevents valid symbols that have the name
3085 of keywords, such as 'end', being turned into variables by
3086 failed matching to assignments for, e.g., END INTERFACE. */
3087 if (gfc_current_state () == COMP_MODULE
3088 || gfc_current_state () == COMP_INTERFACE
3089 || gfc_current_state () == COMP_CONTAINS)
3092 where = gfc_current_locus;
3093 m = gfc_match_sym_tree (&st, host_flag);
3099 /* If this is an implicit do loop index and implicitly typed,
3100 it should not be host associated. */
3101 m = check_for_implicit_index (&st, &sym);
3105 sym->attr.implied_index = 0;
3107 gfc_set_sym_referenced (sym);
3108 switch (sym->attr.flavor)
3111 /* Everything is alright. */
3116 sym_flavor flavor = FL_UNKNOWN;
3118 gfc_gobble_whitespace ();
3120 if (sym->attr.external || sym->attr.procedure
3121 || sym->attr.function || sym->attr.subroutine)
3122 flavor = FL_PROCEDURE;
3124 /* If it is not a procedure, is not typed and is host associated,
3125 we cannot give it a flavor yet. */
3126 else if (sym->ns == gfc_current_ns->parent
3127 && sym->ts.type == BT_UNKNOWN)
3130 /* These are definitive indicators that this is a variable. */
3131 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3132 || sym->attr.pointer || sym->as != NULL)
3133 flavor = FL_VARIABLE;
3135 if (flavor != FL_UNKNOWN
3136 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
3144 gfc_error ("Named constant at %C in an EQUIVALENCE");
3147 /* Otherwise this is checked for and an error given in the
3148 variable definition context checks. */
3152 /* Check for a nonrecursive function result variable. */
3153 if (sym->attr.function
3154 && !sym->attr.external
3155 && sym->result == sym
3156 && (gfc_is_function_return_value (sym, gfc_current_ns)
3158 && sym->ns == gfc_current_ns)
3160 && sym->ns == gfc_current_ns->parent)))
3162 /* If a function result is a derived type, then the derived
3163 type may still have to be resolved. */
3165 if (sym->ts.type == BT_DERIVED
3166 && gfc_use_derived (sym->ts.u.derived) == NULL)
3171 if (sym->attr.proc_pointer
3172 || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3175 /* Fall through to error */
3178 gfc_error ("'%s' at %C is not a variable", sym->name);
3182 /* Special case for derived type variables that get their types
3183 via an IMPLICIT statement. This can't wait for the
3184 resolution phase. */
3187 gfc_namespace * implicit_ns;
3189 if (gfc_current_ns->proc_name == sym)
3190 implicit_ns = gfc_current_ns;
3192 implicit_ns = sym->ns;
3194 if (gfc_peek_ascii_char () == '%'
3195 && sym->ts.type == BT_UNKNOWN
3196 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3197 gfc_set_default_type (sym, 0, implicit_ns);
3200 expr = gfc_get_expr ();
3202 expr->expr_type = EXPR_VARIABLE;
3205 expr->where = where;
3207 /* Now see if we have to do more. */
3208 m = gfc_match_varspec (expr, equiv_flag, false, false);
3211 gfc_free_expr (expr);
3221 gfc_match_variable (gfc_expr **result, int equiv_flag)
3223 return match_variable (result, equiv_flag, 1);
3228 gfc_match_equiv_variable (gfc_expr **result)
3230 return match_variable (result, 1, 0);