Fix ChangeLog
[official-gcc.git] / gcc / fortran / primary.c
bloba9b47d8bced79095902c99e7f359af41f49256ac
1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
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
11 version.
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
16 for more details.
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/>. */
22 #include "config.h"
23 #include "system.h"
24 #include "flags.h"
25 #include "gfortran.h"
26 #include "arith.h"
27 #include "match.h"
28 #include "parse.h"
29 #include "toplev.h"
31 /* Matches a kind-parameter expression, which is either a named
32 symbolic constant or a nonnegative integer constant. If
33 successful, sets the kind value to the correct integer. */
35 static match
36 match_kind_param (int *kind)
38 char name[GFC_MAX_SYMBOL_LEN + 1];
39 gfc_symbol *sym;
40 const char *p;
41 match m;
43 m = gfc_match_small_literal_int (kind, NULL);
44 if (m != MATCH_NO)
45 return m;
47 m = gfc_match_name (name);
48 if (m != MATCH_YES)
49 return m;
51 if (gfc_find_symbol (name, NULL, 1, &sym))
52 return MATCH_ERROR;
54 if (sym == NULL)
55 return MATCH_NO;
57 if (sym->attr.flavor != FL_PARAMETER)
58 return MATCH_NO;
60 p = gfc_extract_int (sym->value, kind);
61 if (p != NULL)
62 return MATCH_NO;
64 gfc_set_sym_referenced (sym);
66 if (*kind < 0)
67 return MATCH_NO;
69 return MATCH_YES;
73 /* Get a trailing kind-specification for non-character variables.
74 Returns:
75 the integer kind value or:
76 -1 if an error was generated
77 -2 if no kind was found */
79 static int
80 get_kind (void)
82 int kind;
83 match m;
85 if (gfc_match_char ('_') != MATCH_YES)
86 return -2;
88 m = match_kind_param (&kind);
89 if (m == MATCH_NO)
90 gfc_error ("Missing kind-parameter at %C");
92 return (m == MATCH_YES) ? kind : -1;
96 /* Given a character and a radix, see if the character is a valid
97 digit in that radix. */
99 int
100 gfc_check_digit (char c, int radix)
102 int r;
104 switch (radix)
106 case 2:
107 r = ('0' <= c && c <= '1');
108 break;
110 case 8:
111 r = ('0' <= c && c <= '7');
112 break;
114 case 10:
115 r = ('0' <= c && c <= '9');
116 break;
118 case 16:
119 r = ISXDIGIT (c);
120 break;
122 default:
123 gfc_internal_error ("gfc_check_digit(): bad radix");
126 return r;
130 /* Match the digit string part of an integer if signflag is not set,
131 the signed digit string part if signflag is set. If the buffer
132 is NULL, we just count characters for the resolution pass. Returns
133 the number of characters matched, -1 for no match. */
135 static int
136 match_digits (int signflag, int radix, char *buffer)
138 locus old_loc;
139 int length;
140 char c;
142 length = 0;
143 c = gfc_next_ascii_char ();
145 if (signflag && (c == '+' || c == '-'))
147 if (buffer != NULL)
148 *buffer++ = c;
149 gfc_gobble_whitespace ();
150 c = gfc_next_ascii_char ();
151 length++;
154 if (!gfc_check_digit (c, radix))
155 return -1;
157 length++;
158 if (buffer != NULL)
159 *buffer++ = c;
161 for (;;)
163 old_loc = gfc_current_locus;
164 c = gfc_next_ascii_char ();
166 if (!gfc_check_digit (c, radix))
167 break;
169 if (buffer != NULL)
170 *buffer++ = c;
171 length++;
174 gfc_current_locus = old_loc;
176 return length;
180 /* Match an integer (digit string and optional kind).
181 A sign will be accepted if signflag is set. */
183 static match
184 match_integer_constant (gfc_expr **result, int signflag)
186 int length, kind;
187 locus old_loc;
188 char *buffer;
189 gfc_expr *e;
191 old_loc = gfc_current_locus;
192 gfc_gobble_whitespace ();
194 length = match_digits (signflag, 10, NULL);
195 gfc_current_locus = old_loc;
196 if (length == -1)
197 return MATCH_NO;
199 buffer = alloca (length + 1);
200 memset (buffer, '\0', length + 1);
202 gfc_gobble_whitespace ();
204 match_digits (signflag, 10, buffer);
206 kind = get_kind ();
207 if (kind == -2)
208 kind = gfc_default_integer_kind;
209 if (kind == -1)
210 return MATCH_ERROR;
212 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
214 gfc_error ("Integer kind %d at %C not available", kind);
215 return MATCH_ERROR;
218 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
220 if (gfc_range_check (e) != ARITH_OK)
222 gfc_error ("Integer too big for its kind at %C. This check can be "
223 "disabled with the option -fno-range-check");
225 gfc_free_expr (e);
226 return MATCH_ERROR;
229 *result = e;
230 return MATCH_YES;
234 /* Match a Hollerith constant. */
236 static match
237 match_hollerith_constant (gfc_expr **result)
239 locus old_loc;
240 gfc_expr *e = NULL;
241 const char *msg;
242 int num;
243 int i;
245 old_loc = gfc_current_locus;
246 gfc_gobble_whitespace ();
248 if (match_integer_constant (&e, 0) == MATCH_YES
249 && gfc_match_char ('h') == MATCH_YES)
251 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
252 "at %C") == FAILURE)
253 goto cleanup;
255 msg = gfc_extract_int (e, &num);
256 if (msg != NULL)
258 gfc_error (msg);
259 goto cleanup;
261 if (num == 0)
263 gfc_error ("Invalid Hollerith constant: %L must contain at least "
264 "one character", &old_loc);
265 goto cleanup;
267 if (e->ts.kind != gfc_default_integer_kind)
269 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
270 "should be default", &old_loc);
271 goto cleanup;
273 else
275 gfc_free_expr (e);
276 e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
277 &gfc_current_locus);
279 e->representation.string = gfc_getmem (num + 1);
281 for (i = 0; i < num; i++)
283 gfc_char_t c = gfc_next_char_literal (1);
284 if (! gfc_wide_fits_in_byte (c))
286 gfc_error ("Invalid Hollerith constant at %L contains a "
287 "wide character", &old_loc);
288 goto cleanup;
291 e->representation.string[i] = (unsigned char) c;
294 e->representation.string[num] = '\0';
295 e->representation.length = num;
297 *result = e;
298 return MATCH_YES;
302 gfc_free_expr (e);
303 gfc_current_locus = old_loc;
304 return MATCH_NO;
306 cleanup:
307 gfc_free_expr (e);
308 return MATCH_ERROR;
312 /* Match a binary, octal or hexadecimal constant that can be found in
313 a DATA statement. The standard permits b'010...', o'73...', and
314 z'a1...' where b, o, and z can be capital letters. This function
315 also accepts postfixed forms of the constants: '01...'b, '73...'o,
316 and 'a1...'z. An additional extension is the use of x for z. */
318 static match
319 match_boz_constant (gfc_expr **result)
321 int radix, length, x_hex, kind;
322 locus old_loc, start_loc;
323 char *buffer, post, delim;
324 gfc_expr *e;
326 start_loc = old_loc = gfc_current_locus;
327 gfc_gobble_whitespace ();
329 x_hex = 0;
330 switch (post = gfc_next_ascii_char ())
332 case 'b':
333 radix = 2;
334 post = 0;
335 break;
336 case 'o':
337 radix = 8;
338 post = 0;
339 break;
340 case 'x':
341 x_hex = 1;
342 /* Fall through. */
343 case 'z':
344 radix = 16;
345 post = 0;
346 break;
347 case '\'':
348 /* Fall through. */
349 case '\"':
350 delim = post;
351 post = 1;
352 radix = 16; /* Set to accept any valid digit string. */
353 break;
354 default:
355 goto backup;
358 /* No whitespace allowed here. */
360 if (post == 0)
361 delim = gfc_next_ascii_char ();
363 if (delim != '\'' && delim != '\"')
364 goto backup;
366 if (x_hex
367 && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
368 "constant at %C uses non-standard syntax")
369 == FAILURE))
370 return MATCH_ERROR;
372 old_loc = gfc_current_locus;
374 length = match_digits (0, radix, NULL);
375 if (length == -1)
377 gfc_error ("Empty set of digits in BOZ constant at %C");
378 return MATCH_ERROR;
381 if (gfc_next_ascii_char () != delim)
383 gfc_error ("Illegal character in BOZ constant at %C");
384 return MATCH_ERROR;
387 if (post == 1)
389 switch (gfc_next_ascii_char ())
391 case 'b':
392 radix = 2;
393 break;
394 case 'o':
395 radix = 8;
396 break;
397 case 'x':
398 /* Fall through. */
399 case 'z':
400 radix = 16;
401 break;
402 default:
403 goto backup;
406 if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
407 "at %C uses non-standard postfix syntax")
408 == FAILURE)
409 return MATCH_ERROR;
412 gfc_current_locus = old_loc;
414 buffer = alloca (length + 1);
415 memset (buffer, '\0', length + 1);
417 match_digits (0, radix, buffer);
418 gfc_next_ascii_char (); /* Eat delimiter. */
419 if (post == 1)
420 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
422 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
423 "If a data-stmt-constant is a boz-literal-constant, the corresponding
424 variable shall be of type integer. The boz-literal-constant is treated
425 as if it were an int-literal-constant with a kind-param that specifies
426 the representation method with the largest decimal exponent range
427 supported by the processor." */
429 kind = gfc_max_integer_kind;
430 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
432 /* Mark as boz variable. */
433 e->is_boz = 1;
435 if (gfc_range_check (e) != ARITH_OK)
437 gfc_error ("Integer too big for integer kind %i at %C", kind);
438 gfc_free_expr (e);
439 return MATCH_ERROR;
442 if (!gfc_in_match_data ()
443 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
444 "statement at %C")
445 == FAILURE))
446 return MATCH_ERROR;
448 *result = e;
449 return MATCH_YES;
451 backup:
452 gfc_current_locus = start_loc;
453 return MATCH_NO;
457 /* Match a real constant of some sort. Allow a signed constant if signflag
458 is nonzero. */
460 static match
461 match_real_constant (gfc_expr **result, int signflag)
463 int kind, count, seen_dp, seen_digits;
464 locus old_loc, temp_loc;
465 char *p, *buffer, c, exp_char;
466 gfc_expr *e;
467 bool negate;
469 old_loc = gfc_current_locus;
470 gfc_gobble_whitespace ();
472 e = NULL;
474 count = 0;
475 seen_dp = 0;
476 seen_digits = 0;
477 exp_char = ' ';
478 negate = FALSE;
480 c = gfc_next_ascii_char ();
481 if (signflag && (c == '+' || c == '-'))
483 if (c == '-')
484 negate = TRUE;
486 gfc_gobble_whitespace ();
487 c = gfc_next_ascii_char ();
490 /* Scan significand. */
491 for (;; c = gfc_next_ascii_char (), count++)
493 if (c == '.')
495 if (seen_dp)
496 goto done;
498 /* Check to see if "." goes with a following operator like
499 ".eq.". */
500 temp_loc = gfc_current_locus;
501 c = gfc_next_ascii_char ();
503 if (c == 'e' || c == 'd' || c == 'q')
505 c = gfc_next_ascii_char ();
506 if (c == '.')
507 goto done; /* Operator named .e. or .d. */
510 if (ISALPHA (c))
511 goto done; /* Distinguish 1.e9 from 1.eq.2 */
513 gfc_current_locus = temp_loc;
514 seen_dp = 1;
515 continue;
518 if (ISDIGIT (c))
520 seen_digits = 1;
521 continue;
524 break;
527 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
528 goto done;
529 exp_char = c;
531 /* Scan exponent. */
532 c = gfc_next_ascii_char ();
533 count++;
535 if (c == '+' || c == '-')
536 { /* optional sign */
537 c = gfc_next_ascii_char ();
538 count++;
541 if (!ISDIGIT (c))
543 gfc_error ("Missing exponent in real number at %C");
544 return MATCH_ERROR;
547 while (ISDIGIT (c))
549 c = gfc_next_ascii_char ();
550 count++;
553 done:
554 /* Check that we have a numeric constant. */
555 if (!seen_digits || (!seen_dp && exp_char == ' '))
557 gfc_current_locus = old_loc;
558 return MATCH_NO;
561 /* Convert the number. */
562 gfc_current_locus = old_loc;
563 gfc_gobble_whitespace ();
565 buffer = alloca (count + 1);
566 memset (buffer, '\0', count + 1);
568 p = buffer;
569 c = gfc_next_ascii_char ();
570 if (c == '+' || c == '-')
572 gfc_gobble_whitespace ();
573 c = gfc_next_ascii_char ();
576 /* Hack for mpfr_set_str(). */
577 for (;;)
579 if (c == 'd' || c == 'q')
580 *p = 'e';
581 else
582 *p = c;
583 p++;
584 if (--count == 0)
585 break;
587 c = gfc_next_ascii_char ();
590 kind = get_kind ();
591 if (kind == -1)
592 goto cleanup;
594 switch (exp_char)
596 case 'd':
597 if (kind != -2)
599 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
600 "kind");
601 goto cleanup;
603 kind = gfc_default_double_kind;
604 break;
606 default:
607 if (kind == -2)
608 kind = gfc_default_real_kind;
610 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
612 gfc_error ("Invalid real kind %d at %C", kind);
613 goto cleanup;
617 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
618 if (negate)
619 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
621 switch (gfc_range_check (e))
623 case ARITH_OK:
624 break;
625 case ARITH_OVERFLOW:
626 gfc_error ("Real constant overflows its kind at %C");
627 goto cleanup;
629 case ARITH_UNDERFLOW:
630 if (gfc_option.warn_underflow)
631 gfc_warning ("Real constant underflows its kind at %C");
632 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
633 break;
635 default:
636 gfc_internal_error ("gfc_range_check() returned bad value");
639 *result = e;
640 return MATCH_YES;
642 cleanup:
643 gfc_free_expr (e);
644 return MATCH_ERROR;
648 /* Match a substring reference. */
650 static match
651 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
653 gfc_expr *start, *end;
654 locus old_loc;
655 gfc_ref *ref;
656 match m;
658 start = NULL;
659 end = NULL;
661 old_loc = gfc_current_locus;
663 m = gfc_match_char ('(');
664 if (m != MATCH_YES)
665 return MATCH_NO;
667 if (gfc_match_char (':') != MATCH_YES)
669 if (init)
670 m = gfc_match_init_expr (&start);
671 else
672 m = gfc_match_expr (&start);
674 if (m != MATCH_YES)
676 m = MATCH_NO;
677 goto cleanup;
680 m = gfc_match_char (':');
681 if (m != MATCH_YES)
682 goto cleanup;
685 if (gfc_match_char (')') != MATCH_YES)
687 if (init)
688 m = gfc_match_init_expr (&end);
689 else
690 m = gfc_match_expr (&end);
692 if (m == MATCH_NO)
693 goto syntax;
694 if (m == MATCH_ERROR)
695 goto cleanup;
697 m = gfc_match_char (')');
698 if (m == MATCH_NO)
699 goto syntax;
702 /* Optimize away the (:) reference. */
703 if (start == NULL && end == NULL)
704 ref = NULL;
705 else
707 ref = gfc_get_ref ();
709 ref->type = REF_SUBSTRING;
710 if (start == NULL)
711 start = gfc_int_expr (1);
712 ref->u.ss.start = start;
713 if (end == NULL && cl)
714 end = gfc_copy_expr (cl->length);
715 ref->u.ss.end = end;
716 ref->u.ss.length = cl;
719 *result = ref;
720 return MATCH_YES;
722 syntax:
723 gfc_error ("Syntax error in SUBSTRING specification at %C");
724 m = MATCH_ERROR;
726 cleanup:
727 gfc_free_expr (start);
728 gfc_free_expr (end);
730 gfc_current_locus = old_loc;
731 return m;
735 /* Reads the next character of a string constant, taking care to
736 return doubled delimiters on the input as a single instance of
737 the delimiter.
739 Special return values for "ret" argument are:
740 -1 End of the string, as determined by the delimiter
741 -2 Unterminated string detected
743 Backslash codes are also expanded at this time. */
745 static gfc_char_t
746 next_string_char (gfc_char_t delimiter, int *ret)
748 locus old_locus;
749 gfc_char_t c;
751 c = gfc_next_char_literal (1);
752 *ret = 0;
754 if (c == '\n')
756 *ret = -2;
757 return 0;
760 if (gfc_option.flag_backslash && c == '\\')
762 old_locus = gfc_current_locus;
764 if (gfc_match_special_char (&c) == MATCH_NO)
765 gfc_current_locus = old_locus;
767 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
768 gfc_warning ("Extension: backslash character at %C");
771 if (c != delimiter)
772 return c;
774 old_locus = gfc_current_locus;
775 c = gfc_next_char_literal (0);
777 if (c == delimiter)
778 return c;
779 gfc_current_locus = old_locus;
781 *ret = -1;
782 return 0;
786 /* Special case of gfc_match_name() that matches a parameter kind name
787 before a string constant. This takes case of the weird but legal
788 case of:
790 kind_____'string'
792 where kind____ is a parameter. gfc_match_name() will happily slurp
793 up all the underscores, which leads to problems. If we return
794 MATCH_YES, the parse pointer points to the final underscore, which
795 is not part of the name. We never return MATCH_ERROR-- errors in
796 the name will be detected later. */
798 static match
799 match_charkind_name (char *name)
801 locus old_loc;
802 char c, peek;
803 int len;
805 gfc_gobble_whitespace ();
806 c = gfc_next_ascii_char ();
807 if (!ISALPHA (c))
808 return MATCH_NO;
810 *name++ = c;
811 len = 1;
813 for (;;)
815 old_loc = gfc_current_locus;
816 c = gfc_next_ascii_char ();
818 if (c == '_')
820 peek = gfc_peek_ascii_char ();
822 if (peek == '\'' || peek == '\"')
824 gfc_current_locus = old_loc;
825 *name = '\0';
826 return MATCH_YES;
830 if (!ISALNUM (c)
831 && c != '_'
832 && (gfc_option.flag_dollar_ok && c != '$'))
833 break;
835 *name++ = c;
836 if (++len > GFC_MAX_SYMBOL_LEN)
837 break;
840 return MATCH_NO;
844 /* See if the current input matches a character constant. Lots of
845 contortions have to be done to match the kind parameter which comes
846 before the actual string. The main consideration is that we don't
847 want to error out too quickly. For example, we don't actually do
848 any validation of the kinds until we have actually seen a legal
849 delimiter. Using match_kind_param() generates errors too quickly. */
851 static match
852 match_string_constant (gfc_expr **result)
854 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
855 int i, kind, length, warn_ampersand, ret;
856 locus old_locus, start_locus;
857 gfc_symbol *sym;
858 gfc_expr *e;
859 const char *q;
860 match m;
861 gfc_char_t c, delimiter, *p;
863 old_locus = gfc_current_locus;
865 gfc_gobble_whitespace ();
867 start_locus = gfc_current_locus;
869 c = gfc_next_char ();
870 if (c == '\'' || c == '"')
872 kind = gfc_default_character_kind;
873 goto got_delim;
876 if (gfc_wide_is_digit (c))
878 kind = 0;
880 while (gfc_wide_is_digit (c))
882 kind = kind * 10 + c - '0';
883 if (kind > 9999999)
884 goto no_match;
885 c = gfc_next_char ();
889 else
891 gfc_current_locus = old_locus;
893 m = match_charkind_name (name);
894 if (m != MATCH_YES)
895 goto no_match;
897 if (gfc_find_symbol (name, NULL, 1, &sym)
898 || sym == NULL
899 || sym->attr.flavor != FL_PARAMETER)
900 goto no_match;
902 kind = -1;
903 c = gfc_next_char ();
906 if (c == ' ')
908 gfc_gobble_whitespace ();
909 c = gfc_next_char ();
912 if (c != '_')
913 goto no_match;
915 gfc_gobble_whitespace ();
916 start_locus = gfc_current_locus;
918 c = gfc_next_char ();
919 if (c != '\'' && c != '"')
920 goto no_match;
922 if (kind == -1)
924 q = gfc_extract_int (sym->value, &kind);
925 if (q != NULL)
927 gfc_error (q);
928 return MATCH_ERROR;
930 gfc_set_sym_referenced (sym);
933 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
935 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
936 return MATCH_ERROR;
939 got_delim:
940 /* Scan the string into a block of memory by first figuring out how
941 long it is, allocating the structure, then re-reading it. This
942 isn't particularly efficient, but string constants aren't that
943 common in most code. TODO: Use obstacks? */
945 delimiter = c;
946 length = 0;
948 for (;;)
950 c = next_string_char (delimiter, &ret);
951 if (ret == -1)
952 break;
953 if (ret == -2)
955 gfc_current_locus = start_locus;
956 gfc_error ("Unterminated character constant beginning at %C");
957 return MATCH_ERROR;
960 length++;
963 /* Peek at the next character to see if it is a b, o, z, or x for the
964 postfixed BOZ literal constants. */
965 peek = gfc_peek_ascii_char ();
966 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
967 goto no_match;
970 e = gfc_get_expr ();
972 e->expr_type = EXPR_CONSTANT;
973 e->ref = NULL;
974 e->ts.type = BT_CHARACTER;
975 e->ts.kind = kind;
976 e->ts.is_c_interop = 0;
977 e->ts.is_iso_c = 0;
978 e->where = start_locus;
980 e->value.character.string = p = gfc_get_wide_string (length + 1);
981 e->value.character.length = length;
983 gfc_current_locus = start_locus;
984 gfc_next_char (); /* Skip delimiter */
986 /* We disable the warning for the following loop as the warning has already
987 been printed in the loop above. */
988 warn_ampersand = gfc_option.warn_ampersand;
989 gfc_option.warn_ampersand = 0;
991 for (i = 0; i < length; i++)
993 c = next_string_char (delimiter, &ret);
995 if (!gfc_check_character_range (c, kind))
997 gfc_error ("Character '%s' in string at %C is not representable "
998 "in character kind %d", gfc_print_wide_char (c), kind);
999 return MATCH_ERROR;
1002 *p++ = c;
1005 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1006 gfc_option.warn_ampersand = warn_ampersand;
1008 next_string_char (delimiter, &ret);
1009 if (ret != -1)
1010 gfc_internal_error ("match_string_constant(): Delimiter not found");
1012 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1013 e->expr_type = EXPR_SUBSTRING;
1015 *result = e;
1017 return MATCH_YES;
1019 no_match:
1020 gfc_current_locus = old_locus;
1021 return MATCH_NO;
1025 /* Match a .true. or .false. Returns 1 if a .true. was found,
1026 0 if a .false. was found, and -1 otherwise. */
1027 static int
1028 match_logical_constant_string (void)
1030 locus orig_loc = gfc_current_locus;
1032 gfc_gobble_whitespace ();
1033 if (gfc_next_ascii_char () == '.')
1035 char ch = gfc_next_ascii_char ();
1036 if (ch == 'f')
1038 if (gfc_next_ascii_char () == 'a'
1039 && gfc_next_ascii_char () == 'l'
1040 && gfc_next_ascii_char () == 's'
1041 && gfc_next_ascii_char () == 'e'
1042 && gfc_next_ascii_char () == '.')
1043 /* Matched ".false.". */
1044 return 0;
1046 else if (ch == 't')
1048 if (gfc_next_ascii_char () == 'r'
1049 && gfc_next_ascii_char () == 'u'
1050 && gfc_next_ascii_char () == 'e'
1051 && gfc_next_ascii_char () == '.')
1052 /* Matched ".true.". */
1053 return 1;
1056 gfc_current_locus = orig_loc;
1057 return -1;
1060 /* Match a .true. or .false. */
1062 static match
1063 match_logical_constant (gfc_expr **result)
1065 gfc_expr *e;
1066 int i, kind;
1068 i = match_logical_constant_string ();
1069 if (i == -1)
1070 return MATCH_NO;
1072 kind = get_kind ();
1073 if (kind == -1)
1074 return MATCH_ERROR;
1075 if (kind == -2)
1076 kind = gfc_default_logical_kind;
1078 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1080 gfc_error ("Bad kind for logical constant at %C");
1081 return MATCH_ERROR;
1084 e = gfc_get_expr ();
1086 e->expr_type = EXPR_CONSTANT;
1087 e->value.logical = i;
1088 e->ts.type = BT_LOGICAL;
1089 e->ts.kind = kind;
1090 e->ts.is_c_interop = 0;
1091 e->ts.is_iso_c = 0;
1092 e->where = gfc_current_locus;
1094 *result = e;
1095 return MATCH_YES;
1099 /* Match a real or imaginary part of a complex constant that is a
1100 symbolic constant. */
1102 static match
1103 match_sym_complex_part (gfc_expr **result)
1105 char name[GFC_MAX_SYMBOL_LEN + 1];
1106 gfc_symbol *sym;
1107 gfc_expr *e;
1108 match m;
1110 m = gfc_match_name (name);
1111 if (m != MATCH_YES)
1112 return m;
1114 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1115 return MATCH_NO;
1117 if (sym->attr.flavor != FL_PARAMETER)
1119 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1120 return MATCH_ERROR;
1123 if (!gfc_numeric_ts (&sym->value->ts))
1125 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1126 return MATCH_ERROR;
1129 if (sym->value->rank != 0)
1131 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1132 return MATCH_ERROR;
1135 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1136 "complex constant at %C") == FAILURE)
1137 return MATCH_ERROR;
1139 switch (sym->value->ts.type)
1141 case BT_REAL:
1142 e = gfc_copy_expr (sym->value);
1143 break;
1145 case BT_COMPLEX:
1146 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1147 if (e == NULL)
1148 goto error;
1149 break;
1151 case BT_INTEGER:
1152 e = gfc_int2real (sym->value, gfc_default_real_kind);
1153 if (e == NULL)
1154 goto error;
1155 break;
1157 default:
1158 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1161 *result = e; /* e is a scalar, real, constant expression. */
1162 return MATCH_YES;
1164 error:
1165 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1166 return MATCH_ERROR;
1170 /* Match a real or imaginary part of a complex number. */
1172 static match
1173 match_complex_part (gfc_expr **result)
1175 match m;
1177 m = match_sym_complex_part (result);
1178 if (m != MATCH_NO)
1179 return m;
1181 m = match_real_constant (result, 1);
1182 if (m != MATCH_NO)
1183 return m;
1185 return match_integer_constant (result, 1);
1189 /* Try to match a complex constant. */
1191 static match
1192 match_complex_constant (gfc_expr **result)
1194 gfc_expr *e, *real, *imag;
1195 gfc_error_buf old_error;
1196 gfc_typespec target;
1197 locus old_loc;
1198 int kind;
1199 match m;
1201 old_loc = gfc_current_locus;
1202 real = imag = e = NULL;
1204 m = gfc_match_char ('(');
1205 if (m != MATCH_YES)
1206 return m;
1208 gfc_push_error (&old_error);
1210 m = match_complex_part (&real);
1211 if (m == MATCH_NO)
1213 gfc_free_error (&old_error);
1214 goto cleanup;
1217 if (gfc_match_char (',') == MATCH_NO)
1219 gfc_pop_error (&old_error);
1220 m = MATCH_NO;
1221 goto cleanup;
1224 /* If m is error, then something was wrong with the real part and we
1225 assume we have a complex constant because we've seen the ','. An
1226 ambiguous case here is the start of an iterator list of some
1227 sort. These sort of lists are matched prior to coming here. */
1229 if (m == MATCH_ERROR)
1231 gfc_free_error (&old_error);
1232 goto cleanup;
1234 gfc_pop_error (&old_error);
1236 m = match_complex_part (&imag);
1237 if (m == MATCH_NO)
1238 goto syntax;
1239 if (m == MATCH_ERROR)
1240 goto cleanup;
1242 m = gfc_match_char (')');
1243 if (m == MATCH_NO)
1245 /* Give the matcher for implied do-loops a chance to run. This
1246 yields a much saner error message for (/ (i, 4=i, 6) /). */
1247 if (gfc_peek_ascii_char () == '=')
1249 m = MATCH_ERROR;
1250 goto cleanup;
1252 else
1253 goto syntax;
1256 if (m == MATCH_ERROR)
1257 goto cleanup;
1259 /* Decide on the kind of this complex number. */
1260 if (real->ts.type == BT_REAL)
1262 if (imag->ts.type == BT_REAL)
1263 kind = gfc_kind_max (real, imag);
1264 else
1265 kind = real->ts.kind;
1267 else
1269 if (imag->ts.type == BT_REAL)
1270 kind = imag->ts.kind;
1271 else
1272 kind = gfc_default_real_kind;
1274 target.type = BT_REAL;
1275 target.kind = kind;
1276 target.is_c_interop = 0;
1277 target.is_iso_c = 0;
1279 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1280 gfc_convert_type (real, &target, 2);
1281 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1282 gfc_convert_type (imag, &target, 2);
1284 e = gfc_convert_complex (real, imag, kind);
1285 e->where = gfc_current_locus;
1287 gfc_free_expr (real);
1288 gfc_free_expr (imag);
1290 *result = e;
1291 return MATCH_YES;
1293 syntax:
1294 gfc_error ("Syntax error in COMPLEX constant at %C");
1295 m = MATCH_ERROR;
1297 cleanup:
1298 gfc_free_expr (e);
1299 gfc_free_expr (real);
1300 gfc_free_expr (imag);
1301 gfc_current_locus = old_loc;
1303 return m;
1307 /* Match constants in any of several forms. Returns nonzero for a
1308 match, zero for no match. */
1310 match
1311 gfc_match_literal_constant (gfc_expr **result, int signflag)
1313 match m;
1315 m = match_complex_constant (result);
1316 if (m != MATCH_NO)
1317 return m;
1319 m = match_string_constant (result);
1320 if (m != MATCH_NO)
1321 return m;
1323 m = match_boz_constant (result);
1324 if (m != MATCH_NO)
1325 return m;
1327 m = match_real_constant (result, signflag);
1328 if (m != MATCH_NO)
1329 return m;
1331 m = match_hollerith_constant (result);
1332 if (m != MATCH_NO)
1333 return m;
1335 m = match_integer_constant (result, signflag);
1336 if (m != MATCH_NO)
1337 return m;
1339 m = match_logical_constant (result);
1340 if (m != MATCH_NO)
1341 return m;
1343 return MATCH_NO;
1347 /* Match a single actual argument value. An actual argument is
1348 usually an expression, but can also be a procedure name. If the
1349 argument is a single name, it is not always possible to tell
1350 whether the name is a dummy procedure or not. We treat these cases
1351 by creating an argument that looks like a dummy procedure and
1352 fixing things later during resolution. */
1354 static match
1355 match_actual_arg (gfc_expr **result)
1357 char name[GFC_MAX_SYMBOL_LEN + 1];
1358 gfc_symtree *symtree;
1359 locus where, w;
1360 gfc_expr *e;
1361 char c;
1363 where = gfc_current_locus;
1365 switch (gfc_match_name (name))
1367 case MATCH_ERROR:
1368 return MATCH_ERROR;
1370 case MATCH_NO:
1371 break;
1373 case MATCH_YES:
1374 w = gfc_current_locus;
1375 gfc_gobble_whitespace ();
1376 c = gfc_next_ascii_char ();
1377 gfc_current_locus = w;
1379 if (c != ',' && c != ')')
1380 break;
1382 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1383 break;
1384 /* Handle error elsewhere. */
1386 /* Eliminate a couple of common cases where we know we don't
1387 have a function argument. */
1388 if (symtree == NULL)
1390 gfc_get_sym_tree (name, NULL, &symtree);
1391 gfc_set_sym_referenced (symtree->n.sym);
1393 else
1395 gfc_symbol *sym;
1397 sym = symtree->n.sym;
1398 gfc_set_sym_referenced (sym);
1399 if (sym->attr.flavor != FL_PROCEDURE
1400 && sym->attr.flavor != FL_UNKNOWN)
1401 break;
1403 /* If the symbol is a function with itself as the result and
1404 is being defined, then we have a variable. */
1405 if (sym->attr.function && sym->result == sym)
1407 if (gfc_current_ns->proc_name == sym
1408 || (gfc_current_ns->parent != NULL
1409 && gfc_current_ns->parent->proc_name == sym))
1410 break;
1412 if (sym->attr.entry
1413 && (sym->ns == gfc_current_ns
1414 || sym->ns == gfc_current_ns->parent))
1416 gfc_entry_list *el = NULL;
1418 for (el = sym->ns->entries; el; el = el->next)
1419 if (sym == el->sym)
1420 break;
1422 if (el)
1423 break;
1428 e = gfc_get_expr (); /* Leave it unknown for now */
1429 e->symtree = symtree;
1430 e->expr_type = EXPR_VARIABLE;
1431 e->ts.type = BT_PROCEDURE;
1432 e->where = where;
1434 *result = e;
1435 return MATCH_YES;
1438 gfc_current_locus = where;
1439 return gfc_match_expr (result);
1443 /* Match a keyword argument. */
1445 static match
1446 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1448 char name[GFC_MAX_SYMBOL_LEN + 1];
1449 gfc_actual_arglist *a;
1450 locus name_locus;
1451 match m;
1453 name_locus = gfc_current_locus;
1454 m = gfc_match_name (name);
1456 if (m != MATCH_YES)
1457 goto cleanup;
1458 if (gfc_match_char ('=') != MATCH_YES)
1460 m = MATCH_NO;
1461 goto cleanup;
1464 m = match_actual_arg (&actual->expr);
1465 if (m != MATCH_YES)
1466 goto cleanup;
1468 /* Make sure this name has not appeared yet. */
1470 if (name[0] != '\0')
1472 for (a = base; a; a = a->next)
1473 if (a->name != NULL && strcmp (a->name, name) == 0)
1475 gfc_error ("Keyword '%s' at %C has already appeared in the "
1476 "current argument list", name);
1477 return MATCH_ERROR;
1481 actual->name = gfc_get_string (name);
1482 return MATCH_YES;
1484 cleanup:
1485 gfc_current_locus = name_locus;
1486 return m;
1490 /* Match an argument list function, such as %VAL. */
1492 static match
1493 match_arg_list_function (gfc_actual_arglist *result)
1495 char name[GFC_MAX_SYMBOL_LEN + 1];
1496 locus old_locus;
1497 match m;
1499 old_locus = gfc_current_locus;
1501 if (gfc_match_char ('%') != MATCH_YES)
1503 m = MATCH_NO;
1504 goto cleanup;
1507 m = gfc_match ("%n (", name);
1508 if (m != MATCH_YES)
1509 goto cleanup;
1511 if (name[0] != '\0')
1513 switch (name[0])
1515 case 'l':
1516 if (strncmp (name, "loc", 3) == 0)
1518 result->name = "%LOC";
1519 break;
1521 case 'r':
1522 if (strncmp (name, "ref", 3) == 0)
1524 result->name = "%REF";
1525 break;
1527 case 'v':
1528 if (strncmp (name, "val", 3) == 0)
1530 result->name = "%VAL";
1531 break;
1533 default:
1534 m = MATCH_ERROR;
1535 goto cleanup;
1539 if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1540 "function at %C") == FAILURE)
1542 m = MATCH_ERROR;
1543 goto cleanup;
1546 m = match_actual_arg (&result->expr);
1547 if (m != MATCH_YES)
1548 goto cleanup;
1550 if (gfc_match_char (')') != MATCH_YES)
1552 m = MATCH_NO;
1553 goto cleanup;
1556 return MATCH_YES;
1558 cleanup:
1559 gfc_current_locus = old_locus;
1560 return m;
1564 /* Matches an actual argument list of a function or subroutine, from
1565 the opening parenthesis to the closing parenthesis. The argument
1566 list is assumed to allow keyword arguments because we don't know if
1567 the symbol associated with the procedure has an implicit interface
1568 or not. We make sure keywords are unique. If sub_flag is set,
1569 we're matching the argument list of a subroutine. */
1571 match
1572 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1574 gfc_actual_arglist *head, *tail;
1575 int seen_keyword;
1576 gfc_st_label *label;
1577 locus old_loc;
1578 match m;
1580 *argp = tail = NULL;
1581 old_loc = gfc_current_locus;
1583 seen_keyword = 0;
1585 if (gfc_match_char ('(') == MATCH_NO)
1586 return (sub_flag) ? MATCH_YES : MATCH_NO;
1588 if (gfc_match_char (')') == MATCH_YES)
1589 return MATCH_YES;
1590 head = NULL;
1592 for (;;)
1594 if (head == NULL)
1595 head = tail = gfc_get_actual_arglist ();
1596 else
1598 tail->next = gfc_get_actual_arglist ();
1599 tail = tail->next;
1602 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1604 m = gfc_match_st_label (&label);
1605 if (m == MATCH_NO)
1606 gfc_error ("Expected alternate return label at %C");
1607 if (m != MATCH_YES)
1608 goto cleanup;
1610 tail->label = label;
1611 goto next;
1614 /* After the first keyword argument is seen, the following
1615 arguments must also have keywords. */
1616 if (seen_keyword)
1618 m = match_keyword_arg (tail, head);
1620 if (m == MATCH_ERROR)
1621 goto cleanup;
1622 if (m == MATCH_NO)
1624 gfc_error ("Missing keyword name in actual argument list at %C");
1625 goto cleanup;
1629 else
1631 /* Try an argument list function, like %VAL. */
1632 m = match_arg_list_function (tail);
1633 if (m == MATCH_ERROR)
1634 goto cleanup;
1636 /* See if we have the first keyword argument. */
1637 if (m == MATCH_NO)
1639 m = match_keyword_arg (tail, head);
1640 if (m == MATCH_YES)
1641 seen_keyword = 1;
1642 if (m == MATCH_ERROR)
1643 goto cleanup;
1646 if (m == MATCH_NO)
1648 /* Try for a non-keyword argument. */
1649 m = match_actual_arg (&tail->expr);
1650 if (m == MATCH_ERROR)
1651 goto cleanup;
1652 if (m == MATCH_NO)
1653 goto syntax;
1658 next:
1659 if (gfc_match_char (')') == MATCH_YES)
1660 break;
1661 if (gfc_match_char (',') != MATCH_YES)
1662 goto syntax;
1665 *argp = head;
1666 return MATCH_YES;
1668 syntax:
1669 gfc_error ("Syntax error in argument list at %C");
1671 cleanup:
1672 gfc_free_actual_arglist (head);
1673 gfc_current_locus = old_loc;
1675 return MATCH_ERROR;
1679 /* Used by match_varspec() to extend the reference list by one
1680 element. */
1682 static gfc_ref *
1683 extend_ref (gfc_expr *primary, gfc_ref *tail)
1685 if (primary->ref == NULL)
1686 primary->ref = tail = gfc_get_ref ();
1687 else
1689 if (tail == NULL)
1690 gfc_internal_error ("extend_ref(): Bad tail");
1691 tail->next = gfc_get_ref ();
1692 tail = tail->next;
1695 return tail;
1699 /* Match any additional specifications associated with the current
1700 variable like member references or substrings. If equiv_flag is
1701 set we only match stuff that is allowed inside an EQUIVALENCE
1702 statement. */
1704 static match
1705 match_varspec (gfc_expr *primary, int equiv_flag)
1707 char name[GFC_MAX_SYMBOL_LEN + 1];
1708 gfc_ref *substring, *tail;
1709 gfc_component *component;
1710 gfc_symbol *sym = primary->symtree->n.sym;
1711 match m;
1712 bool unknown;
1714 tail = NULL;
1716 gfc_gobble_whitespace ();
1717 if ((equiv_flag && gfc_peek_ascii_char () == '(') || sym->attr.dimension)
1719 /* In EQUIVALENCE, we don't know yet whether we are seeing
1720 an array, character variable or array of character
1721 variables. We'll leave the decision till resolve time. */
1722 tail = extend_ref (primary, tail);
1723 tail->type = REF_ARRAY;
1725 m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1726 equiv_flag);
1727 if (m != MATCH_YES)
1728 return m;
1730 gfc_gobble_whitespace ();
1731 if (equiv_flag && gfc_peek_ascii_char () == '(')
1733 tail = extend_ref (primary, tail);
1734 tail->type = REF_ARRAY;
1736 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1737 if (m != MATCH_YES)
1738 return m;
1742 primary->ts = sym->ts;
1744 if (equiv_flag)
1745 return MATCH_YES;
1747 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1748 goto check_substring;
1750 sym = sym->ts.derived;
1752 for (;;)
1754 m = gfc_match_name (name);
1755 if (m == MATCH_NO)
1756 gfc_error ("Expected structure component name at %C");
1757 if (m != MATCH_YES)
1758 return MATCH_ERROR;
1760 component = gfc_find_component (sym, name);
1761 if (component == NULL)
1762 return MATCH_ERROR;
1764 tail = extend_ref (primary, tail);
1765 tail->type = REF_COMPONENT;
1767 tail->u.c.component = component;
1768 tail->u.c.sym = sym;
1770 primary->ts = component->ts;
1772 if (component->as != NULL)
1774 tail = extend_ref (primary, tail);
1775 tail->type = REF_ARRAY;
1777 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1778 if (m != MATCH_YES)
1779 return m;
1782 if (component->ts.type != BT_DERIVED
1783 || gfc_match_char ('%') != MATCH_YES)
1784 break;
1786 sym = component->ts.derived;
1789 check_substring:
1790 unknown = false;
1791 if (primary->ts.type == BT_UNKNOWN)
1793 if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1795 gfc_set_default_type (sym, 0, sym->ns);
1796 primary->ts = sym->ts;
1797 unknown = true;
1801 if (primary->ts.type == BT_CHARACTER)
1803 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1805 case MATCH_YES:
1806 if (tail == NULL)
1807 primary->ref = substring;
1808 else
1809 tail->next = substring;
1811 if (primary->expr_type == EXPR_CONSTANT)
1812 primary->expr_type = EXPR_SUBSTRING;
1814 if (substring)
1815 primary->ts.cl = NULL;
1817 break;
1819 case MATCH_NO:
1820 if (unknown)
1821 gfc_clear_ts (&primary->ts);
1822 break;
1824 case MATCH_ERROR:
1825 return MATCH_ERROR;
1829 return MATCH_YES;
1833 /* Given an expression that is a variable, figure out what the
1834 ultimate variable's type and attribute is, traversing the reference
1835 structures if necessary.
1837 This subroutine is trickier than it looks. We start at the base
1838 symbol and store the attribute. Component references load a
1839 completely new attribute.
1841 A couple of rules come into play. Subobjects of targets are always
1842 targets themselves. If we see a component that goes through a
1843 pointer, then the expression must also be a target, since the
1844 pointer is associated with something (if it isn't core will soon be
1845 dumped). If we see a full part or section of an array, the
1846 expression is also an array.
1848 We can have at most one full array reference. */
1850 symbol_attribute
1851 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1853 int dimension, pointer, allocatable, target;
1854 symbol_attribute attr;
1855 gfc_ref *ref;
1857 if (expr->expr_type != EXPR_VARIABLE)
1858 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1860 ref = expr->ref;
1861 attr = expr->symtree->n.sym->attr;
1863 dimension = attr.dimension;
1864 pointer = attr.pointer;
1865 allocatable = attr.allocatable;
1867 target = attr.target;
1868 if (pointer)
1869 target = 1;
1871 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1872 *ts = expr->symtree->n.sym->ts;
1874 for (; ref; ref = ref->next)
1875 switch (ref->type)
1877 case REF_ARRAY:
1879 switch (ref->u.ar.type)
1881 case AR_FULL:
1882 dimension = 1;
1883 break;
1885 case AR_SECTION:
1886 allocatable = pointer = 0;
1887 dimension = 1;
1888 break;
1890 case AR_ELEMENT:
1891 allocatable = pointer = 0;
1892 break;
1894 case AR_UNKNOWN:
1895 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1898 break;
1900 case REF_COMPONENT:
1901 gfc_get_component_attr (&attr, ref->u.c.component);
1902 if (ts != NULL)
1904 *ts = ref->u.c.component->ts;
1905 /* Don't set the string length if a substring reference
1906 follows. */
1907 if (ts->type == BT_CHARACTER
1908 && ref->next && ref->next->type == REF_SUBSTRING)
1909 ts->cl = NULL;
1912 pointer = ref->u.c.component->pointer;
1913 allocatable = ref->u.c.component->allocatable;
1914 if (pointer)
1915 target = 1;
1917 break;
1919 case REF_SUBSTRING:
1920 allocatable = pointer = 0;
1921 break;
1924 attr.dimension = dimension;
1925 attr.pointer = pointer;
1926 attr.allocatable = allocatable;
1927 attr.target = target;
1929 return attr;
1933 /* Return the attribute from a general expression. */
1935 symbol_attribute
1936 gfc_expr_attr (gfc_expr *e)
1938 symbol_attribute attr;
1940 switch (e->expr_type)
1942 case EXPR_VARIABLE:
1943 attr = gfc_variable_attr (e, NULL);
1944 break;
1946 case EXPR_FUNCTION:
1947 gfc_clear_attr (&attr);
1949 if (e->value.function.esym != NULL)
1950 attr = e->value.function.esym->result->attr;
1952 /* TODO: NULL() returns pointers. May have to take care of this
1953 here. */
1955 break;
1957 default:
1958 gfc_clear_attr (&attr);
1959 break;
1962 return attr;
1966 /* Match a structure constructor. The initial symbol has already been
1967 seen. */
1969 typedef struct gfc_structure_ctor_component
1971 char* name;
1972 gfc_expr* val;
1973 locus where;
1974 struct gfc_structure_ctor_component* next;
1976 gfc_structure_ctor_component;
1978 #define gfc_get_structure_ctor_component() \
1979 gfc_getmem(sizeof(gfc_structure_ctor_component))
1981 static void
1982 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
1984 gfc_free (comp->name);
1985 gfc_free_expr (comp->val);
1988 match
1989 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
1991 gfc_structure_ctor_component *comp_head, *comp_tail;
1992 gfc_structure_ctor_component *comp_iter;
1993 gfc_constructor *ctor_head, *ctor_tail;
1994 gfc_component *comp; /* Is set NULL when named component is first seen */
1995 gfc_expr *e;
1996 locus where;
1997 match m;
1998 const char* last_name = NULL;
2000 comp_head = comp_tail = NULL;
2001 ctor_head = ctor_tail = NULL;
2003 if (gfc_match_char ('(') != MATCH_YES)
2004 goto syntax;
2006 where = gfc_current_locus;
2008 gfc_find_component (sym, NULL);
2010 /* Match the component list and store it in a list together with the
2011 corresponding component names. Check for empty argument list first. */
2012 if (gfc_match_char (')') != MATCH_YES)
2014 comp = sym->components;
2017 gfc_component *this_comp = NULL;
2019 if (!comp_head)
2020 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2021 else
2023 comp_tail->next = gfc_get_structure_ctor_component ();
2024 comp_tail = comp_tail->next;
2026 comp_tail->name = gfc_getmem(GFC_MAX_SYMBOL_LEN + 1);
2027 comp_tail->val = NULL;
2028 comp_tail->where = gfc_current_locus;
2030 /* Try matching a component name. */
2031 if (gfc_match_name (comp_tail->name) == MATCH_YES
2032 && gfc_match_char ('=') == MATCH_YES)
2034 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2035 " constructor with named arguments at %C")
2036 == FAILURE)
2037 goto cleanup;
2039 last_name = comp_tail->name;
2040 comp = NULL;
2042 else
2044 /* Components without name are not allowed after the first named
2045 component initializer! */
2046 if (!comp)
2048 if (last_name)
2049 gfc_error ("Component initializer without name after"
2050 " component named %s at %C!", last_name);
2051 else
2052 gfc_error ("Too many components in structure constructor at"
2053 " %C!");
2054 goto cleanup;
2057 gfc_current_locus = comp_tail->where;
2058 strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2061 /* Find the current component in the structure definition; this is
2062 needed to get its access attribute in the private check below. */
2063 if (comp)
2064 this_comp = comp;
2065 else
2067 for (comp = sym->components; comp; comp = comp->next)
2068 if (!strcmp (comp->name, comp_tail->name))
2070 this_comp = comp;
2071 break;
2073 comp = NULL; /* Reset needed! */
2075 /* Here we can check if a component name is given which does not
2076 correspond to any component of the defined structure. */
2077 if (!this_comp)
2079 gfc_error ("Component '%s' in structure constructor at %C"
2080 " does not correspond to any component in the"
2081 " constructed structure!", comp_tail->name);
2082 goto cleanup;
2085 gcc_assert (this_comp);
2087 /* Check the current component's access status. */
2088 if (sym->attr.use_assoc && this_comp->access == ACCESS_PRIVATE)
2090 gfc_error ("Component '%s' is PRIVATE in structure constructor"
2091 " at %C!", comp_tail->name);
2092 goto cleanup;
2095 /* Check if this component is already given a value. */
2096 for (comp_iter = comp_head; comp_iter != comp_tail;
2097 comp_iter = comp_iter->next)
2099 gcc_assert (comp_iter);
2100 if (!strcmp (comp_iter->name, comp_tail->name))
2102 gfc_error ("Component '%s' is initialized twice in the"
2103 " structure constructor at %C!", comp_tail->name);
2104 goto cleanup;
2108 /* Match the current initializer expression. */
2109 m = gfc_match_expr (&comp_tail->val);
2110 if (m == MATCH_NO)
2111 goto syntax;
2112 if (m == MATCH_ERROR)
2113 goto cleanup;
2115 if (comp)
2116 comp = comp->next;
2118 while (gfc_match_char (',') == MATCH_YES);
2120 if (gfc_match_char (')') != MATCH_YES)
2121 goto syntax;
2123 /* If there were components given and all components are private, error
2124 out at this place. */
2125 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2127 gfc_error ("All components of '%s' are PRIVATE in structure"
2128 " constructor at %C", sym->name);
2129 goto cleanup;
2133 /* Translate the component list into the actual constructor by sorting it in
2134 the order required; this also checks along the way that each and every
2135 component actually has an initializer and handles default initializers
2136 for components without explicit value given. */
2137 for (comp = sym->components; comp; comp = comp->next)
2139 gfc_structure_ctor_component **next_ptr;
2140 gfc_expr *value = NULL;
2142 /* Try to find the initializer for the current component by name. */
2143 next_ptr = &comp_head;
2144 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2146 if (!strcmp (comp_iter->name, comp->name))
2147 break;
2148 next_ptr = &comp_iter->next;
2151 /* If it was not found, try the default initializer if there's any;
2152 otherwise, it's an error. */
2153 if (!comp_iter)
2155 if (comp->initializer)
2157 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2158 " constructor with missing optional arguments"
2159 " at %C") == FAILURE)
2160 goto cleanup;
2161 value = gfc_copy_expr (comp->initializer);
2163 else
2165 gfc_error ("No initializer for component '%s' given in the"
2166 " structure constructor at %C!", comp->name);
2167 goto cleanup;
2170 else
2171 value = comp_iter->val;
2173 /* Add the value to the constructor chain built. */
2174 if (ctor_tail)
2176 ctor_tail->next = gfc_get_constructor ();
2177 ctor_tail = ctor_tail->next;
2179 else
2180 ctor_head = ctor_tail = gfc_get_constructor ();
2181 gcc_assert (value);
2182 ctor_tail->expr = value;
2184 /* Remove the entry from the component list. We don't want the expression
2185 value to be free'd, so set it to NULL. */
2186 if (comp_iter)
2188 *next_ptr = comp_iter->next;
2189 comp_iter->val = NULL;
2190 gfc_free_structure_ctor_component (comp_iter);
2194 /* No component should be left, as this should have caused an error in the
2195 loop constructing the component-list (name that does not correspond to any
2196 component in the structure definition). */
2197 gcc_assert (!comp_head);
2199 e = gfc_get_expr ();
2201 e->expr_type = EXPR_STRUCTURE;
2203 e->ts.type = BT_DERIVED;
2204 e->ts.derived = sym;
2205 e->where = where;
2207 e->value.constructor = ctor_head;
2209 *result = e;
2210 return MATCH_YES;
2212 syntax:
2213 gfc_error ("Syntax error in structure constructor at %C");
2215 cleanup:
2216 for (comp_iter = comp_head; comp_iter; )
2218 gfc_structure_ctor_component *next = comp_iter->next;
2219 gfc_free_structure_ctor_component (comp_iter);
2220 comp_iter = next;
2222 gfc_free_constructor (ctor_head);
2223 return MATCH_ERROR;
2227 /* If the symbol is an implicit do loop index and implicitly typed,
2228 it should not be host associated. Provide a symtree from the
2229 current namespace. */
2230 static match
2231 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2233 if ((*sym)->attr.flavor == FL_VARIABLE
2234 && (*sym)->ns != gfc_current_ns
2235 && (*sym)->attr.implied_index
2236 && (*sym)->attr.implicit_type
2237 && !(*sym)->attr.use_assoc)
2239 int i;
2240 i = gfc_get_sym_tree ((*sym)->name, NULL, st);
2241 if (i)
2242 return MATCH_ERROR;
2243 *sym = (*st)->n.sym;
2245 return MATCH_YES;
2249 /* Matches a variable name followed by anything that might follow it--
2250 array reference, argument list of a function, etc. */
2252 match
2253 gfc_match_rvalue (gfc_expr **result)
2255 gfc_actual_arglist *actual_arglist;
2256 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2257 gfc_state_data *st;
2258 gfc_symbol *sym;
2259 gfc_symtree *symtree;
2260 locus where, old_loc;
2261 gfc_expr *e;
2262 match m, m2;
2263 int i;
2264 gfc_typespec *ts;
2265 bool implicit_char;
2266 gfc_ref *ref;
2268 m = gfc_match_name (name);
2269 if (m != MATCH_YES)
2270 return m;
2272 if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2273 && !gfc_current_ns->has_import_set)
2274 i = gfc_get_sym_tree (name, NULL, &symtree);
2275 else
2276 i = gfc_get_ha_sym_tree (name, &symtree);
2278 if (i)
2279 return MATCH_ERROR;
2281 sym = symtree->n.sym;
2282 e = NULL;
2283 where = gfc_current_locus;
2285 /* If this is an implicit do loop index and implicitly typed,
2286 it should not be host associated. */
2287 m = check_for_implicit_index (&symtree, &sym);
2288 if (m != MATCH_YES)
2289 return m;
2291 gfc_set_sym_referenced (sym);
2292 sym->attr.implied_index = 0;
2294 if (sym->attr.function && sym->result == sym)
2296 /* See if this is a directly recursive function call. */
2297 gfc_gobble_whitespace ();
2298 if (sym->attr.recursive
2299 && gfc_peek_ascii_char () == '('
2300 && gfc_current_ns->proc_name == sym
2301 && !sym->attr.dimension)
2303 gfc_error ("'%s' at %C is the name of a recursive function "
2304 "and so refers to the result variable. Use an "
2305 "explicit RESULT variable for direct recursion "
2306 "(12.5.2.1)", sym->name);
2307 return MATCH_ERROR;
2310 if (gfc_current_ns->proc_name == sym
2311 || (gfc_current_ns->parent != NULL
2312 && gfc_current_ns->parent->proc_name == sym))
2313 goto variable;
2315 if (sym->attr.entry
2316 && (sym->ns == gfc_current_ns
2317 || sym->ns == gfc_current_ns->parent))
2319 gfc_entry_list *el = NULL;
2321 for (el = sym->ns->entries; el; el = el->next)
2322 if (sym == el->sym)
2323 goto variable;
2327 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2328 goto function0;
2330 if (sym->attr.generic)
2331 goto generic_function;
2333 switch (sym->attr.flavor)
2335 case FL_VARIABLE:
2336 variable:
2337 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
2338 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2339 gfc_set_default_type (sym, 0, sym->ns);
2341 e = gfc_get_expr ();
2343 e->expr_type = EXPR_VARIABLE;
2344 e->symtree = symtree;
2346 m = match_varspec (e, 0);
2347 break;
2349 case FL_PARAMETER:
2350 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2351 end up here. Unfortunately, sym->value->expr_type is set to
2352 EXPR_CONSTANT, and so the if () branch would be followed without
2353 the !sym->as check. */
2354 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2355 e = gfc_copy_expr (sym->value);
2356 else
2358 e = gfc_get_expr ();
2359 e->expr_type = EXPR_VARIABLE;
2362 e->symtree = symtree;
2363 m = match_varspec (e, 0);
2365 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2366 break;
2368 /* Variable array references to derived type parameters cause
2369 all sorts of headaches in simplification. Treating such
2370 expressions as variable works just fine for all array
2371 references. */
2372 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2374 for (ref = e->ref; ref; ref = ref->next)
2375 if (ref->type == REF_ARRAY)
2376 break;
2378 if (ref == NULL || ref->u.ar.type == AR_FULL)
2379 break;
2381 ref = e->ref;
2382 e->ref = NULL;
2383 gfc_free_expr (e);
2384 e = gfc_get_expr ();
2385 e->expr_type = EXPR_VARIABLE;
2386 e->symtree = symtree;
2387 e->ref = ref;
2390 break;
2392 case FL_DERIVED:
2393 sym = gfc_use_derived (sym);
2394 if (sym == NULL)
2395 m = MATCH_ERROR;
2396 else
2397 m = gfc_match_structure_constructor (sym, &e);
2398 break;
2400 /* If we're here, then the name is known to be the name of a
2401 procedure, yet it is not sure to be the name of a function. */
2402 case FL_PROCEDURE:
2403 if (sym->attr.subroutine)
2405 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2406 sym->name);
2407 m = MATCH_ERROR;
2408 break;
2411 /* At this point, the name has to be a non-statement function.
2412 If the name is the same as the current function being
2413 compiled, then we have a variable reference (to the function
2414 result) if the name is non-recursive. */
2416 st = gfc_enclosing_unit (NULL);
2418 if (st != NULL && st->state == COMP_FUNCTION
2419 && st->sym == sym
2420 && !sym->attr.recursive)
2422 e = gfc_get_expr ();
2423 e->symtree = symtree;
2424 e->expr_type = EXPR_VARIABLE;
2426 m = match_varspec (e, 0);
2427 break;
2430 /* Match a function reference. */
2431 function0:
2432 m = gfc_match_actual_arglist (0, &actual_arglist);
2433 if (m == MATCH_NO)
2435 if (sym->attr.proc == PROC_ST_FUNCTION)
2436 gfc_error ("Statement function '%s' requires argument list at %C",
2437 sym->name);
2438 else
2439 gfc_error ("Function '%s' requires an argument list at %C",
2440 sym->name);
2442 m = MATCH_ERROR;
2443 break;
2446 if (m != MATCH_YES)
2448 m = MATCH_ERROR;
2449 break;
2452 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2453 sym = symtree->n.sym;
2455 e = gfc_get_expr ();
2456 e->symtree = symtree;
2457 e->expr_type = EXPR_FUNCTION;
2458 e->value.function.actual = actual_arglist;
2459 e->where = gfc_current_locus;
2461 if (sym->as != NULL)
2462 e->rank = sym->as->rank;
2464 if (!sym->attr.function
2465 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2467 m = MATCH_ERROR;
2468 break;
2471 /* Check here for the existence of at least one argument for the
2472 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2473 argument(s) given will be checked in gfc_iso_c_func_interface,
2474 during resolution of the function call. */
2475 if (sym->attr.is_iso_c == 1
2476 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2477 && (sym->intmod_sym_id == ISOCBINDING_LOC
2478 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2479 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2481 /* make sure we were given a param */
2482 if (actual_arglist == NULL)
2484 gfc_error ("Missing argument to '%s' at %C", sym->name);
2485 m = MATCH_ERROR;
2486 break;
2490 if (sym->result == NULL)
2491 sym->result = sym;
2493 m = MATCH_YES;
2494 break;
2496 case FL_UNKNOWN:
2498 /* Special case for derived type variables that get their types
2499 via an IMPLICIT statement. This can't wait for the
2500 resolution phase. */
2502 if (gfc_peek_ascii_char () == '%'
2503 && sym->ts.type == BT_UNKNOWN
2504 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2505 gfc_set_default_type (sym, 0, sym->ns);
2507 /* If the symbol has a dimension attribute, the expression is a
2508 variable. */
2510 if (sym->attr.dimension)
2512 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2513 sym->name, NULL) == FAILURE)
2515 m = MATCH_ERROR;
2516 break;
2519 e = gfc_get_expr ();
2520 e->symtree = symtree;
2521 e->expr_type = EXPR_VARIABLE;
2522 m = match_varspec (e, 0);
2523 break;
2526 /* Name is not an array, so we peek to see if a '(' implies a
2527 function call or a substring reference. Otherwise the
2528 variable is just a scalar. */
2530 gfc_gobble_whitespace ();
2531 if (gfc_peek_ascii_char () != '(')
2533 /* Assume a scalar variable */
2534 e = gfc_get_expr ();
2535 e->symtree = symtree;
2536 e->expr_type = EXPR_VARIABLE;
2538 if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2539 sym->name, NULL) == FAILURE)
2541 m = MATCH_ERROR;
2542 break;
2545 /*FIXME:??? match_varspec does set this for us: */
2546 e->ts = sym->ts;
2547 m = match_varspec (e, 0);
2548 break;
2551 /* See if this is a function reference with a keyword argument
2552 as first argument. We do this because otherwise a spurious
2553 symbol would end up in the symbol table. */
2555 old_loc = gfc_current_locus;
2556 m2 = gfc_match (" ( %n =", argname);
2557 gfc_current_locus = old_loc;
2559 e = gfc_get_expr ();
2560 e->symtree = symtree;
2562 if (m2 != MATCH_YES)
2564 /* Try to figure out whether we're dealing with a character type.
2565 We're peeking ahead here, because we don't want to call
2566 match_substring if we're dealing with an implicitly typed
2567 non-character variable. */
2568 implicit_char = false;
2569 if (sym->ts.type == BT_UNKNOWN)
2571 ts = gfc_get_default_type (sym,NULL);
2572 if (ts->type == BT_CHARACTER)
2573 implicit_char = true;
2576 /* See if this could possibly be a substring reference of a name
2577 that we're not sure is a variable yet. */
2579 if ((implicit_char || sym->ts.type == BT_CHARACTER)
2580 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2583 e->expr_type = EXPR_VARIABLE;
2585 if (sym->attr.flavor != FL_VARIABLE
2586 && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2587 sym->name, NULL) == FAILURE)
2589 m = MATCH_ERROR;
2590 break;
2593 if (sym->ts.type == BT_UNKNOWN
2594 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2596 m = MATCH_ERROR;
2597 break;
2600 e->ts = sym->ts;
2601 if (e->ref)
2602 e->ts.cl = NULL;
2603 m = MATCH_YES;
2604 break;
2608 /* Give up, assume we have a function. */
2610 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2611 sym = symtree->n.sym;
2612 e->expr_type = EXPR_FUNCTION;
2614 if (!sym->attr.function
2615 && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2617 m = MATCH_ERROR;
2618 break;
2621 sym->result = sym;
2623 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2624 if (m == MATCH_NO)
2625 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2627 if (m != MATCH_YES)
2629 m = MATCH_ERROR;
2630 break;
2633 /* If our new function returns a character, array or structure
2634 type, it might have subsequent references. */
2636 m = match_varspec (e, 0);
2637 if (m == MATCH_NO)
2638 m = MATCH_YES;
2640 break;
2642 generic_function:
2643 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2645 e = gfc_get_expr ();
2646 e->symtree = symtree;
2647 e->expr_type = EXPR_FUNCTION;
2649 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2650 break;
2652 default:
2653 gfc_error ("Symbol at %C is not appropriate for an expression");
2654 return MATCH_ERROR;
2657 if (m == MATCH_YES)
2659 e->where = where;
2660 *result = e;
2662 else
2663 gfc_free_expr (e);
2665 return m;
2669 /* Match a variable, ie something that can be assigned to. This
2670 starts as a symbol, can be a structure component or an array
2671 reference. It can be a function if the function doesn't have a
2672 separate RESULT variable. If the symbol has not been previously
2673 seen, we assume it is a variable.
2675 This function is called by two interface functions:
2676 gfc_match_variable, which has host_flag = 1, and
2677 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2678 match of the symbol to the local scope. */
2680 static match
2681 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2683 gfc_symbol *sym;
2684 gfc_symtree *st;
2685 gfc_expr *expr;
2686 locus where;
2687 match m;
2689 /* Since nothing has any business being an lvalue in a module
2690 specification block, an interface block or a contains section,
2691 we force the changed_symbols mechanism to work by setting
2692 host_flag to 0. This prevents valid symbols that have the name
2693 of keywords, such as 'end', being turned into variables by
2694 failed matching to assignments for, eg., END INTERFACE. */
2695 if (gfc_current_state () == COMP_MODULE
2696 || gfc_current_state () == COMP_INTERFACE
2697 || gfc_current_state () == COMP_CONTAINS)
2698 host_flag = 0;
2700 m = gfc_match_sym_tree (&st, host_flag);
2701 if (m != MATCH_YES)
2702 return m;
2703 where = gfc_current_locus;
2705 sym = st->n.sym;
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 (&st, &sym);
2710 if (m != MATCH_YES)
2711 return m;
2713 sym->attr.implied_index = 0;
2715 gfc_set_sym_referenced (sym);
2716 switch (sym->attr.flavor)
2718 case FL_VARIABLE:
2719 if (sym->attr.protected && sym->attr.use_assoc)
2721 gfc_error ("Assigning to PROTECTED variable at %C");
2722 return MATCH_ERROR;
2724 break;
2726 case FL_UNKNOWN:
2728 sym_flavor flavor = FL_UNKNOWN;
2730 gfc_gobble_whitespace ();
2732 if (sym->attr.external || sym->attr.procedure
2733 || sym->attr.function || sym->attr.subroutine)
2734 flavor = FL_PROCEDURE;
2736 /* If it is not a procedure, is not typed and is host associated,
2737 we cannot give it a flavor yet. */
2738 else if (sym->ns == gfc_current_ns->parent
2739 && sym->ts.type == BT_UNKNOWN)
2740 break;
2742 /* These are definitive indicators that this is a variable. */
2743 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
2744 || sym->attr.pointer || sym->as != NULL)
2745 flavor = FL_VARIABLE;
2747 if (flavor != FL_UNKNOWN
2748 && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
2749 return MATCH_ERROR;
2751 break;
2753 case FL_PARAMETER:
2754 if (equiv_flag)
2755 gfc_error ("Named constant at %C in an EQUIVALENCE");
2756 else
2757 gfc_error ("Cannot assign to a named constant at %C");
2758 return MATCH_ERROR;
2759 break;
2761 case FL_PROCEDURE:
2762 /* Check for a nonrecursive function result variable. */
2763 if (sym->attr.function
2764 && !sym->attr.external
2765 && sym->result == sym
2766 && ((sym == gfc_current_ns->proc_name
2767 && sym == gfc_current_ns->proc_name->result)
2768 || (gfc_current_ns->parent
2769 && sym == gfc_current_ns->parent->proc_name->result)
2770 || (sym->attr.entry
2771 && sym->ns == gfc_current_ns)
2772 || (sym->attr.entry
2773 && sym->ns == gfc_current_ns->parent)))
2775 /* If a function result is a derived type, then the derived
2776 type may still have to be resolved. */
2778 if (sym->ts.type == BT_DERIVED
2779 && gfc_use_derived (sym->ts.derived) == NULL)
2780 return MATCH_ERROR;
2781 break;
2784 /* Fall through to error */
2786 default:
2787 gfc_error ("'%s' at %C is not a variable", sym->name);
2788 return MATCH_ERROR;
2791 /* Special case for derived type variables that get their types
2792 via an IMPLICIT statement. This can't wait for the
2793 resolution phase. */
2796 gfc_namespace * implicit_ns;
2798 if (gfc_current_ns->proc_name == sym)
2799 implicit_ns = gfc_current_ns;
2800 else
2801 implicit_ns = sym->ns;
2803 if (gfc_peek_ascii_char () == '%'
2804 && sym->ts.type == BT_UNKNOWN
2805 && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2806 gfc_set_default_type (sym, 0, implicit_ns);
2809 expr = gfc_get_expr ();
2811 expr->expr_type = EXPR_VARIABLE;
2812 expr->symtree = st;
2813 expr->ts = sym->ts;
2814 expr->where = where;
2816 /* Now see if we have to do more. */
2817 m = match_varspec (expr, equiv_flag);
2818 if (m != MATCH_YES)
2820 gfc_free_expr (expr);
2821 return m;
2824 *result = expr;
2825 return MATCH_YES;
2829 match
2830 gfc_match_variable (gfc_expr **result, int equiv_flag)
2832 return match_variable (result, equiv_flag, 1);
2836 match
2837 gfc_match_equiv_variable (gfc_expr **result)
2839 return match_variable (result, 1, 0);