2013-12-29 Janus Weil <janus@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / primary.c
blob089ed429310c1bbcfe2c9966a081e7c561a5f6d8
1 /* Primary expression subroutines
2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "flags.h"
25 #include "gfortran.h"
26 #include "arith.h"
27 #include "match.h"
28 #include "parse.h"
29 #include "constructor.h"
31 int matching_actual_arglist = 0;
33 /* Matches a kind-parameter expression, which is either a named
34 symbolic constant or a nonnegative integer constant. If
35 successful, sets the kind value to the correct integer.
36 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
37 symbol like e.g. 'c_int'. */
39 static match
40 match_kind_param (int *kind, int *is_iso_c)
42 char name[GFC_MAX_SYMBOL_LEN + 1];
43 gfc_symbol *sym;
44 const char *p;
45 match m;
47 *is_iso_c = 0;
49 m = gfc_match_small_literal_int (kind, NULL);
50 if (m != MATCH_NO)
51 return m;
53 m = gfc_match_name (name);
54 if (m != MATCH_YES)
55 return m;
57 if (gfc_find_symbol (name, NULL, 1, &sym))
58 return MATCH_ERROR;
60 if (sym == NULL)
61 return MATCH_NO;
63 *is_iso_c = sym->attr.is_iso_c;
65 if (sym->attr.flavor != FL_PARAMETER)
66 return MATCH_NO;
68 if (sym->value == NULL)
69 return MATCH_NO;
71 p = gfc_extract_int (sym->value, kind);
72 if (p != NULL)
73 return MATCH_NO;
75 gfc_set_sym_referenced (sym);
77 if (*kind < 0)
78 return MATCH_NO;
80 return MATCH_YES;
84 /* Get a trailing kind-specification for non-character variables.
85 Returns:
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'. */
92 static int
93 get_kind (int *is_iso_c)
95 int kind;
96 match m;
98 *is_iso_c = 0;
100 if (gfc_match_char ('_') != MATCH_YES)
101 return -2;
103 m = match_kind_param (&kind, is_iso_c);
104 if (m == MATCH_NO)
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)
117 int r;
119 switch (radix)
121 case 2:
122 r = ('0' <= c && c <= '1');
123 break;
125 case 8:
126 r = ('0' <= c && c <= '7');
127 break;
129 case 10:
130 r = ('0' <= c && c <= '9');
131 break;
133 case 16:
134 r = ISXDIGIT (c);
135 break;
137 default:
138 gfc_internal_error ("gfc_check_digit(): bad radix");
141 return r;
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. */
150 static int
151 match_digits (int signflag, int radix, char *buffer)
153 locus old_loc;
154 int length;
155 char c;
157 length = 0;
158 c = gfc_next_ascii_char ();
160 if (signflag && (c == '+' || c == '-'))
162 if (buffer != NULL)
163 *buffer++ = c;
164 gfc_gobble_whitespace ();
165 c = gfc_next_ascii_char ();
166 length++;
169 if (!gfc_check_digit (c, radix))
170 return -1;
172 length++;
173 if (buffer != NULL)
174 *buffer++ = c;
176 for (;;)
178 old_loc = gfc_current_locus;
179 c = gfc_next_ascii_char ();
181 if (!gfc_check_digit (c, radix))
182 break;
184 if (buffer != NULL)
185 *buffer++ = c;
186 length++;
189 gfc_current_locus = old_loc;
191 return length;
195 /* Match an integer (digit string and optional kind).
196 A sign will be accepted if signflag is set. */
198 static match
199 match_integer_constant (gfc_expr **result, int signflag)
201 int length, kind, is_iso_c;
202 locus old_loc;
203 char *buffer;
204 gfc_expr *e;
206 old_loc = gfc_current_locus;
207 gfc_gobble_whitespace ();
209 length = match_digits (signflag, 10, NULL);
210 gfc_current_locus = old_loc;
211 if (length == -1)
212 return MATCH_NO;
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);
222 if (kind == -2)
223 kind = gfc_default_integer_kind;
224 if (kind == -1)
225 return MATCH_ERROR;
227 if (kind == 4 && gfc_option.flag_integer4_kind == 8)
228 kind = 8;
230 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
232 gfc_error ("Integer kind %d at %C not available", kind);
233 return MATCH_ERROR;
236 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
237 e->ts.is_c_interop = is_iso_c;
239 if (gfc_range_check (e) != ARITH_OK)
241 gfc_error ("Integer too big for its kind at %C. This check can be "
242 "disabled with the option -fno-range-check");
244 gfc_free_expr (e);
245 return MATCH_ERROR;
248 *result = e;
249 return MATCH_YES;
253 /* Match a Hollerith constant. */
255 static match
256 match_hollerith_constant (gfc_expr **result)
258 locus old_loc;
259 gfc_expr *e = NULL;
260 const char *msg;
261 int num, pad;
262 int i;
264 old_loc = gfc_current_locus;
265 gfc_gobble_whitespace ();
267 if (match_integer_constant (&e, 0) == MATCH_YES
268 && gfc_match_char ('h') == MATCH_YES)
270 if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
271 goto cleanup;
273 msg = gfc_extract_int (e, &num);
274 if (msg != NULL)
276 gfc_error (msg);
277 goto cleanup;
279 if (num == 0)
281 gfc_error ("Invalid Hollerith constant: %L must contain at least "
282 "one character", &old_loc);
283 goto cleanup;
285 if (e->ts.kind != gfc_default_integer_kind)
287 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
288 "should be default", &old_loc);
289 goto cleanup;
291 else
293 gfc_free_expr (e);
294 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
295 &gfc_current_locus);
297 /* Calculate padding needed to fit default integer memory. */
298 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
300 e->representation.string = XCNEWVEC (char, num + pad + 1);
302 for (i = 0; i < num; i++)
304 gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
305 if (! gfc_wide_fits_in_byte (c))
307 gfc_error ("Invalid Hollerith constant at %L contains a "
308 "wide character", &old_loc);
309 goto cleanup;
312 e->representation.string[i] = (unsigned char) c;
315 /* Now pad with blanks and end with a null char. */
316 for (i = 0; i < pad; i++)
317 e->representation.string[num + i] = ' ';
319 e->representation.string[num + i] = '\0';
320 e->representation.length = num + pad;
321 e->ts.u.pad = pad;
323 *result = e;
324 return MATCH_YES;
328 gfc_free_expr (e);
329 gfc_current_locus = old_loc;
330 return MATCH_NO;
332 cleanup:
333 gfc_free_expr (e);
334 return MATCH_ERROR;
338 /* Match a binary, octal or hexadecimal constant that can be found in
339 a DATA statement. The standard permits b'010...', o'73...', and
340 z'a1...' where b, o, and z can be capital letters. This function
341 also accepts postfixed forms of the constants: '01...'b, '73...'o,
342 and 'a1...'z. An additional extension is the use of x for z. */
344 static match
345 match_boz_constant (gfc_expr **result)
347 int radix, length, x_hex, kind;
348 locus old_loc, start_loc;
349 char *buffer, post, delim;
350 gfc_expr *e;
352 start_loc = old_loc = gfc_current_locus;
353 gfc_gobble_whitespace ();
355 x_hex = 0;
356 switch (post = gfc_next_ascii_char ())
358 case 'b':
359 radix = 2;
360 post = 0;
361 break;
362 case 'o':
363 radix = 8;
364 post = 0;
365 break;
366 case 'x':
367 x_hex = 1;
368 /* Fall through. */
369 case 'z':
370 radix = 16;
371 post = 0;
372 break;
373 case '\'':
374 /* Fall through. */
375 case '\"':
376 delim = post;
377 post = 1;
378 radix = 16; /* Set to accept any valid digit string. */
379 break;
380 default:
381 goto backup;
384 /* No whitespace allowed here. */
386 if (post == 0)
387 delim = gfc_next_ascii_char ();
389 if (delim != '\'' && delim != '\"')
390 goto backup;
392 if (x_hex
393 && (!gfc_notify_std(GFC_STD_GNU, "Hexadecimal "
394 "constant at %C uses non-standard syntax")))
395 return MATCH_ERROR;
397 old_loc = gfc_current_locus;
399 length = match_digits (0, radix, NULL);
400 if (length == -1)
402 gfc_error ("Empty set of digits in BOZ constant at %C");
403 return MATCH_ERROR;
406 if (gfc_next_ascii_char () != delim)
408 gfc_error ("Illegal character in BOZ constant at %C");
409 return MATCH_ERROR;
412 if (post == 1)
414 switch (gfc_next_ascii_char ())
416 case 'b':
417 radix = 2;
418 break;
419 case 'o':
420 radix = 8;
421 break;
422 case 'x':
423 /* Fall through. */
424 case 'z':
425 radix = 16;
426 break;
427 default:
428 goto backup;
431 if (!gfc_notify_std (GFC_STD_GNU, "BOZ constant "
432 "at %C uses non-standard postfix syntax"))
433 return MATCH_ERROR;
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. */
443 if (post == 1)
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. */
457 e->is_boz = 1;
459 if (gfc_range_check (e) != ARITH_OK)
461 gfc_error ("Integer too big for integer kind %i at %C", kind);
462 gfc_free_expr (e);
463 return MATCH_ERROR;
466 if (!gfc_in_match_data ()
467 && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
468 "statement at %C")))
469 return MATCH_ERROR;
471 *result = e;
472 return MATCH_YES;
474 backup:
475 gfc_current_locus = start_loc;
476 return MATCH_NO;
480 /* Match a real constant of some sort. Allow a signed constant if signflag
481 is nonzero. */
483 static match
484 match_real_constant (gfc_expr **result, int signflag)
486 int kind, count, seen_dp, seen_digits, is_iso_c;
487 locus old_loc, temp_loc;
488 char *p, *buffer, c, exp_char;
489 gfc_expr *e;
490 bool negate;
492 old_loc = gfc_current_locus;
493 gfc_gobble_whitespace ();
495 e = NULL;
497 count = 0;
498 seen_dp = 0;
499 seen_digits = 0;
500 exp_char = ' ';
501 negate = FALSE;
503 c = gfc_next_ascii_char ();
504 if (signflag && (c == '+' || c == '-'))
506 if (c == '-')
507 negate = TRUE;
509 gfc_gobble_whitespace ();
510 c = gfc_next_ascii_char ();
513 /* Scan significand. */
514 for (;; c = gfc_next_ascii_char (), count++)
516 if (c == '.')
518 if (seen_dp)
519 goto done;
521 /* Check to see if "." goes with a following operator like
522 ".eq.". */
523 temp_loc = gfc_current_locus;
524 c = gfc_next_ascii_char ();
526 if (c == 'e' || c == 'd' || c == 'q')
528 c = gfc_next_ascii_char ();
529 if (c == '.')
530 goto done; /* Operator named .e. or .d. */
533 if (ISALPHA (c))
534 goto done; /* Distinguish 1.e9 from 1.eq.2 */
536 gfc_current_locus = temp_loc;
537 seen_dp = 1;
538 continue;
541 if (ISDIGIT (c))
543 seen_digits = 1;
544 continue;
547 break;
550 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
551 goto done;
552 exp_char = c;
555 if (c == 'q')
557 if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
558 "real-literal-constant at %C"))
559 return MATCH_ERROR;
560 else if (gfc_option.warn_real_q_constant)
561 gfc_warning("Extension: exponent-letter 'q' in real-literal-constant "
562 "at %C");
565 /* Scan exponent. */
566 c = gfc_next_ascii_char ();
567 count++;
569 if (c == '+' || c == '-')
570 { /* optional sign */
571 c = gfc_next_ascii_char ();
572 count++;
575 if (!ISDIGIT (c))
577 gfc_error ("Missing exponent in real number at %C");
578 return MATCH_ERROR;
581 while (ISDIGIT (c))
583 c = gfc_next_ascii_char ();
584 count++;
587 done:
588 /* Check that we have a numeric constant. */
589 if (!seen_digits || (!seen_dp && exp_char == ' '))
591 gfc_current_locus = old_loc;
592 return MATCH_NO;
595 /* Convert the number. */
596 gfc_current_locus = old_loc;
597 gfc_gobble_whitespace ();
599 buffer = (char *) alloca (count + 1);
600 memset (buffer, '\0', count + 1);
602 p = buffer;
603 c = gfc_next_ascii_char ();
604 if (c == '+' || c == '-')
606 gfc_gobble_whitespace ();
607 c = gfc_next_ascii_char ();
610 /* Hack for mpfr_set_str(). */
611 for (;;)
613 if (c == 'd' || c == 'q')
614 *p = 'e';
615 else
616 *p = c;
617 p++;
618 if (--count == 0)
619 break;
621 c = gfc_next_ascii_char ();
624 kind = get_kind (&is_iso_c);
625 if (kind == -1)
626 goto cleanup;
628 switch (exp_char)
630 case 'd':
631 if (kind != -2)
633 gfc_error ("Real number at %C has a 'd' exponent and an explicit "
634 "kind");
635 goto cleanup;
637 kind = gfc_default_double_kind;
639 if (kind == 4)
641 if (gfc_option.flag_real4_kind == 8)
642 kind = 8;
643 if (gfc_option.flag_real4_kind == 10)
644 kind = 10;
645 if (gfc_option.flag_real4_kind == 16)
646 kind = 16;
649 if (kind == 8)
651 if (gfc_option.flag_real8_kind == 4)
652 kind = 4;
653 if (gfc_option.flag_real8_kind == 10)
654 kind = 10;
655 if (gfc_option.flag_real8_kind == 16)
656 kind = 16;
658 break;
660 case 'q':
661 if (kind != -2)
663 gfc_error ("Real number at %C has a 'q' exponent and an explicit "
664 "kind");
665 goto cleanup;
668 /* The maximum possible real kind type parameter is 16. First, try
669 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
670 extended precision. If neither value works, just given up. */
671 kind = 16;
672 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
674 kind = 10;
675 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
677 gfc_error ("Invalid exponent-letter 'q' in "
678 "real-literal-constant at %C");
679 goto cleanup;
682 break;
684 default:
685 if (kind == -2)
686 kind = gfc_default_real_kind;
688 if (kind == 4)
690 if (gfc_option.flag_real4_kind == 8)
691 kind = 8;
692 if (gfc_option.flag_real4_kind == 10)
693 kind = 10;
694 if (gfc_option.flag_real4_kind == 16)
695 kind = 16;
698 if (kind == 8)
700 if (gfc_option.flag_real8_kind == 4)
701 kind = 4;
702 if (gfc_option.flag_real8_kind == 10)
703 kind = 10;
704 if (gfc_option.flag_real8_kind == 16)
705 kind = 16;
708 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
710 gfc_error ("Invalid real kind %d at %C", kind);
711 goto cleanup;
715 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
716 if (negate)
717 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
718 e->ts.is_c_interop = is_iso_c;
720 switch (gfc_range_check (e))
722 case ARITH_OK:
723 break;
724 case ARITH_OVERFLOW:
725 gfc_error ("Real constant overflows its kind at %C");
726 goto cleanup;
728 case ARITH_UNDERFLOW:
729 if (gfc_option.warn_underflow)
730 gfc_warning ("Real constant underflows its kind at %C");
731 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
732 break;
734 default:
735 gfc_internal_error ("gfc_range_check() returned bad value");
738 *result = e;
739 return MATCH_YES;
741 cleanup:
742 gfc_free_expr (e);
743 return MATCH_ERROR;
747 /* Match a substring reference. */
749 static match
750 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
752 gfc_expr *start, *end;
753 locus old_loc;
754 gfc_ref *ref;
755 match m;
757 start = NULL;
758 end = NULL;
760 old_loc = gfc_current_locus;
762 m = gfc_match_char ('(');
763 if (m != MATCH_YES)
764 return MATCH_NO;
766 if (gfc_match_char (':') != MATCH_YES)
768 if (init)
769 m = gfc_match_init_expr (&start);
770 else
771 m = gfc_match_expr (&start);
773 if (m != MATCH_YES)
775 m = MATCH_NO;
776 goto cleanup;
779 m = gfc_match_char (':');
780 if (m != MATCH_YES)
781 goto cleanup;
784 if (gfc_match_char (')') != MATCH_YES)
786 if (init)
787 m = gfc_match_init_expr (&end);
788 else
789 m = gfc_match_expr (&end);
791 if (m == MATCH_NO)
792 goto syntax;
793 if (m == MATCH_ERROR)
794 goto cleanup;
796 m = gfc_match_char (')');
797 if (m == MATCH_NO)
798 goto syntax;
801 /* Optimize away the (:) reference. */
802 if (start == NULL && end == NULL)
803 ref = NULL;
804 else
806 ref = gfc_get_ref ();
808 ref->type = REF_SUBSTRING;
809 if (start == NULL)
810 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
811 ref->u.ss.start = start;
812 if (end == NULL && cl)
813 end = gfc_copy_expr (cl->length);
814 ref->u.ss.end = end;
815 ref->u.ss.length = cl;
818 *result = ref;
819 return MATCH_YES;
821 syntax:
822 gfc_error ("Syntax error in SUBSTRING specification at %C");
823 m = MATCH_ERROR;
825 cleanup:
826 gfc_free_expr (start);
827 gfc_free_expr (end);
829 gfc_current_locus = old_loc;
830 return m;
834 /* Reads the next character of a string constant, taking care to
835 return doubled delimiters on the input as a single instance of
836 the delimiter.
838 Special return values for "ret" argument are:
839 -1 End of the string, as determined by the delimiter
840 -2 Unterminated string detected
842 Backslash codes are also expanded at this time. */
844 static gfc_char_t
845 next_string_char (gfc_char_t delimiter, int *ret)
847 locus old_locus;
848 gfc_char_t c;
850 c = gfc_next_char_literal (INSTRING_WARN);
851 *ret = 0;
853 if (c == '\n')
855 *ret = -2;
856 return 0;
859 if (gfc_option.flag_backslash && c == '\\')
861 old_locus = gfc_current_locus;
863 if (gfc_match_special_char (&c) == MATCH_NO)
864 gfc_current_locus = old_locus;
866 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
867 gfc_warning ("Extension: backslash character at %C");
870 if (c != delimiter)
871 return c;
873 old_locus = gfc_current_locus;
874 c = gfc_next_char_literal (NONSTRING);
876 if (c == delimiter)
877 return c;
878 gfc_current_locus = old_locus;
880 *ret = -1;
881 return 0;
885 /* Special case of gfc_match_name() that matches a parameter kind name
886 before a string constant. This takes case of the weird but legal
887 case of:
889 kind_____'string'
891 where kind____ is a parameter. gfc_match_name() will happily slurp
892 up all the underscores, which leads to problems. If we return
893 MATCH_YES, the parse pointer points to the final underscore, which
894 is not part of the name. We never return MATCH_ERROR-- errors in
895 the name will be detected later. */
897 static match
898 match_charkind_name (char *name)
900 locus old_loc;
901 char c, peek;
902 int len;
904 gfc_gobble_whitespace ();
905 c = gfc_next_ascii_char ();
906 if (!ISALPHA (c))
907 return MATCH_NO;
909 *name++ = c;
910 len = 1;
912 for (;;)
914 old_loc = gfc_current_locus;
915 c = gfc_next_ascii_char ();
917 if (c == '_')
919 peek = gfc_peek_ascii_char ();
921 if (peek == '\'' || peek == '\"')
923 gfc_current_locus = old_loc;
924 *name = '\0';
925 return MATCH_YES;
929 if (!ISALNUM (c)
930 && c != '_'
931 && (c != '$' || !gfc_option.flag_dollar_ok))
932 break;
934 *name++ = c;
935 if (++len > GFC_MAX_SYMBOL_LEN)
936 break;
939 return MATCH_NO;
943 /* See if the current input matches a character constant. Lots of
944 contortions have to be done to match the kind parameter which comes
945 before the actual string. The main consideration is that we don't
946 want to error out too quickly. For example, we don't actually do
947 any validation of the kinds until we have actually seen a legal
948 delimiter. Using match_kind_param() generates errors too quickly. */
950 static match
951 match_string_constant (gfc_expr **result)
953 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
954 int i, kind, length, warn_ampersand, ret;
955 locus old_locus, start_locus;
956 gfc_symbol *sym;
957 gfc_expr *e;
958 const char *q;
959 match m;
960 gfc_char_t c, delimiter, *p;
962 old_locus = gfc_current_locus;
964 gfc_gobble_whitespace ();
966 c = gfc_next_char ();
967 if (c == '\'' || c == '"')
969 kind = gfc_default_character_kind;
970 start_locus = gfc_current_locus;
971 goto got_delim;
974 if (gfc_wide_is_digit (c))
976 kind = 0;
978 while (gfc_wide_is_digit (c))
980 kind = kind * 10 + c - '0';
981 if (kind > 9999999)
982 goto no_match;
983 c = gfc_next_char ();
987 else
989 gfc_current_locus = old_locus;
991 m = match_charkind_name (name);
992 if (m != MATCH_YES)
993 goto no_match;
995 if (gfc_find_symbol (name, NULL, 1, &sym)
996 || sym == NULL
997 || sym->attr.flavor != FL_PARAMETER)
998 goto no_match;
1000 kind = -1;
1001 c = gfc_next_char ();
1004 if (c == ' ')
1006 gfc_gobble_whitespace ();
1007 c = gfc_next_char ();
1010 if (c != '_')
1011 goto no_match;
1013 gfc_gobble_whitespace ();
1015 c = gfc_next_char ();
1016 if (c != '\'' && c != '"')
1017 goto no_match;
1019 start_locus = gfc_current_locus;
1021 if (kind == -1)
1023 q = gfc_extract_int (sym->value, &kind);
1024 if (q != NULL)
1026 gfc_error (q);
1027 return MATCH_ERROR;
1029 gfc_set_sym_referenced (sym);
1032 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1034 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
1035 return MATCH_ERROR;
1038 got_delim:
1039 /* Scan the string into a block of memory by first figuring out how
1040 long it is, allocating the structure, then re-reading it. This
1041 isn't particularly efficient, but string constants aren't that
1042 common in most code. TODO: Use obstacks? */
1044 delimiter = c;
1045 length = 0;
1047 for (;;)
1049 c = next_string_char (delimiter, &ret);
1050 if (ret == -1)
1051 break;
1052 if (ret == -2)
1054 gfc_current_locus = start_locus;
1055 gfc_error ("Unterminated character constant beginning at %C");
1056 return MATCH_ERROR;
1059 length++;
1062 /* Peek at the next character to see if it is a b, o, z, or x for the
1063 postfixed BOZ literal constants. */
1064 peek = gfc_peek_ascii_char ();
1065 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
1066 goto no_match;
1068 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
1070 gfc_current_locus = start_locus;
1072 /* We disable the warning for the following loop as the warning has already
1073 been printed in the loop above. */
1074 warn_ampersand = gfc_option.warn_ampersand;
1075 gfc_option.warn_ampersand = 0;
1077 p = e->value.character.string;
1078 for (i = 0; i < length; i++)
1080 c = next_string_char (delimiter, &ret);
1082 if (!gfc_check_character_range (c, kind))
1084 gfc_free_expr (e);
1085 gfc_error ("Character '%s' in string at %C is not representable "
1086 "in character kind %d", gfc_print_wide_char (c), kind);
1087 return MATCH_ERROR;
1090 *p++ = c;
1093 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1094 gfc_option.warn_ampersand = warn_ampersand;
1096 next_string_char (delimiter, &ret);
1097 if (ret != -1)
1098 gfc_internal_error ("match_string_constant(): Delimiter not found");
1100 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1101 e->expr_type = EXPR_SUBSTRING;
1103 *result = e;
1105 return MATCH_YES;
1107 no_match:
1108 gfc_current_locus = old_locus;
1109 return MATCH_NO;
1113 /* Match a .true. or .false. Returns 1 if a .true. was found,
1114 0 if a .false. was found, and -1 otherwise. */
1115 static int
1116 match_logical_constant_string (void)
1118 locus orig_loc = gfc_current_locus;
1120 gfc_gobble_whitespace ();
1121 if (gfc_next_ascii_char () == '.')
1123 char ch = gfc_next_ascii_char ();
1124 if (ch == 'f')
1126 if (gfc_next_ascii_char () == 'a'
1127 && gfc_next_ascii_char () == 'l'
1128 && gfc_next_ascii_char () == 's'
1129 && gfc_next_ascii_char () == 'e'
1130 && gfc_next_ascii_char () == '.')
1131 /* Matched ".false.". */
1132 return 0;
1134 else if (ch == 't')
1136 if (gfc_next_ascii_char () == 'r'
1137 && gfc_next_ascii_char () == 'u'
1138 && gfc_next_ascii_char () == 'e'
1139 && gfc_next_ascii_char () == '.')
1140 /* Matched ".true.". */
1141 return 1;
1144 gfc_current_locus = orig_loc;
1145 return -1;
1148 /* Match a .true. or .false. */
1150 static match
1151 match_logical_constant (gfc_expr **result)
1153 gfc_expr *e;
1154 int i, kind, is_iso_c;
1156 i = match_logical_constant_string ();
1157 if (i == -1)
1158 return MATCH_NO;
1160 kind = get_kind (&is_iso_c);
1161 if (kind == -1)
1162 return MATCH_ERROR;
1163 if (kind == -2)
1164 kind = gfc_default_logical_kind;
1166 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1168 gfc_error ("Bad kind for logical constant at %C");
1169 return MATCH_ERROR;
1172 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1173 e->ts.is_c_interop = is_iso_c;
1175 *result = e;
1176 return MATCH_YES;
1180 /* Match a real or imaginary part of a complex constant that is a
1181 symbolic constant. */
1183 static match
1184 match_sym_complex_part (gfc_expr **result)
1186 char name[GFC_MAX_SYMBOL_LEN + 1];
1187 gfc_symbol *sym;
1188 gfc_expr *e;
1189 match m;
1191 m = gfc_match_name (name);
1192 if (m != MATCH_YES)
1193 return m;
1195 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1196 return MATCH_NO;
1198 if (sym->attr.flavor != FL_PARAMETER)
1200 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1201 return MATCH_ERROR;
1204 if (!gfc_numeric_ts (&sym->value->ts))
1206 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1207 return MATCH_ERROR;
1210 if (sym->value->rank != 0)
1212 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1213 return MATCH_ERROR;
1216 if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
1217 "complex constant at %C"))
1218 return MATCH_ERROR;
1220 switch (sym->value->ts.type)
1222 case BT_REAL:
1223 e = gfc_copy_expr (sym->value);
1224 break;
1226 case BT_COMPLEX:
1227 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1228 if (e == NULL)
1229 goto error;
1230 break;
1232 case BT_INTEGER:
1233 e = gfc_int2real (sym->value, gfc_default_real_kind);
1234 if (e == NULL)
1235 goto error;
1236 break;
1238 default:
1239 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1242 *result = e; /* e is a scalar, real, constant expression. */
1243 return MATCH_YES;
1245 error:
1246 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1247 return MATCH_ERROR;
1251 /* Match a real or imaginary part of a complex number. */
1253 static match
1254 match_complex_part (gfc_expr **result)
1256 match m;
1258 m = match_sym_complex_part (result);
1259 if (m != MATCH_NO)
1260 return m;
1262 m = match_real_constant (result, 1);
1263 if (m != MATCH_NO)
1264 return m;
1266 return match_integer_constant (result, 1);
1270 /* Try to match a complex constant. */
1272 static match
1273 match_complex_constant (gfc_expr **result)
1275 gfc_expr *e, *real, *imag;
1276 gfc_error_buf old_error;
1277 gfc_typespec target;
1278 locus old_loc;
1279 int kind;
1280 match m;
1282 old_loc = gfc_current_locus;
1283 real = imag = e = NULL;
1285 m = gfc_match_char ('(');
1286 if (m != MATCH_YES)
1287 return m;
1289 gfc_push_error (&old_error);
1291 m = match_complex_part (&real);
1292 if (m == MATCH_NO)
1294 gfc_free_error (&old_error);
1295 goto cleanup;
1298 if (gfc_match_char (',') == MATCH_NO)
1300 gfc_pop_error (&old_error);
1301 m = MATCH_NO;
1302 goto cleanup;
1305 /* If m is error, then something was wrong with the real part and we
1306 assume we have a complex constant because we've seen the ','. An
1307 ambiguous case here is the start of an iterator list of some
1308 sort. These sort of lists are matched prior to coming here. */
1310 if (m == MATCH_ERROR)
1312 gfc_free_error (&old_error);
1313 goto cleanup;
1315 gfc_pop_error (&old_error);
1317 m = match_complex_part (&imag);
1318 if (m == MATCH_NO)
1319 goto syntax;
1320 if (m == MATCH_ERROR)
1321 goto cleanup;
1323 m = gfc_match_char (')');
1324 if (m == MATCH_NO)
1326 /* Give the matcher for implied do-loops a chance to run. This
1327 yields a much saner error message for (/ (i, 4=i, 6) /). */
1328 if (gfc_peek_ascii_char () == '=')
1330 m = MATCH_ERROR;
1331 goto cleanup;
1333 else
1334 goto syntax;
1337 if (m == MATCH_ERROR)
1338 goto cleanup;
1340 /* Decide on the kind of this complex number. */
1341 if (real->ts.type == BT_REAL)
1343 if (imag->ts.type == BT_REAL)
1344 kind = gfc_kind_max (real, imag);
1345 else
1346 kind = real->ts.kind;
1348 else
1350 if (imag->ts.type == BT_REAL)
1351 kind = imag->ts.kind;
1352 else
1353 kind = gfc_default_real_kind;
1355 gfc_clear_ts (&target);
1356 target.type = BT_REAL;
1357 target.kind = kind;
1359 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1360 gfc_convert_type (real, &target, 2);
1361 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1362 gfc_convert_type (imag, &target, 2);
1364 e = gfc_convert_complex (real, imag, kind);
1365 e->where = gfc_current_locus;
1367 gfc_free_expr (real);
1368 gfc_free_expr (imag);
1370 *result = e;
1371 return MATCH_YES;
1373 syntax:
1374 gfc_error ("Syntax error in COMPLEX constant at %C");
1375 m = MATCH_ERROR;
1377 cleanup:
1378 gfc_free_expr (e);
1379 gfc_free_expr (real);
1380 gfc_free_expr (imag);
1381 gfc_current_locus = old_loc;
1383 return m;
1387 /* Match constants in any of several forms. Returns nonzero for a
1388 match, zero for no match. */
1390 match
1391 gfc_match_literal_constant (gfc_expr **result, int signflag)
1393 match m;
1395 m = match_complex_constant (result);
1396 if (m != MATCH_NO)
1397 return m;
1399 m = match_string_constant (result);
1400 if (m != MATCH_NO)
1401 return m;
1403 m = match_boz_constant (result);
1404 if (m != MATCH_NO)
1405 return m;
1407 m = match_real_constant (result, signflag);
1408 if (m != MATCH_NO)
1409 return m;
1411 m = match_hollerith_constant (result);
1412 if (m != MATCH_NO)
1413 return m;
1415 m = match_integer_constant (result, signflag);
1416 if (m != MATCH_NO)
1417 return m;
1419 m = match_logical_constant (result);
1420 if (m != MATCH_NO)
1421 return m;
1423 return MATCH_NO;
1427 /* This checks if a symbol is the return value of an encompassing function.
1428 Function nesting can be maximally two levels deep, but we may have
1429 additional local namespaces like BLOCK etc. */
1431 bool
1432 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1434 if (!sym->attr.function || (sym->result != sym))
1435 return false;
1436 while (ns)
1438 if (ns->proc_name == sym)
1439 return true;
1440 ns = ns->parent;
1442 return false;
1446 /* Match a single actual argument value. An actual argument is
1447 usually an expression, but can also be a procedure name. If the
1448 argument is a single name, it is not always possible to tell
1449 whether the name is a dummy procedure or not. We treat these cases
1450 by creating an argument that looks like a dummy procedure and
1451 fixing things later during resolution. */
1453 static match
1454 match_actual_arg (gfc_expr **result)
1456 char name[GFC_MAX_SYMBOL_LEN + 1];
1457 gfc_symtree *symtree;
1458 locus where, w;
1459 gfc_expr *e;
1460 char c;
1462 gfc_gobble_whitespace ();
1463 where = gfc_current_locus;
1465 switch (gfc_match_name (name))
1467 case MATCH_ERROR:
1468 return MATCH_ERROR;
1470 case MATCH_NO:
1471 break;
1473 case MATCH_YES:
1474 w = gfc_current_locus;
1475 gfc_gobble_whitespace ();
1476 c = gfc_next_ascii_char ();
1477 gfc_current_locus = w;
1479 if (c != ',' && c != ')')
1480 break;
1482 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1483 break;
1484 /* Handle error elsewhere. */
1486 /* Eliminate a couple of common cases where we know we don't
1487 have a function argument. */
1488 if (symtree == NULL)
1490 gfc_get_sym_tree (name, NULL, &symtree, false);
1491 gfc_set_sym_referenced (symtree->n.sym);
1493 else
1495 gfc_symbol *sym;
1497 sym = symtree->n.sym;
1498 gfc_set_sym_referenced (sym);
1499 if (sym->attr.flavor != FL_PROCEDURE
1500 && sym->attr.flavor != FL_UNKNOWN)
1501 break;
1503 if (sym->attr.in_common && !sym->attr.proc_pointer)
1505 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
1506 sym->name, &sym->declared_at))
1507 return MATCH_ERROR;
1508 break;
1511 /* If the symbol is a function with itself as the result and
1512 is being defined, then we have a variable. */
1513 if (sym->attr.function && sym->result == sym)
1515 if (gfc_is_function_return_value (sym, gfc_current_ns))
1516 break;
1518 if (sym->attr.entry
1519 && (sym->ns == gfc_current_ns
1520 || sym->ns == gfc_current_ns->parent))
1522 gfc_entry_list *el = NULL;
1524 for (el = sym->ns->entries; el; el = el->next)
1525 if (sym == el->sym)
1526 break;
1528 if (el)
1529 break;
1534 e = gfc_get_expr (); /* Leave it unknown for now */
1535 e->symtree = symtree;
1536 e->expr_type = EXPR_VARIABLE;
1537 e->ts.type = BT_PROCEDURE;
1538 e->where = where;
1540 *result = e;
1541 return MATCH_YES;
1544 gfc_current_locus = where;
1545 return gfc_match_expr (result);
1549 /* Match a keyword argument. */
1551 static match
1552 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1554 char name[GFC_MAX_SYMBOL_LEN + 1];
1555 gfc_actual_arglist *a;
1556 locus name_locus;
1557 match m;
1559 name_locus = gfc_current_locus;
1560 m = gfc_match_name (name);
1562 if (m != MATCH_YES)
1563 goto cleanup;
1564 if (gfc_match_char ('=') != MATCH_YES)
1566 m = MATCH_NO;
1567 goto cleanup;
1570 m = match_actual_arg (&actual->expr);
1571 if (m != MATCH_YES)
1572 goto cleanup;
1574 /* Make sure this name has not appeared yet. */
1576 if (name[0] != '\0')
1578 for (a = base; a; a = a->next)
1579 if (a->name != NULL && strcmp (a->name, name) == 0)
1581 gfc_error ("Keyword '%s' at %C has already appeared in the "
1582 "current argument list", name);
1583 return MATCH_ERROR;
1587 actual->name = gfc_get_string (name);
1588 return MATCH_YES;
1590 cleanup:
1591 gfc_current_locus = name_locus;
1592 return m;
1596 /* Match an argument list function, such as %VAL. */
1598 static match
1599 match_arg_list_function (gfc_actual_arglist *result)
1601 char name[GFC_MAX_SYMBOL_LEN + 1];
1602 locus old_locus;
1603 match m;
1605 old_locus = gfc_current_locus;
1607 if (gfc_match_char ('%') != MATCH_YES)
1609 m = MATCH_NO;
1610 goto cleanup;
1613 m = gfc_match ("%n (", name);
1614 if (m != MATCH_YES)
1615 goto cleanup;
1617 if (name[0] != '\0')
1619 switch (name[0])
1621 case 'l':
1622 if (strncmp (name, "loc", 3) == 0)
1624 result->name = "%LOC";
1625 break;
1627 case 'r':
1628 if (strncmp (name, "ref", 3) == 0)
1630 result->name = "%REF";
1631 break;
1633 case 'v':
1634 if (strncmp (name, "val", 3) == 0)
1636 result->name = "%VAL";
1637 break;
1639 default:
1640 m = MATCH_ERROR;
1641 goto cleanup;
1645 if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
1647 m = MATCH_ERROR;
1648 goto cleanup;
1651 m = match_actual_arg (&result->expr);
1652 if (m != MATCH_YES)
1653 goto cleanup;
1655 if (gfc_match_char (')') != MATCH_YES)
1657 m = MATCH_NO;
1658 goto cleanup;
1661 return MATCH_YES;
1663 cleanup:
1664 gfc_current_locus = old_locus;
1665 return m;
1669 /* Matches an actual argument list of a function or subroutine, from
1670 the opening parenthesis to the closing parenthesis. The argument
1671 list is assumed to allow keyword arguments because we don't know if
1672 the symbol associated with the procedure has an implicit interface
1673 or not. We make sure keywords are unique. If sub_flag is set,
1674 we're matching the argument list of a subroutine. */
1676 match
1677 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1679 gfc_actual_arglist *head, *tail;
1680 int seen_keyword;
1681 gfc_st_label *label;
1682 locus old_loc;
1683 match m;
1685 *argp = tail = NULL;
1686 old_loc = gfc_current_locus;
1688 seen_keyword = 0;
1690 if (gfc_match_char ('(') == MATCH_NO)
1691 return (sub_flag) ? MATCH_YES : MATCH_NO;
1693 if (gfc_match_char (')') == MATCH_YES)
1694 return MATCH_YES;
1695 head = NULL;
1697 matching_actual_arglist++;
1699 for (;;)
1701 if (head == NULL)
1702 head = tail = gfc_get_actual_arglist ();
1703 else
1705 tail->next = gfc_get_actual_arglist ();
1706 tail = tail->next;
1709 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1711 m = gfc_match_st_label (&label);
1712 if (m == MATCH_NO)
1713 gfc_error ("Expected alternate return label at %C");
1714 if (m != MATCH_YES)
1715 goto cleanup;
1717 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
1718 "at %C"))
1719 goto cleanup;
1721 tail->label = label;
1722 goto next;
1725 /* After the first keyword argument is seen, the following
1726 arguments must also have keywords. */
1727 if (seen_keyword)
1729 m = match_keyword_arg (tail, head);
1731 if (m == MATCH_ERROR)
1732 goto cleanup;
1733 if (m == MATCH_NO)
1735 gfc_error ("Missing keyword name in actual argument list at %C");
1736 goto cleanup;
1740 else
1742 /* Try an argument list function, like %VAL. */
1743 m = match_arg_list_function (tail);
1744 if (m == MATCH_ERROR)
1745 goto cleanup;
1747 /* See if we have the first keyword argument. */
1748 if (m == MATCH_NO)
1750 m = match_keyword_arg (tail, head);
1751 if (m == MATCH_YES)
1752 seen_keyword = 1;
1753 if (m == MATCH_ERROR)
1754 goto cleanup;
1757 if (m == MATCH_NO)
1759 /* Try for a non-keyword argument. */
1760 m = match_actual_arg (&tail->expr);
1761 if (m == MATCH_ERROR)
1762 goto cleanup;
1763 if (m == MATCH_NO)
1764 goto syntax;
1769 next:
1770 if (gfc_match_char (')') == MATCH_YES)
1771 break;
1772 if (gfc_match_char (',') != MATCH_YES)
1773 goto syntax;
1776 *argp = head;
1777 matching_actual_arglist--;
1778 return MATCH_YES;
1780 syntax:
1781 gfc_error ("Syntax error in argument list at %C");
1783 cleanup:
1784 gfc_free_actual_arglist (head);
1785 gfc_current_locus = old_loc;
1786 matching_actual_arglist--;
1787 return MATCH_ERROR;
1791 /* Used by gfc_match_varspec() to extend the reference list by one
1792 element. */
1794 static gfc_ref *
1795 extend_ref (gfc_expr *primary, gfc_ref *tail)
1797 if (primary->ref == NULL)
1798 primary->ref = tail = gfc_get_ref ();
1799 else
1801 if (tail == NULL)
1802 gfc_internal_error ("extend_ref(): Bad tail");
1803 tail->next = gfc_get_ref ();
1804 tail = tail->next;
1807 return tail;
1811 /* Match any additional specifications associated with the current
1812 variable like member references or substrings. If equiv_flag is
1813 set we only match stuff that is allowed inside an EQUIVALENCE
1814 statement. sub_flag tells whether we expect a type-bound procedure found
1815 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1816 components, 'ppc_arg' determines whether the PPC may be called (with an
1817 argument list), or whether it may just be referred to as a pointer. */
1819 match
1820 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1821 bool ppc_arg)
1823 char name[GFC_MAX_SYMBOL_LEN + 1];
1824 gfc_ref *substring, *tail;
1825 gfc_component *component;
1826 gfc_symbol *sym = primary->symtree->n.sym;
1827 match m;
1828 bool unknown;
1830 tail = NULL;
1832 gfc_gobble_whitespace ();
1834 if (gfc_peek_ascii_char () == '[')
1836 if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
1837 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
1838 && CLASS_DATA (sym)->attr.dimension))
1840 gfc_error ("Array section designator, e.g. '(:)', is required "
1841 "besides the coarray designator '[...]' at %C");
1842 return MATCH_ERROR;
1844 if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
1845 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
1846 && !CLASS_DATA (sym)->attr.codimension))
1848 gfc_error ("Coarray designator at %C but '%s' is not a coarray",
1849 sym->name);
1850 return MATCH_ERROR;
1854 /* For associate names, we may not yet know whether they are arrays or not.
1855 Thus if we have one and parentheses follow, we have to assume that it
1856 actually is one for now. The final decision will be made at
1857 resolution time, of course. */
1858 if (sym->assoc && gfc_peek_ascii_char () == '(')
1859 sym->attr.dimension = 1;
1861 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1862 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1863 || (sym->attr.dimension && sym->ts.type != BT_CLASS
1864 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
1865 && !(gfc_matching_procptr_assignment
1866 && sym->attr.flavor == FL_PROCEDURE))
1867 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1868 && (CLASS_DATA (sym)->attr.dimension
1869 || CLASS_DATA (sym)->attr.codimension)))
1871 gfc_array_spec *as;
1873 tail = extend_ref (primary, tail);
1874 tail->type = REF_ARRAY;
1876 /* In EQUIVALENCE, we don't know yet whether we are seeing
1877 an array, character variable or array of character
1878 variables. We'll leave the decision till resolve time. */
1880 if (equiv_flag)
1881 as = NULL;
1882 else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
1883 as = CLASS_DATA (sym)->as;
1884 else
1885 as = sym->as;
1887 m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
1888 as ? as->corank : 0);
1889 if (m != MATCH_YES)
1890 return m;
1892 gfc_gobble_whitespace ();
1893 if (equiv_flag && gfc_peek_ascii_char () == '(')
1895 tail = extend_ref (primary, tail);
1896 tail->type = REF_ARRAY;
1898 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1899 if (m != MATCH_YES)
1900 return m;
1904 primary->ts = sym->ts;
1906 if (equiv_flag)
1907 return MATCH_YES;
1909 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1910 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1911 gfc_set_default_type (sym, 0, sym->ns);
1913 if (sym->ts.type == BT_UNKNOWN && gfc_match_char ('%') == MATCH_YES)
1915 gfc_error ("Symbol '%s' at %C has no IMPLICIT type", sym->name);
1916 return MATCH_ERROR;
1918 else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1919 && gfc_match_char ('%') == MATCH_YES)
1921 gfc_error ("Unexpected '%%' for nonderived-type variable '%s' at %C",
1922 sym->name);
1923 return MATCH_ERROR;
1926 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1927 || gfc_match_char ('%') != MATCH_YES)
1928 goto check_substring;
1930 sym = sym->ts.u.derived;
1932 for (;;)
1934 bool t;
1935 gfc_symtree *tbp;
1937 m = gfc_match_name (name);
1938 if (m == MATCH_NO)
1939 gfc_error ("Expected structure component name at %C");
1940 if (m != MATCH_YES)
1941 return MATCH_ERROR;
1943 if (sym->f2k_derived)
1944 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1945 else
1946 tbp = NULL;
1948 if (tbp)
1950 gfc_symbol* tbp_sym;
1952 if (!t)
1953 return MATCH_ERROR;
1955 gcc_assert (!tail || !tail->next);
1957 if (!(primary->expr_type == EXPR_VARIABLE
1958 || (primary->expr_type == EXPR_STRUCTURE
1959 && primary->symtree && primary->symtree->n.sym
1960 && primary->symtree->n.sym->attr.flavor)))
1961 return MATCH_ERROR;
1963 if (tbp->n.tb->is_generic)
1964 tbp_sym = NULL;
1965 else
1966 tbp_sym = tbp->n.tb->u.specific->n.sym;
1968 primary->expr_type = EXPR_COMPCALL;
1969 primary->value.compcall.tbp = tbp->n.tb;
1970 primary->value.compcall.name = tbp->name;
1971 primary->value.compcall.ignore_pass = 0;
1972 primary->value.compcall.assign = 0;
1973 primary->value.compcall.base_object = NULL;
1974 gcc_assert (primary->symtree->n.sym->attr.referenced);
1975 if (tbp_sym)
1976 primary->ts = tbp_sym->ts;
1977 else
1978 gfc_clear_ts (&primary->ts);
1980 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1981 &primary->value.compcall.actual);
1982 if (m == MATCH_ERROR)
1983 return MATCH_ERROR;
1984 if (m == MATCH_NO)
1986 if (sub_flag)
1987 primary->value.compcall.actual = NULL;
1988 else
1990 gfc_error ("Expected argument list at %C");
1991 return MATCH_ERROR;
1995 break;
1998 component = gfc_find_component (sym, name, false, false);
1999 if (component == NULL)
2000 return MATCH_ERROR;
2002 tail = extend_ref (primary, tail);
2003 tail->type = REF_COMPONENT;
2005 tail->u.c.component = component;
2006 tail->u.c.sym = sym;
2008 primary->ts = component->ts;
2010 if (component->attr.proc_pointer && ppc_arg)
2012 /* Procedure pointer component call: Look for argument list. */
2013 m = gfc_match_actual_arglist (sub_flag,
2014 &primary->value.compcall.actual);
2015 if (m == MATCH_ERROR)
2016 return MATCH_ERROR;
2018 if (m == MATCH_NO && !gfc_matching_ptr_assignment
2019 && !gfc_matching_procptr_assignment && !matching_actual_arglist)
2021 gfc_error ("Procedure pointer component '%s' requires an "
2022 "argument list at %C", component->name);
2023 return MATCH_ERROR;
2026 if (m == MATCH_YES)
2027 primary->expr_type = EXPR_PPC;
2029 break;
2032 if (component->as != NULL && !component->attr.proc_pointer)
2034 tail = extend_ref (primary, tail);
2035 tail->type = REF_ARRAY;
2037 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
2038 component->as->corank);
2039 if (m != MATCH_YES)
2040 return m;
2042 else if (component->ts.type == BT_CLASS && component->attr.class_ok
2043 && CLASS_DATA (component)->as && !component->attr.proc_pointer)
2045 tail = extend_ref (primary, tail);
2046 tail->type = REF_ARRAY;
2048 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
2049 equiv_flag,
2050 CLASS_DATA (component)->as->corank);
2051 if (m != MATCH_YES)
2052 return m;
2055 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
2056 || gfc_match_char ('%') != MATCH_YES)
2057 break;
2059 sym = component->ts.u.derived;
2062 check_substring:
2063 unknown = false;
2064 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
2066 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
2068 gfc_set_default_type (sym, 0, sym->ns);
2069 primary->ts = sym->ts;
2070 unknown = true;
2074 if (primary->ts.type == BT_CHARACTER)
2076 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
2078 case MATCH_YES:
2079 if (tail == NULL)
2080 primary->ref = substring;
2081 else
2082 tail->next = substring;
2084 if (primary->expr_type == EXPR_CONSTANT)
2085 primary->expr_type = EXPR_SUBSTRING;
2087 if (substring)
2088 primary->ts.u.cl = NULL;
2090 break;
2092 case MATCH_NO:
2093 if (unknown)
2095 gfc_clear_ts (&primary->ts);
2096 gfc_clear_ts (&sym->ts);
2098 break;
2100 case MATCH_ERROR:
2101 return MATCH_ERROR;
2105 /* F2008, C727. */
2106 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
2108 gfc_error ("Coindexed procedure-pointer component at %C");
2109 return MATCH_ERROR;
2112 return MATCH_YES;
2116 /* Given an expression that is a variable, figure out what the
2117 ultimate variable's type and attribute is, traversing the reference
2118 structures if necessary.
2120 This subroutine is trickier than it looks. We start at the base
2121 symbol and store the attribute. Component references load a
2122 completely new attribute.
2124 A couple of rules come into play. Subobjects of targets are always
2125 targets themselves. If we see a component that goes through a
2126 pointer, then the expression must also be a target, since the
2127 pointer is associated with something (if it isn't core will soon be
2128 dumped). If we see a full part or section of an array, the
2129 expression is also an array.
2131 We can have at most one full array reference. */
2133 symbol_attribute
2134 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2136 int dimension, codimension, pointer, allocatable, target;
2137 symbol_attribute attr;
2138 gfc_ref *ref;
2139 gfc_symbol *sym;
2140 gfc_component *comp;
2142 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2143 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2145 sym = expr->symtree->n.sym;
2146 attr = sym->attr;
2148 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2150 dimension = CLASS_DATA (sym)->attr.dimension;
2151 codimension = CLASS_DATA (sym)->attr.codimension;
2152 pointer = CLASS_DATA (sym)->attr.class_pointer;
2153 allocatable = CLASS_DATA (sym)->attr.allocatable;
2155 else
2157 dimension = attr.dimension;
2158 codimension = attr.codimension;
2159 pointer = attr.pointer;
2160 allocatable = attr.allocatable;
2163 target = attr.target;
2164 if (pointer || attr.proc_pointer)
2165 target = 1;
2167 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2168 *ts = sym->ts;
2170 for (ref = expr->ref; ref; ref = ref->next)
2171 switch (ref->type)
2173 case REF_ARRAY:
2175 switch (ref->u.ar.type)
2177 case AR_FULL:
2178 dimension = 1;
2179 break;
2181 case AR_SECTION:
2182 allocatable = pointer = 0;
2183 dimension = 1;
2184 break;
2186 case AR_ELEMENT:
2187 /* Handle coarrays. */
2188 if (ref->u.ar.dimen > 0)
2189 allocatable = pointer = 0;
2190 break;
2192 case AR_UNKNOWN:
2193 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2196 break;
2198 case REF_COMPONENT:
2199 comp = ref->u.c.component;
2200 attr = comp->attr;
2201 if (ts != NULL)
2203 *ts = comp->ts;
2204 /* Don't set the string length if a substring reference
2205 follows. */
2206 if (ts->type == BT_CHARACTER
2207 && ref->next && ref->next->type == REF_SUBSTRING)
2208 ts->u.cl = NULL;
2211 if (comp->ts.type == BT_CLASS)
2213 codimension = CLASS_DATA (comp)->attr.codimension;
2214 pointer = CLASS_DATA (comp)->attr.class_pointer;
2215 allocatable = CLASS_DATA (comp)->attr.allocatable;
2217 else
2219 codimension = comp->attr.codimension;
2220 pointer = comp->attr.pointer;
2221 allocatable = comp->attr.allocatable;
2223 if (pointer || attr.proc_pointer)
2224 target = 1;
2226 break;
2228 case REF_SUBSTRING:
2229 allocatable = pointer = 0;
2230 break;
2233 attr.dimension = dimension;
2234 attr.codimension = codimension;
2235 attr.pointer = pointer;
2236 attr.allocatable = allocatable;
2237 attr.target = target;
2238 attr.save = sym->attr.save;
2240 return attr;
2244 /* Return the attribute from a general expression. */
2246 symbol_attribute
2247 gfc_expr_attr (gfc_expr *e)
2249 symbol_attribute attr;
2251 switch (e->expr_type)
2253 case EXPR_VARIABLE:
2254 attr = gfc_variable_attr (e, NULL);
2255 break;
2257 case EXPR_FUNCTION:
2258 gfc_clear_attr (&attr);
2260 if (e->value.function.esym && e->value.function.esym->result)
2262 gfc_symbol *sym = e->value.function.esym->result;
2263 attr = sym->attr;
2264 if (sym->ts.type == BT_CLASS)
2266 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2267 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2268 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2271 else
2272 attr = gfc_variable_attr (e, NULL);
2274 /* TODO: NULL() returns pointers. May have to take care of this
2275 here. */
2277 break;
2279 default:
2280 gfc_clear_attr (&attr);
2281 break;
2284 return attr;
2288 /* Match a structure constructor. The initial symbol has already been
2289 seen. */
2291 typedef struct gfc_structure_ctor_component
2293 char* name;
2294 gfc_expr* val;
2295 locus where;
2296 struct gfc_structure_ctor_component* next;
2298 gfc_structure_ctor_component;
2300 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2302 static void
2303 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2305 free (comp->name);
2306 gfc_free_expr (comp->val);
2307 free (comp);
2311 /* Translate the component list into the actual constructor by sorting it in
2312 the order required; this also checks along the way that each and every
2313 component actually has an initializer and handles default initializers
2314 for components without explicit value given. */
2315 static bool
2316 build_actual_constructor (gfc_structure_ctor_component **comp_head,
2317 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2319 gfc_structure_ctor_component *comp_iter;
2320 gfc_component *comp;
2322 for (comp = sym->components; comp; comp = comp->next)
2324 gfc_structure_ctor_component **next_ptr;
2325 gfc_expr *value = NULL;
2327 /* Try to find the initializer for the current component by name. */
2328 next_ptr = comp_head;
2329 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2331 if (!strcmp (comp_iter->name, comp->name))
2332 break;
2333 next_ptr = &comp_iter->next;
2336 /* If an extension, try building the parent derived type by building
2337 a value expression for the parent derived type and calling self. */
2338 if (!comp_iter && comp == sym->components && sym->attr.extension)
2340 value = gfc_get_structure_constructor_expr (comp->ts.type,
2341 comp->ts.kind,
2342 &gfc_current_locus);
2343 value->ts = comp->ts;
2345 if (!build_actual_constructor (comp_head,
2346 &value->value.constructor,
2347 comp->ts.u.derived))
2349 gfc_free_expr (value);
2350 return false;
2353 gfc_constructor_append_expr (ctor_head, value, NULL);
2354 continue;
2357 /* If it was not found, try the default initializer if there's any;
2358 otherwise, it's an error. */
2359 if (!comp_iter)
2361 if (comp->initializer)
2363 if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
2364 "with missing optional arguments at %C"))
2365 return false;
2366 value = gfc_copy_expr (comp->initializer);
2368 else
2370 gfc_error ("No initializer for component '%s' given in the"
2371 " structure constructor at %C!", comp->name);
2372 return false;
2375 else
2376 value = comp_iter->val;
2378 /* Add the value to the constructor chain built. */
2379 gfc_constructor_append_expr (ctor_head, value, NULL);
2381 /* Remove the entry from the component list. We don't want the expression
2382 value to be free'd, so set it to NULL. */
2383 if (comp_iter)
2385 *next_ptr = comp_iter->next;
2386 comp_iter->val = NULL;
2387 gfc_free_structure_ctor_component (comp_iter);
2390 return true;
2394 bool
2395 gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
2396 gfc_actual_arglist **arglist,
2397 bool parent)
2399 gfc_actual_arglist *actual;
2400 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2401 gfc_constructor_base ctor_head = NULL;
2402 gfc_component *comp; /* Is set NULL when named component is first seen */
2403 const char* last_name = NULL;
2404 locus old_locus;
2405 gfc_expr *expr;
2407 expr = parent ? *cexpr : e;
2408 old_locus = gfc_current_locus;
2409 if (parent)
2410 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2411 else
2412 gfc_current_locus = expr->where;
2414 comp_tail = comp_head = NULL;
2416 if (!parent && sym->attr.abstract)
2418 gfc_error ("Can't construct ABSTRACT type '%s' at %L",
2419 sym->name, &expr->where);
2420 goto cleanup;
2423 comp = sym->components;
2424 actual = parent ? *arglist : expr->value.function.actual;
2425 for ( ; actual; )
2427 gfc_component *this_comp = NULL;
2429 if (!comp_head)
2430 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2431 else
2433 comp_tail->next = gfc_get_structure_ctor_component ();
2434 comp_tail = comp_tail->next;
2436 if (actual->name)
2438 if (!gfc_notify_std (GFC_STD_F2003, "Structure"
2439 " constructor with named arguments at %C"))
2440 goto cleanup;
2442 comp_tail->name = xstrdup (actual->name);
2443 last_name = comp_tail->name;
2444 comp = NULL;
2446 else
2448 /* Components without name are not allowed after the first named
2449 component initializer! */
2450 if (!comp)
2452 if (last_name)
2453 gfc_error ("Component initializer without name after component"
2454 " named %s at %L!", last_name,
2455 actual->expr ? &actual->expr->where
2456 : &gfc_current_locus);
2457 else
2458 gfc_error ("Too many components in structure constructor at "
2459 "%L!", actual->expr ? &actual->expr->where
2460 : &gfc_current_locus);
2461 goto cleanup;
2464 comp_tail->name = xstrdup (comp->name);
2467 /* Find the current component in the structure definition and check
2468 its access is not private. */
2469 if (comp)
2470 this_comp = gfc_find_component (sym, comp->name, false, false);
2471 else
2473 this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2474 false, false);
2475 comp = NULL; /* Reset needed! */
2478 /* Here we can check if a component name is given which does not
2479 correspond to any component of the defined structure. */
2480 if (!this_comp)
2481 goto cleanup;
2483 comp_tail->val = actual->expr;
2484 if (actual->expr != NULL)
2485 comp_tail->where = actual->expr->where;
2486 actual->expr = NULL;
2488 /* Check if this component is already given a value. */
2489 for (comp_iter = comp_head; comp_iter != comp_tail;
2490 comp_iter = comp_iter->next)
2492 gcc_assert (comp_iter);
2493 if (!strcmp (comp_iter->name, comp_tail->name))
2495 gfc_error ("Component '%s' is initialized twice in the structure"
2496 " constructor at %L!", comp_tail->name,
2497 comp_tail->val ? &comp_tail->where
2498 : &gfc_current_locus);
2499 goto cleanup;
2503 /* F2008, R457/C725, for PURE C1283. */
2504 if (this_comp->attr.pointer && comp_tail->val
2505 && gfc_is_coindexed (comp_tail->val))
2507 gfc_error ("Coindexed expression to pointer component '%s' in "
2508 "structure constructor at %L!", comp_tail->name,
2509 &comp_tail->where);
2510 goto cleanup;
2513 /* If not explicitly a parent constructor, gather up the components
2514 and build one. */
2515 if (comp && comp == sym->components
2516 && sym->attr.extension
2517 && comp_tail->val
2518 && (comp_tail->val->ts.type != BT_DERIVED
2520 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2522 bool m;
2523 gfc_actual_arglist *arg_null = NULL;
2525 actual->expr = comp_tail->val;
2526 comp_tail->val = NULL;
2528 m = gfc_convert_to_structure_constructor (NULL,
2529 comp->ts.u.derived, &comp_tail->val,
2530 comp->ts.u.derived->attr.zero_comp
2531 ? &arg_null : &actual, true);
2532 if (!m)
2533 goto cleanup;
2535 if (comp->ts.u.derived->attr.zero_comp)
2537 comp = comp->next;
2538 continue;
2542 if (comp)
2543 comp = comp->next;
2544 if (parent && !comp)
2545 break;
2547 actual = actual->next;
2550 if (!build_actual_constructor (&comp_head, &ctor_head, sym))
2551 goto cleanup;
2553 /* No component should be left, as this should have caused an error in the
2554 loop constructing the component-list (name that does not correspond to any
2555 component in the structure definition). */
2556 if (comp_head && sym->attr.extension)
2558 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2560 gfc_error ("component '%s' at %L has already been set by a "
2561 "parent derived type constructor", comp_iter->name,
2562 &comp_iter->where);
2564 goto cleanup;
2566 else
2567 gcc_assert (!comp_head);
2569 if (parent)
2571 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
2572 expr->ts.u.derived = sym;
2573 expr->value.constructor = ctor_head;
2574 *cexpr = expr;
2576 else
2578 expr->ts.u.derived = sym;
2579 expr->ts.kind = 0;
2580 expr->ts.type = BT_DERIVED;
2581 expr->value.constructor = ctor_head;
2582 expr->expr_type = EXPR_STRUCTURE;
2585 gfc_current_locus = old_locus;
2586 if (parent)
2587 *arglist = actual;
2588 return true;
2590 cleanup:
2591 gfc_current_locus = old_locus;
2593 for (comp_iter = comp_head; comp_iter; )
2595 gfc_structure_ctor_component *next = comp_iter->next;
2596 gfc_free_structure_ctor_component (comp_iter);
2597 comp_iter = next;
2599 gfc_constructor_free (ctor_head);
2601 return false;
2605 match
2606 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
2608 match m;
2609 gfc_expr *e;
2610 gfc_symtree *symtree;
2612 gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */
2614 e = gfc_get_expr ();
2615 e->symtree = symtree;
2616 e->expr_type = EXPR_FUNCTION;
2618 gcc_assert (sym->attr.flavor == FL_DERIVED
2619 && symtree->n.sym->attr.flavor == FL_PROCEDURE);
2620 e->value.function.esym = sym;
2621 e->symtree->n.sym->attr.generic = 1;
2623 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2624 if (m != MATCH_YES)
2626 gfc_free_expr (e);
2627 return m;
2630 if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
2632 gfc_free_expr (e);
2633 return MATCH_ERROR;
2636 *result = e;
2637 return MATCH_YES;
2641 /* If the symbol is an implicit do loop index and implicitly typed,
2642 it should not be host associated. Provide a symtree from the
2643 current namespace. */
2644 static match
2645 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2647 if ((*sym)->attr.flavor == FL_VARIABLE
2648 && (*sym)->ns != gfc_current_ns
2649 && (*sym)->attr.implied_index
2650 && (*sym)->attr.implicit_type
2651 && !(*sym)->attr.use_assoc)
2653 int i;
2654 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2655 if (i)
2656 return MATCH_ERROR;
2657 *sym = (*st)->n.sym;
2659 return MATCH_YES;
2663 /* Procedure pointer as function result: Replace the function symbol by the
2664 auto-generated hidden result variable named "ppr@". */
2666 static bool
2667 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2669 /* Check for procedure pointer result variable. */
2670 if ((*sym)->attr.function && !(*sym)->attr.external
2671 && (*sym)->result && (*sym)->result != *sym
2672 && (*sym)->result->attr.proc_pointer
2673 && (*sym) == gfc_current_ns->proc_name
2674 && (*sym) == (*sym)->result->ns->proc_name
2675 && strcmp ("ppr@", (*sym)->result->name) == 0)
2677 /* Automatic replacement with "hidden" result variable. */
2678 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2679 *sym = (*sym)->result;
2680 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2681 return true;
2683 return false;
2687 /* Matches a variable name followed by anything that might follow it--
2688 array reference, argument list of a function, etc. */
2690 match
2691 gfc_match_rvalue (gfc_expr **result)
2693 gfc_actual_arglist *actual_arglist;
2694 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2695 gfc_state_data *st;
2696 gfc_symbol *sym;
2697 gfc_symtree *symtree;
2698 locus where, old_loc;
2699 gfc_expr *e;
2700 match m, m2;
2701 int i;
2702 gfc_typespec *ts;
2703 bool implicit_char;
2704 gfc_ref *ref;
2706 m = gfc_match_name (name);
2707 if (m != MATCH_YES)
2708 return m;
2710 if (gfc_find_state (COMP_INTERFACE)
2711 && !gfc_current_ns->has_import_set)
2712 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2713 else
2714 i = gfc_get_ha_sym_tree (name, &symtree);
2716 if (i)
2717 return MATCH_ERROR;
2719 sym = symtree->n.sym;
2720 e = NULL;
2721 where = gfc_current_locus;
2723 replace_hidden_procptr_result (&sym, &symtree);
2725 /* If this is an implicit do loop index and implicitly typed,
2726 it should not be host associated. */
2727 m = check_for_implicit_index (&symtree, &sym);
2728 if (m != MATCH_YES)
2729 return m;
2731 gfc_set_sym_referenced (sym);
2732 sym->attr.implied_index = 0;
2734 if (sym->attr.function && sym->result == sym)
2736 /* See if this is a directly recursive function call. */
2737 gfc_gobble_whitespace ();
2738 if (sym->attr.recursive
2739 && gfc_peek_ascii_char () == '('
2740 && gfc_current_ns->proc_name == sym
2741 && !sym->attr.dimension)
2743 gfc_error ("'%s' at %C is the name of a recursive function "
2744 "and so refers to the result variable. Use an "
2745 "explicit RESULT variable for direct recursion "
2746 "(12.5.2.1)", sym->name);
2747 return MATCH_ERROR;
2750 if (gfc_is_function_return_value (sym, gfc_current_ns))
2751 goto variable;
2753 if (sym->attr.entry
2754 && (sym->ns == gfc_current_ns
2755 || sym->ns == gfc_current_ns->parent))
2757 gfc_entry_list *el = NULL;
2759 for (el = sym->ns->entries; el; el = el->next)
2760 if (sym == el->sym)
2761 goto variable;
2765 if (gfc_matching_procptr_assignment)
2766 goto procptr0;
2768 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2769 goto function0;
2771 if (sym->attr.generic)
2772 goto generic_function;
2774 switch (sym->attr.flavor)
2776 case FL_VARIABLE:
2777 variable:
2778 e = gfc_get_expr ();
2780 e->expr_type = EXPR_VARIABLE;
2781 e->symtree = symtree;
2783 m = gfc_match_varspec (e, 0, false, true);
2784 break;
2786 case FL_PARAMETER:
2787 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2788 end up here. Unfortunately, sym->value->expr_type is set to
2789 EXPR_CONSTANT, and so the if () branch would be followed without
2790 the !sym->as check. */
2791 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2792 e = gfc_copy_expr (sym->value);
2793 else
2795 e = gfc_get_expr ();
2796 e->expr_type = EXPR_VARIABLE;
2799 e->symtree = symtree;
2800 m = gfc_match_varspec (e, 0, false, true);
2802 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2803 break;
2805 /* Variable array references to derived type parameters cause
2806 all sorts of headaches in simplification. Treating such
2807 expressions as variable works just fine for all array
2808 references. */
2809 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2811 for (ref = e->ref; ref; ref = ref->next)
2812 if (ref->type == REF_ARRAY)
2813 break;
2815 if (ref == NULL || ref->u.ar.type == AR_FULL)
2816 break;
2818 ref = e->ref;
2819 e->ref = NULL;
2820 gfc_free_expr (e);
2821 e = gfc_get_expr ();
2822 e->expr_type = EXPR_VARIABLE;
2823 e->symtree = symtree;
2824 e->ref = ref;
2827 break;
2829 case FL_DERIVED:
2830 sym = gfc_use_derived (sym);
2831 if (sym == NULL)
2832 m = MATCH_ERROR;
2833 else
2834 goto generic_function;
2835 break;
2837 /* If we're here, then the name is known to be the name of a
2838 procedure, yet it is not sure to be the name of a function. */
2839 case FL_PROCEDURE:
2841 /* Procedure Pointer Assignments. */
2842 procptr0:
2843 if (gfc_matching_procptr_assignment)
2845 gfc_gobble_whitespace ();
2846 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2847 /* Parse functions returning a procptr. */
2848 goto function0;
2850 e = gfc_get_expr ();
2851 e->expr_type = EXPR_VARIABLE;
2852 e->symtree = symtree;
2853 m = gfc_match_varspec (e, 0, false, true);
2854 if (!e->ref && sym->attr.flavor == FL_UNKNOWN
2855 && sym->ts.type == BT_UNKNOWN
2856 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
2858 m = MATCH_ERROR;
2859 break;
2861 break;
2864 if (sym->attr.subroutine)
2866 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2867 sym->name);
2868 m = MATCH_ERROR;
2869 break;
2872 /* At this point, the name has to be a non-statement function.
2873 If the name is the same as the current function being
2874 compiled, then we have a variable reference (to the function
2875 result) if the name is non-recursive. */
2877 st = gfc_enclosing_unit (NULL);
2879 if (st != NULL && st->state == COMP_FUNCTION
2880 && st->sym == sym
2881 && !sym->attr.recursive)
2883 e = gfc_get_expr ();
2884 e->symtree = symtree;
2885 e->expr_type = EXPR_VARIABLE;
2887 m = gfc_match_varspec (e, 0, false, true);
2888 break;
2891 /* Match a function reference. */
2892 function0:
2893 m = gfc_match_actual_arglist (0, &actual_arglist);
2894 if (m == MATCH_NO)
2896 if (sym->attr.proc == PROC_ST_FUNCTION)
2897 gfc_error ("Statement function '%s' requires argument list at %C",
2898 sym->name);
2899 else
2900 gfc_error ("Function '%s' requires an argument list at %C",
2901 sym->name);
2903 m = MATCH_ERROR;
2904 break;
2907 if (m != MATCH_YES)
2909 m = MATCH_ERROR;
2910 break;
2913 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2914 sym = symtree->n.sym;
2916 replace_hidden_procptr_result (&sym, &symtree);
2918 e = gfc_get_expr ();
2919 e->symtree = symtree;
2920 e->expr_type = EXPR_FUNCTION;
2921 e->value.function.actual = actual_arglist;
2922 e->where = gfc_current_locus;
2924 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
2925 && CLASS_DATA (sym)->as)
2926 e->rank = CLASS_DATA (sym)->as->rank;
2927 else if (sym->as != NULL)
2928 e->rank = sym->as->rank;
2930 if (!sym->attr.function
2931 && !gfc_add_function (&sym->attr, sym->name, NULL))
2933 m = MATCH_ERROR;
2934 break;
2937 /* Check here for the existence of at least one argument for the
2938 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2939 argument(s) given will be checked in gfc_iso_c_func_interface,
2940 during resolution of the function call. */
2941 if (sym->attr.is_iso_c == 1
2942 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2943 && (sym->intmod_sym_id == ISOCBINDING_LOC
2944 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2945 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2947 /* make sure we were given a param */
2948 if (actual_arglist == NULL)
2950 gfc_error ("Missing argument to '%s' at %C", sym->name);
2951 m = MATCH_ERROR;
2952 break;
2956 if (sym->result == NULL)
2957 sym->result = sym;
2959 m = MATCH_YES;
2960 break;
2962 case FL_UNKNOWN:
2964 /* Special case for derived type variables that get their types
2965 via an IMPLICIT statement. This can't wait for the
2966 resolution phase. */
2968 if (gfc_peek_ascii_char () == '%'
2969 && sym->ts.type == BT_UNKNOWN
2970 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2971 gfc_set_default_type (sym, 0, sym->ns);
2973 /* If the symbol has a (co)dimension attribute, the expression is a
2974 variable. */
2976 if (sym->attr.dimension || sym->attr.codimension)
2978 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
2980 m = MATCH_ERROR;
2981 break;
2984 e = gfc_get_expr ();
2985 e->symtree = symtree;
2986 e->expr_type = EXPR_VARIABLE;
2987 m = gfc_match_varspec (e, 0, false, true);
2988 break;
2991 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
2992 && (CLASS_DATA (sym)->attr.dimension
2993 || CLASS_DATA (sym)->attr.codimension))
2995 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
2997 m = MATCH_ERROR;
2998 break;
3001 e = gfc_get_expr ();
3002 e->symtree = symtree;
3003 e->expr_type = EXPR_VARIABLE;
3004 m = gfc_match_varspec (e, 0, false, true);
3005 break;
3008 /* Name is not an array, so we peek to see if a '(' implies a
3009 function call or a substring reference. Otherwise the
3010 variable is just a scalar. */
3012 gfc_gobble_whitespace ();
3013 if (gfc_peek_ascii_char () != '(')
3015 /* Assume a scalar variable */
3016 e = gfc_get_expr ();
3017 e->symtree = symtree;
3018 e->expr_type = EXPR_VARIABLE;
3020 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3022 m = MATCH_ERROR;
3023 break;
3026 /*FIXME:??? gfc_match_varspec does set this for us: */
3027 e->ts = sym->ts;
3028 m = gfc_match_varspec (e, 0, false, true);
3029 break;
3032 /* See if this is a function reference with a keyword argument
3033 as first argument. We do this because otherwise a spurious
3034 symbol would end up in the symbol table. */
3036 old_loc = gfc_current_locus;
3037 m2 = gfc_match (" ( %n =", argname);
3038 gfc_current_locus = old_loc;
3040 e = gfc_get_expr ();
3041 e->symtree = symtree;
3043 if (m2 != MATCH_YES)
3045 /* Try to figure out whether we're dealing with a character type.
3046 We're peeking ahead here, because we don't want to call
3047 match_substring if we're dealing with an implicitly typed
3048 non-character variable. */
3049 implicit_char = false;
3050 if (sym->ts.type == BT_UNKNOWN)
3052 ts = gfc_get_default_type (sym->name, NULL);
3053 if (ts->type == BT_CHARACTER)
3054 implicit_char = true;
3057 /* See if this could possibly be a substring reference of a name
3058 that we're not sure is a variable yet. */
3060 if ((implicit_char || sym->ts.type == BT_CHARACTER)
3061 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
3064 e->expr_type = EXPR_VARIABLE;
3066 if (sym->attr.flavor != FL_VARIABLE
3067 && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
3068 sym->name, NULL))
3070 m = MATCH_ERROR;
3071 break;
3074 if (sym->ts.type == BT_UNKNOWN
3075 && !gfc_set_default_type (sym, 1, NULL))
3077 m = MATCH_ERROR;
3078 break;
3081 e->ts = sym->ts;
3082 if (e->ref)
3083 e->ts.u.cl = NULL;
3084 m = MATCH_YES;
3085 break;
3089 /* Give up, assume we have a function. */
3091 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3092 sym = symtree->n.sym;
3093 e->expr_type = EXPR_FUNCTION;
3095 if (!sym->attr.function
3096 && !gfc_add_function (&sym->attr, sym->name, NULL))
3098 m = MATCH_ERROR;
3099 break;
3102 sym->result = sym;
3104 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3105 if (m == MATCH_NO)
3106 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
3108 if (m != MATCH_YES)
3110 m = MATCH_ERROR;
3111 break;
3114 /* If our new function returns a character, array or structure
3115 type, it might have subsequent references. */
3117 m = gfc_match_varspec (e, 0, false, true);
3118 if (m == MATCH_NO)
3119 m = MATCH_YES;
3121 break;
3123 generic_function:
3124 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3126 e = gfc_get_expr ();
3127 e->symtree = symtree;
3128 e->expr_type = EXPR_FUNCTION;
3130 if (sym->attr.flavor == FL_DERIVED)
3132 e->value.function.esym = sym;
3133 e->symtree->n.sym->attr.generic = 1;
3136 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3137 break;
3139 default:
3140 gfc_error ("Symbol at %C is not appropriate for an expression");
3141 return MATCH_ERROR;
3144 if (m == MATCH_YES)
3146 e->where = where;
3147 *result = e;
3149 else
3150 gfc_free_expr (e);
3152 return m;
3156 /* Match a variable, i.e. something that can be assigned to. This
3157 starts as a symbol, can be a structure component or an array
3158 reference. It can be a function if the function doesn't have a
3159 separate RESULT variable. If the symbol has not been previously
3160 seen, we assume it is a variable.
3162 This function is called by two interface functions:
3163 gfc_match_variable, which has host_flag = 1, and
3164 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3165 match of the symbol to the local scope. */
3167 static match
3168 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
3170 gfc_symbol *sym;
3171 gfc_symtree *st;
3172 gfc_expr *expr;
3173 locus where;
3174 match m;
3176 /* Since nothing has any business being an lvalue in a module
3177 specification block, an interface block or a contains section,
3178 we force the changed_symbols mechanism to work by setting
3179 host_flag to 0. This prevents valid symbols that have the name
3180 of keywords, such as 'end', being turned into variables by
3181 failed matching to assignments for, e.g., END INTERFACE. */
3182 if (gfc_current_state () == COMP_MODULE
3183 || gfc_current_state () == COMP_INTERFACE
3184 || gfc_current_state () == COMP_CONTAINS)
3185 host_flag = 0;
3187 where = gfc_current_locus;
3188 m = gfc_match_sym_tree (&st, host_flag);
3189 if (m != MATCH_YES)
3190 return m;
3192 sym = st->n.sym;
3194 /* If this is an implicit do loop index and implicitly typed,
3195 it should not be host associated. */
3196 m = check_for_implicit_index (&st, &sym);
3197 if (m != MATCH_YES)
3198 return m;
3200 sym->attr.implied_index = 0;
3202 gfc_set_sym_referenced (sym);
3203 switch (sym->attr.flavor)
3205 case FL_VARIABLE:
3206 /* Everything is alright. */
3207 break;
3209 case FL_UNKNOWN:
3211 sym_flavor flavor = FL_UNKNOWN;
3213 gfc_gobble_whitespace ();
3215 if (sym->attr.external || sym->attr.procedure
3216 || sym->attr.function || sym->attr.subroutine)
3217 flavor = FL_PROCEDURE;
3219 /* If it is not a procedure, is not typed and is host associated,
3220 we cannot give it a flavor yet. */
3221 else if (sym->ns == gfc_current_ns->parent
3222 && sym->ts.type == BT_UNKNOWN)
3223 break;
3225 /* These are definitive indicators that this is a variable. */
3226 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3227 || sym->attr.pointer || sym->as != NULL)
3228 flavor = FL_VARIABLE;
3230 if (flavor != FL_UNKNOWN
3231 && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
3232 return MATCH_ERROR;
3234 break;
3236 case FL_PARAMETER:
3237 if (equiv_flag)
3239 gfc_error ("Named constant at %C in an EQUIVALENCE");
3240 return MATCH_ERROR;
3242 /* Otherwise this is checked for and an error given in the
3243 variable definition context checks. */
3244 break;
3246 case FL_PROCEDURE:
3247 /* Check for a nonrecursive function result variable. */
3248 if (sym->attr.function
3249 && !sym->attr.external
3250 && sym->result == sym
3251 && (gfc_is_function_return_value (sym, gfc_current_ns)
3252 || (sym->attr.entry
3253 && sym->ns == gfc_current_ns)
3254 || (sym->attr.entry
3255 && sym->ns == gfc_current_ns->parent)))
3257 /* If a function result is a derived type, then the derived
3258 type may still have to be resolved. */
3260 if (sym->ts.type == BT_DERIVED
3261 && gfc_use_derived (sym->ts.u.derived) == NULL)
3262 return MATCH_ERROR;
3263 break;
3266 if (sym->attr.proc_pointer
3267 || replace_hidden_procptr_result (&sym, &st))
3268 break;
3270 /* Fall through to error */
3272 default:
3273 gfc_error ("'%s' at %C is not a variable", sym->name);
3274 return MATCH_ERROR;
3277 /* Special case for derived type variables that get their types
3278 via an IMPLICIT statement. This can't wait for the
3279 resolution phase. */
3282 gfc_namespace * implicit_ns;
3284 if (gfc_current_ns->proc_name == sym)
3285 implicit_ns = gfc_current_ns;
3286 else
3287 implicit_ns = sym->ns;
3289 if (gfc_peek_ascii_char () == '%'
3290 && sym->ts.type == BT_UNKNOWN
3291 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3292 gfc_set_default_type (sym, 0, implicit_ns);
3295 expr = gfc_get_expr ();
3297 expr->expr_type = EXPR_VARIABLE;
3298 expr->symtree = st;
3299 expr->ts = sym->ts;
3300 expr->where = where;
3302 /* Now see if we have to do more. */
3303 m = gfc_match_varspec (expr, equiv_flag, false, false);
3304 if (m != MATCH_YES)
3306 gfc_free_expr (expr);
3307 return m;
3310 *result = expr;
3311 return MATCH_YES;
3315 match
3316 gfc_match_variable (gfc_expr **result, int equiv_flag)
3318 return match_variable (result, equiv_flag, 1);
3322 match
3323 gfc_match_equiv_variable (gfc_expr **result)
3325 return match_variable (result, 1, 0);