]> git.ipfire.org Git - thirdparty/gcc.git/blame_incremental - gcc/fortran/primary.c
c99_classification_macros_c.cc: Add *-*-aix* to dg-xfail-if, dg-excess-errors.
[thirdparty/gcc.git] / gcc / fortran / primary.c
... / ...
CommitLineData
1/* Primary expression subroutines
2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
20
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"
30
31int matching_actual_arglist = 0;
32
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'. */
38
39static match
40match_kind_param (int *kind, int *is_iso_c)
41{
42 char name[GFC_MAX_SYMBOL_LEN + 1];
43 gfc_symbol *sym;
44 const char *p;
45 match m;
46
47 *is_iso_c = 0;
48
49 m = gfc_match_small_literal_int (kind, NULL);
50 if (m != MATCH_NO)
51 return m;
52
53 m = gfc_match_name (name);
54 if (m != MATCH_YES)
55 return m;
56
57 if (gfc_find_symbol (name, NULL, 1, &sym))
58 return MATCH_ERROR;
59
60 if (sym == NULL)
61 return MATCH_NO;
62
63 *is_iso_c = sym->attr.is_iso_c;
64
65 if (sym->attr.flavor != FL_PARAMETER)
66 return MATCH_NO;
67
68 if (sym->value == NULL)
69 return MATCH_NO;
70
71 p = gfc_extract_int (sym->value, kind);
72 if (p != NULL)
73 return MATCH_NO;
74
75 gfc_set_sym_referenced (sym);
76
77 if (*kind < 0)
78 return MATCH_NO;
79
80 return MATCH_YES;
81}
82
83
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'. */
91
92static int
93get_kind (int *is_iso_c)
94{
95 int kind;
96 match m;
97
98 *is_iso_c = 0;
99
100 if (gfc_match_char ('_') != MATCH_YES)
101 return -2;
102
103 m = match_kind_param (&kind, is_iso_c);
104 if (m == MATCH_NO)
105 gfc_error ("Missing kind-parameter at %C");
106
107 return (m == MATCH_YES) ? kind : -1;
108}
109
110
111/* Given a character and a radix, see if the character is a valid
112 digit in that radix. */
113
114int
115gfc_check_digit (char c, int radix)
116{
117 int r;
118
119 switch (radix)
120 {
121 case 2:
122 r = ('0' <= c && c <= '1');
123 break;
124
125 case 8:
126 r = ('0' <= c && c <= '7');
127 break;
128
129 case 10:
130 r = ('0' <= c && c <= '9');
131 break;
132
133 case 16:
134 r = ISXDIGIT (c);
135 break;
136
137 default:
138 gfc_internal_error ("gfc_check_digit(): bad radix");
139 }
140
141 return r;
142}
143
144
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. */
149
150static int
151match_digits (int signflag, int radix, char *buffer)
152{
153 locus old_loc;
154 int length;
155 char c;
156
157 length = 0;
158 c = gfc_next_ascii_char ();
159
160 if (signflag && (c == '+' || c == '-'))
161 {
162 if (buffer != NULL)
163 *buffer++ = c;
164 gfc_gobble_whitespace ();
165 c = gfc_next_ascii_char ();
166 length++;
167 }
168
169 if (!gfc_check_digit (c, radix))
170 return -1;
171
172 length++;
173 if (buffer != NULL)
174 *buffer++ = c;
175
176 for (;;)
177 {
178 old_loc = gfc_current_locus;
179 c = gfc_next_ascii_char ();
180
181 if (!gfc_check_digit (c, radix))
182 break;
183
184 if (buffer != NULL)
185 *buffer++ = c;
186 length++;
187 }
188
189 gfc_current_locus = old_loc;
190
191 return length;
192}
193
194
195/* Match an integer (digit string and optional kind).
196 A sign will be accepted if signflag is set. */
197
198static match
199match_integer_constant (gfc_expr **result, int signflag)
200{
201 int length, kind, is_iso_c;
202 locus old_loc;
203 char *buffer;
204 gfc_expr *e;
205
206 old_loc = gfc_current_locus;
207 gfc_gobble_whitespace ();
208
209 length = match_digits (signflag, 10, NULL);
210 gfc_current_locus = old_loc;
211 if (length == -1)
212 return MATCH_NO;
213
214 buffer = (char *) alloca (length + 1);
215 memset (buffer, '\0', length + 1);
216
217 gfc_gobble_whitespace ();
218
219 match_digits (signflag, 10, buffer);
220
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;
226
227 if (kind == 4 && flag_integer4_kind == 8)
228 kind = 8;
229
230 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
231 {
232 gfc_error ("Integer kind %d at %C not available", kind);
233 return MATCH_ERROR;
234 }
235
236 e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
237 e->ts.is_c_interop = is_iso_c;
238
239 if (gfc_range_check (e) != ARITH_OK)
240 {
241 gfc_error ("Integer too big for its kind at %C. This check can be "
242 "disabled with the option -fno-range-check");
243
244 gfc_free_expr (e);
245 return MATCH_ERROR;
246 }
247
248 *result = e;
249 return MATCH_YES;
250}
251
252
253/* Match a Hollerith constant. */
254
255static match
256match_hollerith_constant (gfc_expr **result)
257{
258 locus old_loc;
259 gfc_expr *e = NULL;
260 const char *msg;
261 int num, pad;
262 int i;
263
264 old_loc = gfc_current_locus;
265 gfc_gobble_whitespace ();
266
267 if (match_integer_constant (&e, 0) == MATCH_YES
268 && gfc_match_char ('h') == MATCH_YES)
269 {
270 if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
271 goto cleanup;
272
273 msg = gfc_extract_int (e, &num);
274 if (msg != NULL)
275 {
276 gfc_error (msg);
277 goto cleanup;
278 }
279 if (num == 0)
280 {
281 gfc_error ("Invalid Hollerith constant: %L must contain at least "
282 "one character", &old_loc);
283 goto cleanup;
284 }
285 if (e->ts.kind != gfc_default_integer_kind)
286 {
287 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
288 "should be default", &old_loc);
289 goto cleanup;
290 }
291 else
292 {
293 gfc_free_expr (e);
294 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
295 &gfc_current_locus);
296
297 /* Calculate padding needed to fit default integer memory. */
298 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
299
300 e->representation.string = XCNEWVEC (char, num + pad + 1);
301
302 for (i = 0; i < num; i++)
303 {
304 gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
305 if (! gfc_wide_fits_in_byte (c))
306 {
307 gfc_error ("Invalid Hollerith constant at %L contains a "
308 "wide character", &old_loc);
309 goto cleanup;
310 }
311
312 e->representation.string[i] = (unsigned char) c;
313 }
314
315 /* Now pad with blanks and end with a null char. */
316 for (i = 0; i < pad; i++)
317 e->representation.string[num + i] = ' ';
318
319 e->representation.string[num + i] = '\0';
320 e->representation.length = num + pad;
321 e->ts.u.pad = pad;
322
323 *result = e;
324 return MATCH_YES;
325 }
326 }
327
328 gfc_free_expr (e);
329 gfc_current_locus = old_loc;
330 return MATCH_NO;
331
332cleanup:
333 gfc_free_expr (e);
334 return MATCH_ERROR;
335}
336
337
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. */
343
344static match
345match_boz_constant (gfc_expr **result)
346{
347 int radix, length, x_hex, kind;
348 locus old_loc, start_loc;
349 char *buffer, post, delim;
350 gfc_expr *e;
351
352 start_loc = old_loc = gfc_current_locus;
353 gfc_gobble_whitespace ();
354
355 x_hex = 0;
356 switch (post = gfc_next_ascii_char ())
357 {
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;
382 }
383
384 /* No whitespace allowed here. */
385
386 if (post == 0)
387 delim = gfc_next_ascii_char ();
388
389 if (delim != '\'' && delim != '\"')
390 goto backup;
391
392 if (x_hex
393 && (!gfc_notify_std(GFC_STD_GNU, "Hexadecimal "
394 "constant at %C uses non-standard syntax")))
395 return MATCH_ERROR;
396
397 old_loc = gfc_current_locus;
398
399 length = match_digits (0, radix, NULL);
400 if (length == -1)
401 {
402 gfc_error ("Empty set of digits in BOZ constant at %C");
403 return MATCH_ERROR;
404 }
405
406 if (gfc_next_ascii_char () != delim)
407 {
408 gfc_error ("Illegal character in BOZ constant at %C");
409 return MATCH_ERROR;
410 }
411
412 if (post == 1)
413 {
414 switch (gfc_next_ascii_char ())
415 {
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;
429 }
430
431 if (!gfc_notify_std (GFC_STD_GNU, "BOZ constant "
432 "at %C uses non-standard postfix syntax"))
433 return MATCH_ERROR;
434 }
435
436 gfc_current_locus = old_loc;
437
438 buffer = (char *) alloca (length + 1);
439 memset (buffer, '\0', length + 1);
440
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. */
445
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." */
452
453 kind = gfc_max_integer_kind;
454 e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
455
456 /* Mark as boz variable. */
457 e->is_boz = 1;
458
459 if (gfc_range_check (e) != ARITH_OK)
460 {
461 gfc_error ("Integer too big for integer kind %i at %C", kind);
462 gfc_free_expr (e);
463 return MATCH_ERROR;
464 }
465
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;
470
471 *result = e;
472 return MATCH_YES;
473
474backup:
475 gfc_current_locus = start_loc;
476 return MATCH_NO;
477}
478
479
480/* Match a real constant of some sort. Allow a signed constant if signflag
481 is nonzero. */
482
483static match
484match_real_constant (gfc_expr **result, int signflag)
485{
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;
491
492 old_loc = gfc_current_locus;
493 gfc_gobble_whitespace ();
494
495 e = NULL;
496
497 count = 0;
498 seen_dp = 0;
499 seen_digits = 0;
500 exp_char = ' ';
501 negate = FALSE;
502
503 c = gfc_next_ascii_char ();
504 if (signflag && (c == '+' || c == '-'))
505 {
506 if (c == '-')
507 negate = TRUE;
508
509 gfc_gobble_whitespace ();
510 c = gfc_next_ascii_char ();
511 }
512
513 /* Scan significand. */
514 for (;; c = gfc_next_ascii_char (), count++)
515 {
516 if (c == '.')
517 {
518 if (seen_dp)
519 goto done;
520
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 ();
525
526 if (c == 'e' || c == 'd' || c == 'q')
527 {
528 c = gfc_next_ascii_char ();
529 if (c == '.')
530 goto done; /* Operator named .e. or .d. */
531 }
532
533 if (ISALPHA (c))
534 goto done; /* Distinguish 1.e9 from 1.eq.2 */
535
536 gfc_current_locus = temp_loc;
537 seen_dp = 1;
538 continue;
539 }
540
541 if (ISDIGIT (c))
542 {
543 seen_digits = 1;
544 continue;
545 }
546
547 break;
548 }
549
550 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
551 goto done;
552 exp_char = c;
553
554
555 if (c == 'q')
556 {
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 (warn_real_q_constant)
561 gfc_warning (OPT_Wreal_q_constant,
562 "Extension: exponent-letter %<q%> in real-literal-constant "
563 "at %C");
564 }
565
566 /* Scan exponent. */
567 c = gfc_next_ascii_char ();
568 count++;
569
570 if (c == '+' || c == '-')
571 { /* optional sign */
572 c = gfc_next_ascii_char ();
573 count++;
574 }
575
576 if (!ISDIGIT (c))
577 {
578 gfc_error ("Missing exponent in real number at %C");
579 return MATCH_ERROR;
580 }
581
582 while (ISDIGIT (c))
583 {
584 c = gfc_next_ascii_char ();
585 count++;
586 }
587
588done:
589 /* Check that we have a numeric constant. */
590 if (!seen_digits || (!seen_dp && exp_char == ' '))
591 {
592 gfc_current_locus = old_loc;
593 return MATCH_NO;
594 }
595
596 /* Convert the number. */
597 gfc_current_locus = old_loc;
598 gfc_gobble_whitespace ();
599
600 buffer = (char *) alloca (count + 1);
601 memset (buffer, '\0', count + 1);
602
603 p = buffer;
604 c = gfc_next_ascii_char ();
605 if (c == '+' || c == '-')
606 {
607 gfc_gobble_whitespace ();
608 c = gfc_next_ascii_char ();
609 }
610
611 /* Hack for mpfr_set_str(). */
612 for (;;)
613 {
614 if (c == 'd' || c == 'q')
615 *p = 'e';
616 else
617 *p = c;
618 p++;
619 if (--count == 0)
620 break;
621
622 c = gfc_next_ascii_char ();
623 }
624
625 kind = get_kind (&is_iso_c);
626 if (kind == -1)
627 goto cleanup;
628
629 switch (exp_char)
630 {
631 case 'd':
632 if (kind != -2)
633 {
634 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
635 "kind");
636 goto cleanup;
637 }
638 kind = gfc_default_double_kind;
639
640 if (kind == 4)
641 {
642 if (flag_real4_kind == 8)
643 kind = 8;
644 if (flag_real4_kind == 10)
645 kind = 10;
646 if (flag_real4_kind == 16)
647 kind = 16;
648 }
649
650 if (kind == 8)
651 {
652 if (flag_real8_kind == 4)
653 kind = 4;
654 if (flag_real8_kind == 10)
655 kind = 10;
656 if (flag_real8_kind == 16)
657 kind = 16;
658 }
659 break;
660
661 case 'q':
662 if (kind != -2)
663 {
664 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
665 "kind");
666 goto cleanup;
667 }
668
669 /* The maximum possible real kind type parameter is 16. First, try
670 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
671 extended precision. If neither value works, just given up. */
672 kind = 16;
673 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
674 {
675 kind = 10;
676 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
677 {
678 gfc_error ("Invalid exponent-letter %<q%> in "
679 "real-literal-constant at %C");
680 goto cleanup;
681 }
682 }
683 break;
684
685 default:
686 if (kind == -2)
687 kind = gfc_default_real_kind;
688
689 if (kind == 4)
690 {
691 if (flag_real4_kind == 8)
692 kind = 8;
693 if (flag_real4_kind == 10)
694 kind = 10;
695 if (flag_real4_kind == 16)
696 kind = 16;
697 }
698
699 if (kind == 8)
700 {
701 if (flag_real8_kind == 4)
702 kind = 4;
703 if (flag_real8_kind == 10)
704 kind = 10;
705 if (flag_real8_kind == 16)
706 kind = 16;
707 }
708
709 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
710 {
711 gfc_error ("Invalid real kind %d at %C", kind);
712 goto cleanup;
713 }
714 }
715
716 e = gfc_convert_real (buffer, kind, &gfc_current_locus);
717 if (negate)
718 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
719 e->ts.is_c_interop = is_iso_c;
720
721 switch (gfc_range_check (e))
722 {
723 case ARITH_OK:
724 break;
725 case ARITH_OVERFLOW:
726 gfc_error ("Real constant overflows its kind at %C");
727 goto cleanup;
728
729 case ARITH_UNDERFLOW:
730 if (warn_underflow)
731 gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C");
732 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
733 break;
734
735 default:
736 gfc_internal_error ("gfc_range_check() returned bad value");
737 }
738
739 *result = e;
740 return MATCH_YES;
741
742cleanup:
743 gfc_free_expr (e);
744 return MATCH_ERROR;
745}
746
747
748/* Match a substring reference. */
749
750static match
751match_substring (gfc_charlen *cl, int init, gfc_ref **result)
752{
753 gfc_expr *start, *end;
754 locus old_loc;
755 gfc_ref *ref;
756 match m;
757
758 start = NULL;
759 end = NULL;
760
761 old_loc = gfc_current_locus;
762
763 m = gfc_match_char ('(');
764 if (m != MATCH_YES)
765 return MATCH_NO;
766
767 if (gfc_match_char (':') != MATCH_YES)
768 {
769 if (init)
770 m = gfc_match_init_expr (&start);
771 else
772 m = gfc_match_expr (&start);
773
774 if (m != MATCH_YES)
775 {
776 m = MATCH_NO;
777 goto cleanup;
778 }
779
780 m = gfc_match_char (':');
781 if (m != MATCH_YES)
782 goto cleanup;
783 }
784
785 if (gfc_match_char (')') != MATCH_YES)
786 {
787 if (init)
788 m = gfc_match_init_expr (&end);
789 else
790 m = gfc_match_expr (&end);
791
792 if (m == MATCH_NO)
793 goto syntax;
794 if (m == MATCH_ERROR)
795 goto cleanup;
796
797 m = gfc_match_char (')');
798 if (m == MATCH_NO)
799 goto syntax;
800 }
801
802 /* Optimize away the (:) reference. */
803 if (start == NULL && end == NULL)
804 ref = NULL;
805 else
806 {
807 ref = gfc_get_ref ();
808
809 ref->type = REF_SUBSTRING;
810 if (start == NULL)
811 start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
812 ref->u.ss.start = start;
813 if (end == NULL && cl)
814 end = gfc_copy_expr (cl->length);
815 ref->u.ss.end = end;
816 ref->u.ss.length = cl;
817 }
818
819 *result = ref;
820 return MATCH_YES;
821
822syntax:
823 gfc_error ("Syntax error in SUBSTRING specification at %C");
824 m = MATCH_ERROR;
825
826cleanup:
827 gfc_free_expr (start);
828 gfc_free_expr (end);
829
830 gfc_current_locus = old_loc;
831 return m;
832}
833
834
835/* Reads the next character of a string constant, taking care to
836 return doubled delimiters on the input as a single instance of
837 the delimiter.
838
839 Special return values for "ret" argument are:
840 -1 End of the string, as determined by the delimiter
841 -2 Unterminated string detected
842
843 Backslash codes are also expanded at this time. */
844
845static gfc_char_t
846next_string_char (gfc_char_t delimiter, int *ret)
847{
848 locus old_locus;
849 gfc_char_t c;
850
851 c = gfc_next_char_literal (INSTRING_WARN);
852 *ret = 0;
853
854 if (c == '\n')
855 {
856 *ret = -2;
857 return 0;
858 }
859
860 if (flag_backslash && c == '\\')
861 {
862 old_locus = gfc_current_locus;
863
864 if (gfc_match_special_char (&c) == MATCH_NO)
865 gfc_current_locus = old_locus;
866
867 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
868 gfc_warning ("Extension: backslash character at %C");
869 }
870
871 if (c != delimiter)
872 return c;
873
874 old_locus = gfc_current_locus;
875 c = gfc_next_char_literal (NONSTRING);
876
877 if (c == delimiter)
878 return c;
879 gfc_current_locus = old_locus;
880
881 *ret = -1;
882 return 0;
883}
884
885
886/* Special case of gfc_match_name() that matches a parameter kind name
887 before a string constant. This takes case of the weird but legal
888 case of:
889
890 kind_____'string'
891
892 where kind____ is a parameter. gfc_match_name() will happily slurp
893 up all the underscores, which leads to problems. If we return
894 MATCH_YES, the parse pointer points to the final underscore, which
895 is not part of the name. We never return MATCH_ERROR-- errors in
896 the name will be detected later. */
897
898static match
899match_charkind_name (char *name)
900{
901 locus old_loc;
902 char c, peek;
903 int len;
904
905 gfc_gobble_whitespace ();
906 c = gfc_next_ascii_char ();
907 if (!ISALPHA (c))
908 return MATCH_NO;
909
910 *name++ = c;
911 len = 1;
912
913 for (;;)
914 {
915 old_loc = gfc_current_locus;
916 c = gfc_next_ascii_char ();
917
918 if (c == '_')
919 {
920 peek = gfc_peek_ascii_char ();
921
922 if (peek == '\'' || peek == '\"')
923 {
924 gfc_current_locus = old_loc;
925 *name = '\0';
926 return MATCH_YES;
927 }
928 }
929
930 if (!ISALNUM (c)
931 && c != '_'
932 && (c != '$' || !flag_dollar_ok))
933 break;
934
935 *name++ = c;
936 if (++len > GFC_MAX_SYMBOL_LEN)
937 break;
938 }
939
940 return MATCH_NO;
941}
942
943
944/* See if the current input matches a character constant. Lots of
945 contortions have to be done to match the kind parameter which comes
946 before the actual string. The main consideration is that we don't
947 want to error out too quickly. For example, we don't actually do
948 any validation of the kinds until we have actually seen a legal
949 delimiter. Using match_kind_param() generates errors too quickly. */
950
951static match
952match_string_constant (gfc_expr **result)
953{
954 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
955 int i, kind, length, save_warn_ampersand, ret;
956 locus old_locus, start_locus;
957 gfc_symbol *sym;
958 gfc_expr *e;
959 const char *q;
960 match m;
961 gfc_char_t c, delimiter, *p;
962
963 old_locus = gfc_current_locus;
964
965 gfc_gobble_whitespace ();
966
967 c = gfc_next_char ();
968 if (c == '\'' || c == '"')
969 {
970 kind = gfc_default_character_kind;
971 start_locus = gfc_current_locus;
972 goto got_delim;
973 }
974
975 if (gfc_wide_is_digit (c))
976 {
977 kind = 0;
978
979 while (gfc_wide_is_digit (c))
980 {
981 kind = kind * 10 + c - '0';
982 if (kind > 9999999)
983 goto no_match;
984 c = gfc_next_char ();
985 }
986
987 }
988 else
989 {
990 gfc_current_locus = old_locus;
991
992 m = match_charkind_name (name);
993 if (m != MATCH_YES)
994 goto no_match;
995
996 if (gfc_find_symbol (name, NULL, 1, &sym)
997 || sym == NULL
998 || sym->attr.flavor != FL_PARAMETER)
999 goto no_match;
1000
1001 kind = -1;
1002 c = gfc_next_char ();
1003 }
1004
1005 if (c == ' ')
1006 {
1007 gfc_gobble_whitespace ();
1008 c = gfc_next_char ();
1009 }
1010
1011 if (c != '_')
1012 goto no_match;
1013
1014 gfc_gobble_whitespace ();
1015
1016 c = gfc_next_char ();
1017 if (c != '\'' && c != '"')
1018 goto no_match;
1019
1020 start_locus = gfc_current_locus;
1021
1022 if (kind == -1)
1023 {
1024 q = gfc_extract_int (sym->value, &kind);
1025 if (q != NULL)
1026 {
1027 gfc_error (q);
1028 return MATCH_ERROR;
1029 }
1030 gfc_set_sym_referenced (sym);
1031 }
1032
1033 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1034 {
1035 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
1036 return MATCH_ERROR;
1037 }
1038
1039got_delim:
1040 /* Scan the string into a block of memory by first figuring out how
1041 long it is, allocating the structure, then re-reading it. This
1042 isn't particularly efficient, but string constants aren't that
1043 common in most code. TODO: Use obstacks? */
1044
1045 delimiter = c;
1046 length = 0;
1047
1048 for (;;)
1049 {
1050 c = next_string_char (delimiter, &ret);
1051 if (ret == -1)
1052 break;
1053 if (ret == -2)
1054 {
1055 gfc_current_locus = start_locus;
1056 gfc_error ("Unterminated character constant beginning at %C");
1057 return MATCH_ERROR;
1058 }
1059
1060 length++;
1061 }
1062
1063 /* Peek at the next character to see if it is a b, o, z, or x for the
1064 postfixed BOZ literal constants. */
1065 peek = gfc_peek_ascii_char ();
1066 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
1067 goto no_match;
1068
1069 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
1070
1071 gfc_current_locus = start_locus;
1072
1073 /* We disable the warning for the following loop as the warning has already
1074 been printed in the loop above. */
1075 save_warn_ampersand = warn_ampersand;
1076 warn_ampersand = false;
1077
1078 p = e->value.character.string;
1079 for (i = 0; i < length; i++)
1080 {
1081 c = next_string_char (delimiter, &ret);
1082
1083 if (!gfc_check_character_range (c, kind))
1084 {
1085 gfc_free_expr (e);
1086 gfc_error ("Character %qs in string at %C is not representable "
1087 "in character kind %d", gfc_print_wide_char (c), kind);
1088 return MATCH_ERROR;
1089 }
1090
1091 *p++ = c;
1092 }
1093
1094 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1095 warn_ampersand = save_warn_ampersand;
1096
1097 next_string_char (delimiter, &ret);
1098 if (ret != -1)
1099 gfc_internal_error ("match_string_constant(): Delimiter not found");
1100
1101 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1102 e->expr_type = EXPR_SUBSTRING;
1103
1104 *result = e;
1105
1106 return MATCH_YES;
1107
1108no_match:
1109 gfc_current_locus = old_locus;
1110 return MATCH_NO;
1111}
1112
1113
1114/* Match a .true. or .false. Returns 1 if a .true. was found,
1115 0 if a .false. was found, and -1 otherwise. */
1116static int
1117match_logical_constant_string (void)
1118{
1119 locus orig_loc = gfc_current_locus;
1120
1121 gfc_gobble_whitespace ();
1122 if (gfc_next_ascii_char () == '.')
1123 {
1124 char ch = gfc_next_ascii_char ();
1125 if (ch == 'f')
1126 {
1127 if (gfc_next_ascii_char () == 'a'
1128 && gfc_next_ascii_char () == 'l'
1129 && gfc_next_ascii_char () == 's'
1130 && gfc_next_ascii_char () == 'e'
1131 && gfc_next_ascii_char () == '.')
1132 /* Matched ".false.". */
1133 return 0;
1134 }
1135 else if (ch == 't')
1136 {
1137 if (gfc_next_ascii_char () == 'r'
1138 && gfc_next_ascii_char () == 'u'
1139 && gfc_next_ascii_char () == 'e'
1140 && gfc_next_ascii_char () == '.')
1141 /* Matched ".true.". */
1142 return 1;
1143 }
1144 }
1145 gfc_current_locus = orig_loc;
1146 return -1;
1147}
1148
1149/* Match a .true. or .false. */
1150
1151static match
1152match_logical_constant (gfc_expr **result)
1153{
1154 gfc_expr *e;
1155 int i, kind, is_iso_c;
1156
1157 i = match_logical_constant_string ();
1158 if (i == -1)
1159 return MATCH_NO;
1160
1161 kind = get_kind (&is_iso_c);
1162 if (kind == -1)
1163 return MATCH_ERROR;
1164 if (kind == -2)
1165 kind = gfc_default_logical_kind;
1166
1167 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1168 {
1169 gfc_error ("Bad kind for logical constant at %C");
1170 return MATCH_ERROR;
1171 }
1172
1173 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1174 e->ts.is_c_interop = is_iso_c;
1175
1176 *result = e;
1177 return MATCH_YES;
1178}
1179
1180
1181/* Match a real or imaginary part of a complex constant that is a
1182 symbolic constant. */
1183
1184static match
1185match_sym_complex_part (gfc_expr **result)
1186{
1187 char name[GFC_MAX_SYMBOL_LEN + 1];
1188 gfc_symbol *sym;
1189 gfc_expr *e;
1190 match m;
1191
1192 m = gfc_match_name (name);
1193 if (m != MATCH_YES)
1194 return m;
1195
1196 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1197 return MATCH_NO;
1198
1199 if (sym->attr.flavor != FL_PARAMETER)
1200 {
1201 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1202 return MATCH_ERROR;
1203 }
1204
1205 if (!gfc_numeric_ts (&sym->value->ts))
1206 {
1207 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1208 return MATCH_ERROR;
1209 }
1210
1211 if (sym->value->rank != 0)
1212 {
1213 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1214 return MATCH_ERROR;
1215 }
1216
1217 if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
1218 "complex constant at %C"))
1219 return MATCH_ERROR;
1220
1221 switch (sym->value->ts.type)
1222 {
1223 case BT_REAL:
1224 e = gfc_copy_expr (sym->value);
1225 break;
1226
1227 case BT_COMPLEX:
1228 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1229 if (e == NULL)
1230 goto error;
1231 break;
1232
1233 case BT_INTEGER:
1234 e = gfc_int2real (sym->value, gfc_default_real_kind);
1235 if (e == NULL)
1236 goto error;
1237 break;
1238
1239 default:
1240 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1241 }
1242
1243 *result = e; /* e is a scalar, real, constant expression. */
1244 return MATCH_YES;
1245
1246error:
1247 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1248 return MATCH_ERROR;
1249}
1250
1251
1252/* Match a real or imaginary part of a complex number. */
1253
1254static match
1255match_complex_part (gfc_expr **result)
1256{
1257 match m;
1258
1259 m = match_sym_complex_part (result);
1260 if (m != MATCH_NO)
1261 return m;
1262
1263 m = match_real_constant (result, 1);
1264 if (m != MATCH_NO)
1265 return m;
1266
1267 return match_integer_constant (result, 1);
1268}
1269
1270
1271/* Try to match a complex constant. */
1272
1273static match
1274match_complex_constant (gfc_expr **result)
1275{
1276 gfc_expr *e, *real, *imag;
1277 gfc_error_buf old_error_1;
1278 output_buffer old_error;
1279 gfc_typespec target;
1280 locus old_loc;
1281 int kind;
1282 match m;
1283
1284 old_loc = gfc_current_locus;
1285 real = imag = e = NULL;
1286
1287 m = gfc_match_char ('(');
1288 if (m != MATCH_YES)
1289 return m;
1290
1291 gfc_push_error (&old_error, &old_error_1);
1292
1293 m = match_complex_part (&real);
1294 if (m == MATCH_NO)
1295 {
1296 gfc_free_error (&old_error, &old_error_1);
1297 goto cleanup;
1298 }
1299
1300 if (gfc_match_char (',') == MATCH_NO)
1301 {
1302 gfc_pop_error (&old_error, &old_error_1);
1303 m = MATCH_NO;
1304 goto cleanup;
1305 }
1306
1307 /* If m is error, then something was wrong with the real part and we
1308 assume we have a complex constant because we've seen the ','. An
1309 ambiguous case here is the start of an iterator list of some
1310 sort. These sort of lists are matched prior to coming here. */
1311
1312 if (m == MATCH_ERROR)
1313 {
1314 gfc_free_error (&old_error, &old_error_1);
1315 goto cleanup;
1316 }
1317 gfc_pop_error (&old_error, &old_error_1);
1318
1319 m = match_complex_part (&imag);
1320 if (m == MATCH_NO)
1321 goto syntax;
1322 if (m == MATCH_ERROR)
1323 goto cleanup;
1324
1325 m = gfc_match_char (')');
1326 if (m == MATCH_NO)
1327 {
1328 /* Give the matcher for implied do-loops a chance to run. This
1329 yields a much saner error message for (/ (i, 4=i, 6) /). */
1330 if (gfc_peek_ascii_char () == '=')
1331 {
1332 m = MATCH_ERROR;
1333 goto cleanup;
1334 }
1335 else
1336 goto syntax;
1337 }
1338
1339 if (m == MATCH_ERROR)
1340 goto cleanup;
1341
1342 /* Decide on the kind of this complex number. */
1343 if (real->ts.type == BT_REAL)
1344 {
1345 if (imag->ts.type == BT_REAL)
1346 kind = gfc_kind_max (real, imag);
1347 else
1348 kind = real->ts.kind;
1349 }
1350 else
1351 {
1352 if (imag->ts.type == BT_REAL)
1353 kind = imag->ts.kind;
1354 else
1355 kind = gfc_default_real_kind;
1356 }
1357 gfc_clear_ts (&target);
1358 target.type = BT_REAL;
1359 target.kind = kind;
1360
1361 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1362 gfc_convert_type (real, &target, 2);
1363 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1364 gfc_convert_type (imag, &target, 2);
1365
1366 e = gfc_convert_complex (real, imag, kind);
1367 e->where = gfc_current_locus;
1368
1369 gfc_free_expr (real);
1370 gfc_free_expr (imag);
1371
1372 *result = e;
1373 return MATCH_YES;
1374
1375syntax:
1376 gfc_error ("Syntax error in COMPLEX constant at %C");
1377 m = MATCH_ERROR;
1378
1379cleanup:
1380 gfc_free_expr (e);
1381 gfc_free_expr (real);
1382 gfc_free_expr (imag);
1383 gfc_current_locus = old_loc;
1384
1385 return m;
1386}
1387
1388
1389/* Match constants in any of several forms. Returns nonzero for a
1390 match, zero for no match. */
1391
1392match
1393gfc_match_literal_constant (gfc_expr **result, int signflag)
1394{
1395 match m;
1396
1397 m = match_complex_constant (result);
1398 if (m != MATCH_NO)
1399 return m;
1400
1401 m = match_string_constant (result);
1402 if (m != MATCH_NO)
1403 return m;
1404
1405 m = match_boz_constant (result);
1406 if (m != MATCH_NO)
1407 return m;
1408
1409 m = match_real_constant (result, signflag);
1410 if (m != MATCH_NO)
1411 return m;
1412
1413 m = match_hollerith_constant (result);
1414 if (m != MATCH_NO)
1415 return m;
1416
1417 m = match_integer_constant (result, signflag);
1418 if (m != MATCH_NO)
1419 return m;
1420
1421 m = match_logical_constant (result);
1422 if (m != MATCH_NO)
1423 return m;
1424
1425 return MATCH_NO;
1426}
1427
1428
1429/* This checks if a symbol is the return value of an encompassing function.
1430 Function nesting can be maximally two levels deep, but we may have
1431 additional local namespaces like BLOCK etc. */
1432
1433bool
1434gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1435{
1436 if (!sym->attr.function || (sym->result != sym))
1437 return false;
1438 while (ns)
1439 {
1440 if (ns->proc_name == sym)
1441 return true;
1442 ns = ns->parent;
1443 }
1444 return false;
1445}
1446
1447
1448/* Match a single actual argument value. An actual argument is
1449 usually an expression, but can also be a procedure name. If the
1450 argument is a single name, it is not always possible to tell
1451 whether the name is a dummy procedure or not. We treat these cases
1452 by creating an argument that looks like a dummy procedure and
1453 fixing things later during resolution. */
1454
1455static match
1456match_actual_arg (gfc_expr **result)
1457{
1458 char name[GFC_MAX_SYMBOL_LEN + 1];
1459 gfc_symtree *symtree;
1460 locus where, w;
1461 gfc_expr *e;
1462 char c;
1463
1464 gfc_gobble_whitespace ();
1465 where = gfc_current_locus;
1466
1467 switch (gfc_match_name (name))
1468 {
1469 case MATCH_ERROR:
1470 return MATCH_ERROR;
1471
1472 case MATCH_NO:
1473 break;
1474
1475 case MATCH_YES:
1476 w = gfc_current_locus;
1477 gfc_gobble_whitespace ();
1478 c = gfc_next_ascii_char ();
1479 gfc_current_locus = w;
1480
1481 if (c != ',' && c != ')')
1482 break;
1483
1484 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1485 break;
1486 /* Handle error elsewhere. */
1487
1488 /* Eliminate a couple of common cases where we know we don't
1489 have a function argument. */
1490 if (symtree == NULL)
1491 {
1492 gfc_get_sym_tree (name, NULL, &symtree, false);
1493 gfc_set_sym_referenced (symtree->n.sym);
1494 }
1495 else
1496 {
1497 gfc_symbol *sym;
1498
1499 sym = symtree->n.sym;
1500 gfc_set_sym_referenced (sym);
1501 if (sym->attr.flavor != FL_PROCEDURE
1502 && sym->attr.flavor != FL_UNKNOWN)
1503 break;
1504
1505 if (sym->attr.in_common && !sym->attr.proc_pointer)
1506 {
1507 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
1508 sym->name, &sym->declared_at))
1509 return MATCH_ERROR;
1510 break;
1511 }
1512
1513 /* If the symbol is a function with itself as the result and
1514 is being defined, then we have a variable. */
1515 if (sym->attr.function && sym->result == sym)
1516 {
1517 if (gfc_is_function_return_value (sym, gfc_current_ns))
1518 break;
1519
1520 if (sym->attr.entry
1521 && (sym->ns == gfc_current_ns
1522 || sym->ns == gfc_current_ns->parent))
1523 {
1524 gfc_entry_list *el = NULL;
1525
1526 for (el = sym->ns->entries; el; el = el->next)
1527 if (sym == el->sym)
1528 break;
1529
1530 if (el)
1531 break;
1532 }
1533 }
1534 }
1535
1536 e = gfc_get_expr (); /* Leave it unknown for now */
1537 e->symtree = symtree;
1538 e->expr_type = EXPR_VARIABLE;
1539 e->ts.type = BT_PROCEDURE;
1540 e->where = where;
1541
1542 *result = e;
1543 return MATCH_YES;
1544 }
1545
1546 gfc_current_locus = where;
1547 return gfc_match_expr (result);
1548}
1549
1550
1551/* Match a keyword argument. */
1552
1553static match
1554match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1555{
1556 char name[GFC_MAX_SYMBOL_LEN + 1];
1557 gfc_actual_arglist *a;
1558 locus name_locus;
1559 match m;
1560
1561 name_locus = gfc_current_locus;
1562 m = gfc_match_name (name);
1563
1564 if (m != MATCH_YES)
1565 goto cleanup;
1566 if (gfc_match_char ('=') != MATCH_YES)
1567 {
1568 m = MATCH_NO;
1569 goto cleanup;
1570 }
1571
1572 m = match_actual_arg (&actual->expr);
1573 if (m != MATCH_YES)
1574 goto cleanup;
1575
1576 /* Make sure this name has not appeared yet. */
1577
1578 if (name[0] != '\0')
1579 {
1580 for (a = base; a; a = a->next)
1581 if (a->name != NULL && strcmp (a->name, name) == 0)
1582 {
1583 gfc_error ("Keyword %qs at %C has already appeared in the "
1584 "current argument list", name);
1585 return MATCH_ERROR;
1586 }
1587 }
1588
1589 actual->name = gfc_get_string (name);
1590 return MATCH_YES;
1591
1592cleanup:
1593 gfc_current_locus = name_locus;
1594 return m;
1595}
1596
1597
1598/* Match an argument list function, such as %VAL. */
1599
1600static match
1601match_arg_list_function (gfc_actual_arglist *result)
1602{
1603 char name[GFC_MAX_SYMBOL_LEN + 1];
1604 locus old_locus;
1605 match m;
1606
1607 old_locus = gfc_current_locus;
1608
1609 if (gfc_match_char ('%') != MATCH_YES)
1610 {
1611 m = MATCH_NO;
1612 goto cleanup;
1613 }
1614
1615 m = gfc_match ("%n (", name);
1616 if (m != MATCH_YES)
1617 goto cleanup;
1618
1619 if (name[0] != '\0')
1620 {
1621 switch (name[0])
1622 {
1623 case 'l':
1624 if (strncmp (name, "loc", 3) == 0)
1625 {
1626 result->name = "%LOC";
1627 break;
1628 }
1629 case 'r':
1630 if (strncmp (name, "ref", 3) == 0)
1631 {
1632 result->name = "%REF";
1633 break;
1634 }
1635 case 'v':
1636 if (strncmp (name, "val", 3) == 0)
1637 {
1638 result->name = "%VAL";
1639 break;
1640 }
1641 default:
1642 m = MATCH_ERROR;
1643 goto cleanup;
1644 }
1645 }
1646
1647 if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
1648 {
1649 m = MATCH_ERROR;
1650 goto cleanup;
1651 }
1652
1653 m = match_actual_arg (&result->expr);
1654 if (m != MATCH_YES)
1655 goto cleanup;
1656
1657 if (gfc_match_char (')') != MATCH_YES)
1658 {
1659 m = MATCH_NO;
1660 goto cleanup;
1661 }
1662
1663 return MATCH_YES;
1664
1665cleanup:
1666 gfc_current_locus = old_locus;
1667 return m;
1668}
1669
1670
1671/* Matches an actual argument list of a function or subroutine, from
1672 the opening parenthesis to the closing parenthesis. The argument
1673 list is assumed to allow keyword arguments because we don't know if
1674 the symbol associated with the procedure has an implicit interface
1675 or not. We make sure keywords are unique. If sub_flag is set,
1676 we're matching the argument list of a subroutine. */
1677
1678match
1679gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1680{
1681 gfc_actual_arglist *head, *tail;
1682 int seen_keyword;
1683 gfc_st_label *label;
1684 locus old_loc;
1685 match m;
1686
1687 *argp = tail = NULL;
1688 old_loc = gfc_current_locus;
1689
1690 seen_keyword = 0;
1691
1692 if (gfc_match_char ('(') == MATCH_NO)
1693 return (sub_flag) ? MATCH_YES : MATCH_NO;
1694
1695 if (gfc_match_char (')') == MATCH_YES)
1696 return MATCH_YES;
1697 head = NULL;
1698
1699 matching_actual_arglist++;
1700
1701 for (;;)
1702 {
1703 if (head == NULL)
1704 head = tail = gfc_get_actual_arglist ();
1705 else
1706 {
1707 tail->next = gfc_get_actual_arglist ();
1708 tail = tail->next;
1709 }
1710
1711 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1712 {
1713 m = gfc_match_st_label (&label);
1714 if (m == MATCH_NO)
1715 gfc_error ("Expected alternate return label at %C");
1716 if (m != MATCH_YES)
1717 goto cleanup;
1718
1719 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
1720 "at %C"))
1721 goto cleanup;
1722
1723 tail->label = label;
1724 goto next;
1725 }
1726
1727 /* After the first keyword argument is seen, the following
1728 arguments must also have keywords. */
1729 if (seen_keyword)
1730 {
1731 m = match_keyword_arg (tail, head);
1732
1733 if (m == MATCH_ERROR)
1734 goto cleanup;
1735 if (m == MATCH_NO)
1736 {
1737 gfc_error ("Missing keyword name in actual argument list at %C");
1738 goto cleanup;
1739 }
1740
1741 }
1742 else
1743 {
1744 /* Try an argument list function, like %VAL. */
1745 m = match_arg_list_function (tail);
1746 if (m == MATCH_ERROR)
1747 goto cleanup;
1748
1749 /* See if we have the first keyword argument. */
1750 if (m == MATCH_NO)
1751 {
1752 m = match_keyword_arg (tail, head);
1753 if (m == MATCH_YES)
1754 seen_keyword = 1;
1755 if (m == MATCH_ERROR)
1756 goto cleanup;
1757 }
1758
1759 if (m == MATCH_NO)
1760 {
1761 /* Try for a non-keyword argument. */
1762 m = match_actual_arg (&tail->expr);
1763 if (m == MATCH_ERROR)
1764 goto cleanup;
1765 if (m == MATCH_NO)
1766 goto syntax;
1767 }
1768 }
1769
1770
1771 next:
1772 if (gfc_match_char (')') == MATCH_YES)
1773 break;
1774 if (gfc_match_char (',') != MATCH_YES)
1775 goto syntax;
1776 }
1777
1778 *argp = head;
1779 matching_actual_arglist--;
1780 return MATCH_YES;
1781
1782syntax:
1783 gfc_error ("Syntax error in argument list at %C");
1784
1785cleanup:
1786 gfc_free_actual_arglist (head);
1787 gfc_current_locus = old_loc;
1788 matching_actual_arglist--;
1789 return MATCH_ERROR;
1790}
1791
1792
1793/* Used by gfc_match_varspec() to extend the reference list by one
1794 element. */
1795
1796static gfc_ref *
1797extend_ref (gfc_expr *primary, gfc_ref *tail)
1798{
1799 if (primary->ref == NULL)
1800 primary->ref = tail = gfc_get_ref ();
1801 else
1802 {
1803 if (tail == NULL)
1804 gfc_internal_error ("extend_ref(): Bad tail");
1805 tail->next = gfc_get_ref ();
1806 tail = tail->next;
1807 }
1808
1809 return tail;
1810}
1811
1812
1813/* Match any additional specifications associated with the current
1814 variable like member references or substrings. If equiv_flag is
1815 set we only match stuff that is allowed inside an EQUIVALENCE
1816 statement. sub_flag tells whether we expect a type-bound procedure found
1817 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1818 components, 'ppc_arg' determines whether the PPC may be called (with an
1819 argument list), or whether it may just be referred to as a pointer. */
1820
1821match
1822gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1823 bool ppc_arg)
1824{
1825 char name[GFC_MAX_SYMBOL_LEN + 1];
1826 gfc_ref *substring, *tail;
1827 gfc_component *component;
1828 gfc_symbol *sym = primary->symtree->n.sym;
1829 match m;
1830 bool unknown;
1831
1832 tail = NULL;
1833
1834 gfc_gobble_whitespace ();
1835
1836 if (gfc_peek_ascii_char () == '[')
1837 {
1838 if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
1839 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
1840 && CLASS_DATA (sym)->attr.dimension))
1841 {
1842 gfc_error ("Array section designator, e.g. '(:)', is required "
1843 "besides the coarray designator '[...]' at %C");
1844 return MATCH_ERROR;
1845 }
1846 if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
1847 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
1848 && !CLASS_DATA (sym)->attr.codimension))
1849 {
1850 gfc_error ("Coarray designator at %C but %qs is not a coarray",
1851 sym->name);
1852 return MATCH_ERROR;
1853 }
1854 }
1855
1856 /* For associate names, we may not yet know whether they are arrays or not.
1857 Thus if we have one and parentheses follow, we have to assume that it
1858 actually is one for now. The final decision will be made at
1859 resolution time, of course. */
1860 if (sym->assoc && gfc_peek_ascii_char () == '(')
1861 sym->attr.dimension = 1;
1862
1863 if ((equiv_flag && gfc_peek_ascii_char () == '(')
1864 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
1865 || (sym->attr.dimension && sym->ts.type != BT_CLASS
1866 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
1867 && !(gfc_matching_procptr_assignment
1868 && sym->attr.flavor == FL_PROCEDURE))
1869 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
1870 && (CLASS_DATA (sym)->attr.dimension
1871 || CLASS_DATA (sym)->attr.codimension)))
1872 {
1873 gfc_array_spec *as;
1874
1875 tail = extend_ref (primary, tail);
1876 tail->type = REF_ARRAY;
1877
1878 /* In EQUIVALENCE, we don't know yet whether we are seeing
1879 an array, character variable or array of character
1880 variables. We'll leave the decision till resolve time. */
1881
1882 if (equiv_flag)
1883 as = NULL;
1884 else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
1885 as = CLASS_DATA (sym)->as;
1886 else
1887 as = sym->as;
1888
1889 m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
1890 as ? as->corank : 0);
1891 if (m != MATCH_YES)
1892 return m;
1893
1894 gfc_gobble_whitespace ();
1895 if (equiv_flag && gfc_peek_ascii_char () == '(')
1896 {
1897 tail = extend_ref (primary, tail);
1898 tail->type = REF_ARRAY;
1899
1900 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
1901 if (m != MATCH_YES)
1902 return m;
1903 }
1904 }
1905
1906 primary->ts = sym->ts;
1907
1908 if (equiv_flag)
1909 return MATCH_YES;
1910
1911 if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1912 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1913 gfc_set_default_type (sym, 0, sym->ns);
1914
1915 if (sym->ts.type == BT_UNKNOWN && gfc_match_char ('%') == MATCH_YES)
1916 {
1917 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
1918 return MATCH_ERROR;
1919 }
1920 else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1921 && gfc_match_char ('%') == MATCH_YES)
1922 {
1923 gfc_error ("Unexpected %<%%%> for nonderived-type variable %qs at %C",
1924 sym->name);
1925 return MATCH_ERROR;
1926 }
1927
1928 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1929 || gfc_match_char ('%') != MATCH_YES)
1930 goto check_substring;
1931
1932 sym = sym->ts.u.derived;
1933
1934 for (;;)
1935 {
1936 bool t;
1937 gfc_symtree *tbp;
1938
1939 m = gfc_match_name (name);
1940 if (m == MATCH_NO)
1941 gfc_error ("Expected structure component name at %C");
1942 if (m != MATCH_YES)
1943 return MATCH_ERROR;
1944
1945 if (sym->f2k_derived)
1946 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1947 else
1948 tbp = NULL;
1949
1950 if (tbp)
1951 {
1952 gfc_symbol* tbp_sym;
1953
1954 if (!t)
1955 return MATCH_ERROR;
1956
1957 gcc_assert (!tail || !tail->next);
1958
1959 if (!(primary->expr_type == EXPR_VARIABLE
1960 || (primary->expr_type == EXPR_STRUCTURE
1961 && primary->symtree && primary->symtree->n.sym
1962 && primary->symtree->n.sym->attr.flavor)))
1963 return MATCH_ERROR;
1964
1965 if (tbp->n.tb->is_generic)
1966 tbp_sym = NULL;
1967 else
1968 tbp_sym = tbp->n.tb->u.specific->n.sym;
1969
1970 primary->expr_type = EXPR_COMPCALL;
1971 primary->value.compcall.tbp = tbp->n.tb;
1972 primary->value.compcall.name = tbp->name;
1973 primary->value.compcall.ignore_pass = 0;
1974 primary->value.compcall.assign = 0;
1975 primary->value.compcall.base_object = NULL;
1976 gcc_assert (primary->symtree->n.sym->attr.referenced);
1977 if (tbp_sym)
1978 primary->ts = tbp_sym->ts;
1979 else
1980 gfc_clear_ts (&primary->ts);
1981
1982 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1983 &primary->value.compcall.actual);
1984 if (m == MATCH_ERROR)
1985 return MATCH_ERROR;
1986 if (m == MATCH_NO)
1987 {
1988 if (sub_flag)
1989 primary->value.compcall.actual = NULL;
1990 else
1991 {
1992 gfc_error ("Expected argument list at %C");
1993 return MATCH_ERROR;
1994 }
1995 }
1996
1997 break;
1998 }
1999
2000 component = gfc_find_component (sym, name, false, false);
2001 if (component == NULL)
2002 return MATCH_ERROR;
2003
2004 tail = extend_ref (primary, tail);
2005 tail->type = REF_COMPONENT;
2006
2007 tail->u.c.component = component;
2008 tail->u.c.sym = sym;
2009
2010 primary->ts = component->ts;
2011
2012 if (component->attr.proc_pointer && ppc_arg)
2013 {
2014 /* Procedure pointer component call: Look for argument list. */
2015 m = gfc_match_actual_arglist (sub_flag,
2016 &primary->value.compcall.actual);
2017 if (m == MATCH_ERROR)
2018 return MATCH_ERROR;
2019
2020 if (m == MATCH_NO && !gfc_matching_ptr_assignment
2021 && !gfc_matching_procptr_assignment && !matching_actual_arglist)
2022 {
2023 gfc_error ("Procedure pointer component %qs requires an "
2024 "argument list at %C", component->name);
2025 return MATCH_ERROR;
2026 }
2027
2028 if (m == MATCH_YES)
2029 primary->expr_type = EXPR_PPC;
2030
2031 break;
2032 }
2033
2034 if (component->as != NULL && !component->attr.proc_pointer)
2035 {
2036 tail = extend_ref (primary, tail);
2037 tail->type = REF_ARRAY;
2038
2039 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
2040 component->as->corank);
2041 if (m != MATCH_YES)
2042 return m;
2043 }
2044 else if (component->ts.type == BT_CLASS && component->attr.class_ok
2045 && CLASS_DATA (component)->as && !component->attr.proc_pointer)
2046 {
2047 tail = extend_ref (primary, tail);
2048 tail->type = REF_ARRAY;
2049
2050 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
2051 equiv_flag,
2052 CLASS_DATA (component)->as->corank);
2053 if (m != MATCH_YES)
2054 return m;
2055 }
2056
2057 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
2058 || gfc_match_char ('%') != MATCH_YES)
2059 break;
2060
2061 sym = component->ts.u.derived;
2062 }
2063
2064check_substring:
2065 unknown = false;
2066 if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
2067 {
2068 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
2069 {
2070 gfc_set_default_type (sym, 0, sym->ns);
2071 primary->ts = sym->ts;
2072 unknown = true;
2073 }
2074 }
2075
2076 if (primary->ts.type == BT_CHARACTER)
2077 {
2078 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
2079 {
2080 case MATCH_YES:
2081 if (tail == NULL)
2082 primary->ref = substring;
2083 else
2084 tail->next = substring;
2085
2086 if (primary->expr_type == EXPR_CONSTANT)
2087 primary->expr_type = EXPR_SUBSTRING;
2088
2089 if (substring)
2090 primary->ts.u.cl = NULL;
2091
2092 break;
2093
2094 case MATCH_NO:
2095 if (unknown)
2096 {
2097 gfc_clear_ts (&primary->ts);
2098 gfc_clear_ts (&sym->ts);
2099 }
2100 break;
2101
2102 case MATCH_ERROR:
2103 return MATCH_ERROR;
2104 }
2105 }
2106
2107 /* F2008, C727. */
2108 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
2109 {
2110 gfc_error ("Coindexed procedure-pointer component at %C");
2111 return MATCH_ERROR;
2112 }
2113
2114 return MATCH_YES;
2115}
2116
2117
2118/* Given an expression that is a variable, figure out what the
2119 ultimate variable's type and attribute is, traversing the reference
2120 structures if necessary.
2121
2122 This subroutine is trickier than it looks. We start at the base
2123 symbol and store the attribute. Component references load a
2124 completely new attribute.
2125
2126 A couple of rules come into play. Subobjects of targets are always
2127 targets themselves. If we see a component that goes through a
2128 pointer, then the expression must also be a target, since the
2129 pointer is associated with something (if it isn't core will soon be
2130 dumped). If we see a full part or section of an array, the
2131 expression is also an array.
2132
2133 We can have at most one full array reference. */
2134
2135symbol_attribute
2136gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2137{
2138 int dimension, codimension, pointer, allocatable, target;
2139 symbol_attribute attr;
2140 gfc_ref *ref;
2141 gfc_symbol *sym;
2142 gfc_component *comp;
2143
2144 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2145 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2146
2147 sym = expr->symtree->n.sym;
2148 attr = sym->attr;
2149
2150 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2151 {
2152 dimension = CLASS_DATA (sym)->attr.dimension;
2153 codimension = CLASS_DATA (sym)->attr.codimension;
2154 pointer = CLASS_DATA (sym)->attr.class_pointer;
2155 allocatable = CLASS_DATA (sym)->attr.allocatable;
2156 }
2157 else
2158 {
2159 dimension = attr.dimension;
2160 codimension = attr.codimension;
2161 pointer = attr.pointer;
2162 allocatable = attr.allocatable;
2163 }
2164
2165 target = attr.target;
2166 if (pointer || attr.proc_pointer)
2167 target = 1;
2168
2169 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2170 *ts = sym->ts;
2171
2172 for (ref = expr->ref; ref; ref = ref->next)
2173 switch (ref->type)
2174 {
2175 case REF_ARRAY:
2176
2177 switch (ref->u.ar.type)
2178 {
2179 case AR_FULL:
2180 dimension = 1;
2181 break;
2182
2183 case AR_SECTION:
2184 allocatable = pointer = 0;
2185 dimension = 1;
2186 break;
2187
2188 case AR_ELEMENT:
2189 /* Handle coarrays. */
2190 if (ref->u.ar.dimen > 0)
2191 allocatable = pointer = 0;
2192 break;
2193
2194 case AR_UNKNOWN:
2195 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2196 }
2197
2198 break;
2199
2200 case REF_COMPONENT:
2201 comp = ref->u.c.component;
2202 attr = comp->attr;
2203 if (ts != NULL)
2204 {
2205 *ts = comp->ts;
2206 /* Don't set the string length if a substring reference
2207 follows. */
2208 if (ts->type == BT_CHARACTER
2209 && ref->next && ref->next->type == REF_SUBSTRING)
2210 ts->u.cl = NULL;
2211 }
2212
2213 if (comp->ts.type == BT_CLASS)
2214 {
2215 codimension = CLASS_DATA (comp)->attr.codimension;
2216 pointer = CLASS_DATA (comp)->attr.class_pointer;
2217 allocatable = CLASS_DATA (comp)->attr.allocatable;
2218 }
2219 else
2220 {
2221 codimension = comp->attr.codimension;
2222 pointer = comp->attr.pointer;
2223 allocatable = comp->attr.allocatable;
2224 }
2225 if (pointer || attr.proc_pointer)
2226 target = 1;
2227
2228 break;
2229
2230 case REF_SUBSTRING:
2231 allocatable = pointer = 0;
2232 break;
2233 }
2234
2235 attr.dimension = dimension;
2236 attr.codimension = codimension;
2237 attr.pointer = pointer;
2238 attr.allocatable = allocatable;
2239 attr.target = target;
2240 attr.save = sym->attr.save;
2241
2242 return attr;
2243}
2244
2245
2246/* Return the attribute from a general expression. */
2247
2248symbol_attribute
2249gfc_expr_attr (gfc_expr *e)
2250{
2251 symbol_attribute attr;
2252
2253 switch (e->expr_type)
2254 {
2255 case EXPR_VARIABLE:
2256 attr = gfc_variable_attr (e, NULL);
2257 break;
2258
2259 case EXPR_FUNCTION:
2260 gfc_clear_attr (&attr);
2261
2262 if (e->value.function.esym && e->value.function.esym->result)
2263 {
2264 gfc_symbol *sym = e->value.function.esym->result;
2265 attr = sym->attr;
2266 if (sym->ts.type == BT_CLASS)
2267 {
2268 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2269 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2270 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2271 }
2272 }
2273 else
2274 attr = gfc_variable_attr (e, NULL);
2275
2276 /* TODO: NULL() returns pointers. May have to take care of this
2277 here. */
2278
2279 break;
2280
2281 default:
2282 gfc_clear_attr (&attr);
2283 break;
2284 }
2285
2286 return attr;
2287}
2288
2289
2290/* Match a structure constructor. The initial symbol has already been
2291 seen. */
2292
2293typedef struct gfc_structure_ctor_component
2294{
2295 char* name;
2296 gfc_expr* val;
2297 locus where;
2298 struct gfc_structure_ctor_component* next;
2299}
2300gfc_structure_ctor_component;
2301
2302#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2303
2304static void
2305gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2306{
2307 free (comp->name);
2308 gfc_free_expr (comp->val);
2309 free (comp);
2310}
2311
2312
2313/* Translate the component list into the actual constructor by sorting it in
2314 the order required; this also checks along the way that each and every
2315 component actually has an initializer and handles default initializers
2316 for components without explicit value given. */
2317static bool
2318build_actual_constructor (gfc_structure_ctor_component **comp_head,
2319 gfc_constructor_base *ctor_head, gfc_symbol *sym)
2320{
2321 gfc_structure_ctor_component *comp_iter;
2322 gfc_component *comp;
2323
2324 for (comp = sym->components; comp; comp = comp->next)
2325 {
2326 gfc_structure_ctor_component **next_ptr;
2327 gfc_expr *value = NULL;
2328
2329 /* Try to find the initializer for the current component by name. */
2330 next_ptr = comp_head;
2331 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2332 {
2333 if (!strcmp (comp_iter->name, comp->name))
2334 break;
2335 next_ptr = &comp_iter->next;
2336 }
2337
2338 /* If an extension, try building the parent derived type by building
2339 a value expression for the parent derived type and calling self. */
2340 if (!comp_iter && comp == sym->components && sym->attr.extension)
2341 {
2342 value = gfc_get_structure_constructor_expr (comp->ts.type,
2343 comp->ts.kind,
2344 &gfc_current_locus);
2345 value->ts = comp->ts;
2346
2347 if (!build_actual_constructor (comp_head,
2348 &value->value.constructor,
2349 comp->ts.u.derived))
2350 {
2351 gfc_free_expr (value);
2352 return false;
2353 }
2354
2355 gfc_constructor_append_expr (ctor_head, value, NULL);
2356 continue;
2357 }
2358
2359 /* If it was not found, try the default initializer if there's any;
2360 otherwise, it's an error unless this is a deferred parameter. */
2361 if (!comp_iter)
2362 {
2363 if (comp->initializer)
2364 {
2365 if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
2366 "with missing optional arguments at %C"))
2367 return false;
2368 value = gfc_copy_expr (comp->initializer);
2369 }
2370 else if (!comp->attr.deferred_parameter)
2371 {
2372 gfc_error ("No initializer for component %qs given in the"
2373 " structure constructor at %C!", comp->name);
2374 return false;
2375 }
2376 }
2377 else
2378 value = comp_iter->val;
2379
2380 /* Add the value to the constructor chain built. */
2381 gfc_constructor_append_expr (ctor_head, value, NULL);
2382
2383 /* Remove the entry from the component list. We don't want the expression
2384 value to be free'd, so set it to NULL. */
2385 if (comp_iter)
2386 {
2387 *next_ptr = comp_iter->next;
2388 comp_iter->val = NULL;
2389 gfc_free_structure_ctor_component (comp_iter);
2390 }
2391 }
2392 return true;
2393}
2394
2395
2396bool
2397gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
2398 gfc_actual_arglist **arglist,
2399 bool parent)
2400{
2401 gfc_actual_arglist *actual;
2402 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2403 gfc_constructor_base ctor_head = NULL;
2404 gfc_component *comp; /* Is set NULL when named component is first seen */
2405 const char* last_name = NULL;
2406 locus old_locus;
2407 gfc_expr *expr;
2408
2409 expr = parent ? *cexpr : e;
2410 old_locus = gfc_current_locus;
2411 if (parent)
2412 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
2413 else
2414 gfc_current_locus = expr->where;
2415
2416 comp_tail = comp_head = NULL;
2417
2418 if (!parent && sym->attr.abstract)
2419 {
2420 gfc_error ("Can't construct ABSTRACT type %qs at %L",
2421 sym->name, &expr->where);
2422 goto cleanup;
2423 }
2424
2425 comp = sym->components;
2426 actual = parent ? *arglist : expr->value.function.actual;
2427 for ( ; actual; )
2428 {
2429 gfc_component *this_comp = NULL;
2430
2431 if (!comp_head)
2432 comp_tail = comp_head = gfc_get_structure_ctor_component ();
2433 else
2434 {
2435 comp_tail->next = gfc_get_structure_ctor_component ();
2436 comp_tail = comp_tail->next;
2437 }
2438 if (actual->name)
2439 {
2440 if (!gfc_notify_std (GFC_STD_F2003, "Structure"
2441 " constructor with named arguments at %C"))
2442 goto cleanup;
2443
2444 comp_tail->name = xstrdup (actual->name);
2445 last_name = comp_tail->name;
2446 comp = NULL;
2447 }
2448 else
2449 {
2450 /* Components without name are not allowed after the first named
2451 component initializer! */
2452 if (!comp || comp->attr.deferred_parameter)
2453 {
2454 if (last_name)
2455 gfc_error ("Component initializer without name after component"
2456 " named %s at %L!", last_name,
2457 actual->expr ? &actual->expr->where
2458 : &gfc_current_locus);
2459 else
2460 gfc_error ("Too many components in structure constructor at "
2461 "%L!", actual->expr ? &actual->expr->where
2462 : &gfc_current_locus);
2463 goto cleanup;
2464 }
2465
2466 comp_tail->name = xstrdup (comp->name);
2467 }
2468
2469 /* Find the current component in the structure definition and check
2470 its access is not private. */
2471 if (comp)
2472 this_comp = gfc_find_component (sym, comp->name, false, false);
2473 else
2474 {
2475 this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
2476 false, false);
2477 comp = NULL; /* Reset needed! */
2478 }
2479
2480 /* Here we can check if a component name is given which does not
2481 correspond to any component of the defined structure. */
2482 if (!this_comp)
2483 goto cleanup;
2484
2485 comp_tail->val = actual->expr;
2486 if (actual->expr != NULL)
2487 comp_tail->where = actual->expr->where;
2488 actual->expr = NULL;
2489
2490 /* Check if this component is already given a value. */
2491 for (comp_iter = comp_head; comp_iter != comp_tail;
2492 comp_iter = comp_iter->next)
2493 {
2494 gcc_assert (comp_iter);
2495 if (!strcmp (comp_iter->name, comp_tail->name))
2496 {
2497 gfc_error ("Component %qs is initialized twice in the structure"
2498 " constructor at %L!", comp_tail->name,
2499 comp_tail->val ? &comp_tail->where
2500 : &gfc_current_locus);
2501 goto cleanup;
2502 }
2503 }
2504
2505 /* F2008, R457/C725, for PURE C1283. */
2506 if (this_comp->attr.pointer && comp_tail->val
2507 && gfc_is_coindexed (comp_tail->val))
2508 {
2509 gfc_error ("Coindexed expression to pointer component %qs in "
2510 "structure constructor at %L!", comp_tail->name,
2511 &comp_tail->where);
2512 goto cleanup;
2513 }
2514
2515 /* If not explicitly a parent constructor, gather up the components
2516 and build one. */
2517 if (comp && comp == sym->components
2518 && sym->attr.extension
2519 && comp_tail->val
2520 && (comp_tail->val->ts.type != BT_DERIVED
2521 ||
2522 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2523 {
2524 bool m;
2525 gfc_actual_arglist *arg_null = NULL;
2526
2527 actual->expr = comp_tail->val;
2528 comp_tail->val = NULL;
2529
2530 m = gfc_convert_to_structure_constructor (NULL,
2531 comp->ts.u.derived, &comp_tail->val,
2532 comp->ts.u.derived->attr.zero_comp
2533 ? &arg_null : &actual, true);
2534 if (!m)
2535 goto cleanup;
2536
2537 if (comp->ts.u.derived->attr.zero_comp)
2538 {
2539 comp = comp->next;
2540 continue;
2541 }
2542 }
2543
2544 if (comp)
2545 comp = comp->next;
2546 if (parent && !comp)
2547 break;
2548
2549 if (actual)
2550 actual = actual->next;
2551 }
2552
2553 if (!build_actual_constructor (&comp_head, &ctor_head, sym))
2554 goto cleanup;
2555
2556 /* No component should be left, as this should have caused an error in the
2557 loop constructing the component-list (name that does not correspond to any
2558 component in the structure definition). */
2559 if (comp_head && sym->attr.extension)
2560 {
2561 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2562 {
2563 gfc_error ("component %qs at %L has already been set by a "
2564 "parent derived type constructor", comp_iter->name,
2565 &comp_iter->where);
2566 }
2567 goto cleanup;
2568 }
2569 else
2570 gcc_assert (!comp_head);
2571
2572 if (parent)
2573 {
2574 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
2575 expr->ts.u.derived = sym;
2576 expr->value.constructor = ctor_head;
2577 *cexpr = expr;
2578 }
2579 else
2580 {
2581 expr->ts.u.derived = sym;
2582 expr->ts.kind = 0;
2583 expr->ts.type = BT_DERIVED;
2584 expr->value.constructor = ctor_head;
2585 expr->expr_type = EXPR_STRUCTURE;
2586 }
2587
2588 gfc_current_locus = old_locus;
2589 if (parent)
2590 *arglist = actual;
2591 return true;
2592
2593 cleanup:
2594 gfc_current_locus = old_locus;
2595
2596 for (comp_iter = comp_head; comp_iter; )
2597 {
2598 gfc_structure_ctor_component *next = comp_iter->next;
2599 gfc_free_structure_ctor_component (comp_iter);
2600 comp_iter = next;
2601 }
2602 gfc_constructor_free (ctor_head);
2603
2604 return false;
2605}
2606
2607
2608match
2609gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
2610{
2611 match m;
2612 gfc_expr *e;
2613 gfc_symtree *symtree;
2614
2615 gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */
2616
2617 e = gfc_get_expr ();
2618 e->symtree = symtree;
2619 e->expr_type = EXPR_FUNCTION;
2620
2621 gcc_assert (sym->attr.flavor == FL_DERIVED
2622 && symtree->n.sym->attr.flavor == FL_PROCEDURE);
2623 e->value.function.esym = sym;
2624 e->symtree->n.sym->attr.generic = 1;
2625
2626 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2627 if (m != MATCH_YES)
2628 {
2629 gfc_free_expr (e);
2630 return m;
2631 }
2632
2633 if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
2634 {
2635 gfc_free_expr (e);
2636 return MATCH_ERROR;
2637 }
2638
2639 *result = e;
2640 return MATCH_YES;
2641}
2642
2643
2644/* If the symbol is an implicit do loop index and implicitly typed,
2645 it should not be host associated. Provide a symtree from the
2646 current namespace. */
2647static match
2648check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2649{
2650 if ((*sym)->attr.flavor == FL_VARIABLE
2651 && (*sym)->ns != gfc_current_ns
2652 && (*sym)->attr.implied_index
2653 && (*sym)->attr.implicit_type
2654 && !(*sym)->attr.use_assoc)
2655 {
2656 int i;
2657 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2658 if (i)
2659 return MATCH_ERROR;
2660 *sym = (*st)->n.sym;
2661 }
2662 return MATCH_YES;
2663}
2664
2665
2666/* Procedure pointer as function result: Replace the function symbol by the
2667 auto-generated hidden result variable named "ppr@". */
2668
2669static bool
2670replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2671{
2672 /* Check for procedure pointer result variable. */
2673 if ((*sym)->attr.function && !(*sym)->attr.external
2674 && (*sym)->result && (*sym)->result != *sym
2675 && (*sym)->result->attr.proc_pointer
2676 && (*sym) == gfc_current_ns->proc_name
2677 && (*sym) == (*sym)->result->ns->proc_name
2678 && strcmp ("ppr@", (*sym)->result->name) == 0)
2679 {
2680 /* Automatic replacement with "hidden" result variable. */
2681 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2682 *sym = (*sym)->result;
2683 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2684 return true;
2685 }
2686 return false;
2687}
2688
2689
2690/* Matches a variable name followed by anything that might follow it--
2691 array reference, argument list of a function, etc. */
2692
2693match
2694gfc_match_rvalue (gfc_expr **result)
2695{
2696 gfc_actual_arglist *actual_arglist;
2697 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2698 gfc_state_data *st;
2699 gfc_symbol *sym;
2700 gfc_symtree *symtree;
2701 locus where, old_loc;
2702 gfc_expr *e;
2703 match m, m2;
2704 int i;
2705 gfc_typespec *ts;
2706 bool implicit_char;
2707 gfc_ref *ref;
2708
2709 m = gfc_match_name (name);
2710 if (m != MATCH_YES)
2711 return m;
2712
2713 if (gfc_find_state (COMP_INTERFACE)
2714 && !gfc_current_ns->has_import_set)
2715 i = gfc_get_sym_tree (name, NULL, &symtree, false);
2716 else
2717 i = gfc_get_ha_sym_tree (name, &symtree);
2718
2719 if (i)
2720 return MATCH_ERROR;
2721
2722 sym = symtree->n.sym;
2723 e = NULL;
2724 where = gfc_current_locus;
2725
2726 replace_hidden_procptr_result (&sym, &symtree);
2727
2728 /* If this is an implicit do loop index and implicitly typed,
2729 it should not be host associated. */
2730 m = check_for_implicit_index (&symtree, &sym);
2731 if (m != MATCH_YES)
2732 return m;
2733
2734 gfc_set_sym_referenced (sym);
2735 sym->attr.implied_index = 0;
2736
2737 if (sym->attr.function && sym->result == sym)
2738 {
2739 /* See if this is a directly recursive function call. */
2740 gfc_gobble_whitespace ();
2741 if (sym->attr.recursive
2742 && gfc_peek_ascii_char () == '('
2743 && gfc_current_ns->proc_name == sym
2744 && !sym->attr.dimension)
2745 {
2746 gfc_error ("%qs at %C is the name of a recursive function "
2747 "and so refers to the result variable. Use an "
2748 "explicit RESULT variable for direct recursion "
2749 "(12.5.2.1)", sym->name);
2750 return MATCH_ERROR;
2751 }
2752
2753 if (gfc_is_function_return_value (sym, gfc_current_ns))
2754 goto variable;
2755
2756 if (sym->attr.entry
2757 && (sym->ns == gfc_current_ns
2758 || sym->ns == gfc_current_ns->parent))
2759 {
2760 gfc_entry_list *el = NULL;
2761
2762 for (el = sym->ns->entries; el; el = el->next)
2763 if (sym == el->sym)
2764 goto variable;
2765 }
2766 }
2767
2768 if (gfc_matching_procptr_assignment)
2769 goto procptr0;
2770
2771 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2772 goto function0;
2773
2774 if (sym->attr.generic)
2775 goto generic_function;
2776
2777 switch (sym->attr.flavor)
2778 {
2779 case FL_VARIABLE:
2780 variable:
2781 e = gfc_get_expr ();
2782
2783 e->expr_type = EXPR_VARIABLE;
2784 e->symtree = symtree;
2785
2786 m = gfc_match_varspec (e, 0, false, true);
2787 break;
2788
2789 case FL_PARAMETER:
2790 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2791 end up here. Unfortunately, sym->value->expr_type is set to
2792 EXPR_CONSTANT, and so the if () branch would be followed without
2793 the !sym->as check. */
2794 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2795 e = gfc_copy_expr (sym->value);
2796 else
2797 {
2798 e = gfc_get_expr ();
2799 e->expr_type = EXPR_VARIABLE;
2800 }
2801
2802 e->symtree = symtree;
2803 m = gfc_match_varspec (e, 0, false, true);
2804
2805 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2806 break;
2807
2808 /* Variable array references to derived type parameters cause
2809 all sorts of headaches in simplification. Treating such
2810 expressions as variable works just fine for all array
2811 references. */
2812 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2813 {
2814 for (ref = e->ref; ref; ref = ref->next)
2815 if (ref->type == REF_ARRAY)
2816 break;
2817
2818 if (ref == NULL || ref->u.ar.type == AR_FULL)
2819 break;
2820
2821 ref = e->ref;
2822 e->ref = NULL;
2823 gfc_free_expr (e);
2824 e = gfc_get_expr ();
2825 e->expr_type = EXPR_VARIABLE;
2826 e->symtree = symtree;
2827 e->ref = ref;
2828 }
2829
2830 break;
2831
2832 case FL_DERIVED:
2833 sym = gfc_use_derived (sym);
2834 if (sym == NULL)
2835 m = MATCH_ERROR;
2836 else
2837 goto generic_function;
2838 break;
2839
2840 /* If we're here, then the name is known to be the name of a
2841 procedure, yet it is not sure to be the name of a function. */
2842 case FL_PROCEDURE:
2843
2844 /* Procedure Pointer Assignments. */
2845 procptr0:
2846 if (gfc_matching_procptr_assignment)
2847 {
2848 gfc_gobble_whitespace ();
2849 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2850 /* Parse functions returning a procptr. */
2851 goto function0;
2852
2853 e = gfc_get_expr ();
2854 e->expr_type = EXPR_VARIABLE;
2855 e->symtree = symtree;
2856 m = gfc_match_varspec (e, 0, false, true);
2857 if (!e->ref && sym->attr.flavor == FL_UNKNOWN
2858 && sym->ts.type == BT_UNKNOWN
2859 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
2860 {
2861 m = MATCH_ERROR;
2862 break;
2863 }
2864 break;
2865 }
2866
2867 if (sym->attr.subroutine)
2868 {
2869 gfc_error ("Unexpected use of subroutine name %qs at %C",
2870 sym->name);
2871 m = MATCH_ERROR;
2872 break;
2873 }
2874
2875 /* At this point, the name has to be a non-statement function.
2876 If the name is the same as the current function being
2877 compiled, then we have a variable reference (to the function
2878 result) if the name is non-recursive. */
2879
2880 st = gfc_enclosing_unit (NULL);
2881
2882 if (st != NULL && st->state == COMP_FUNCTION
2883 && st->sym == sym
2884 && !sym->attr.recursive)
2885 {
2886 e = gfc_get_expr ();
2887 e->symtree = symtree;
2888 e->expr_type = EXPR_VARIABLE;
2889
2890 m = gfc_match_varspec (e, 0, false, true);
2891 break;
2892 }
2893
2894 /* Match a function reference. */
2895 function0:
2896 m = gfc_match_actual_arglist (0, &actual_arglist);
2897 if (m == MATCH_NO)
2898 {
2899 if (sym->attr.proc == PROC_ST_FUNCTION)
2900 gfc_error ("Statement function %qs requires argument list at %C",
2901 sym->name);
2902 else
2903 gfc_error ("Function %qs requires an argument list at %C",
2904 sym->name);
2905
2906 m = MATCH_ERROR;
2907 break;
2908 }
2909
2910 if (m != MATCH_YES)
2911 {
2912 m = MATCH_ERROR;
2913 break;
2914 }
2915
2916 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
2917 sym = symtree->n.sym;
2918
2919 replace_hidden_procptr_result (&sym, &symtree);
2920
2921 e = gfc_get_expr ();
2922 e->symtree = symtree;
2923 e->expr_type = EXPR_FUNCTION;
2924 e->value.function.actual = actual_arglist;
2925 e->where = gfc_current_locus;
2926
2927 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
2928 && CLASS_DATA (sym)->as)
2929 e->rank = CLASS_DATA (sym)->as->rank;
2930 else if (sym->as != NULL)
2931 e->rank = sym->as->rank;
2932
2933 if (!sym->attr.function
2934 && !gfc_add_function (&sym->attr, sym->name, NULL))
2935 {
2936 m = MATCH_ERROR;
2937 break;
2938 }
2939
2940 /* Check here for the existence of at least one argument for the
2941 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
2942 argument(s) given will be checked in gfc_iso_c_func_interface,
2943 during resolution of the function call. */
2944 if (sym->attr.is_iso_c == 1
2945 && (sym->from_intmod == INTMOD_ISO_C_BINDING
2946 && (sym->intmod_sym_id == ISOCBINDING_LOC
2947 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2948 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2949 {
2950 /* make sure we were given a param */
2951 if (actual_arglist == NULL)
2952 {
2953 gfc_error ("Missing argument to %qs at %C", sym->name);
2954 m = MATCH_ERROR;
2955 break;
2956 }
2957 }
2958
2959 if (sym->result == NULL)
2960 sym->result = sym;
2961
2962 m = MATCH_YES;
2963 break;
2964
2965 case FL_UNKNOWN:
2966
2967 /* Special case for derived type variables that get their types
2968 via an IMPLICIT statement. This can't wait for the
2969 resolution phase. */
2970
2971 if (gfc_peek_ascii_char () == '%'
2972 && sym->ts.type == BT_UNKNOWN
2973 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2974 gfc_set_default_type (sym, 0, sym->ns);
2975
2976 /* If the symbol has a (co)dimension attribute, the expression is a
2977 variable. */
2978
2979 if (sym->attr.dimension || sym->attr.codimension)
2980 {
2981 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
2982 {
2983 m = MATCH_ERROR;
2984 break;
2985 }
2986
2987 e = gfc_get_expr ();
2988 e->symtree = symtree;
2989 e->expr_type = EXPR_VARIABLE;
2990 m = gfc_match_varspec (e, 0, false, true);
2991 break;
2992 }
2993
2994 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
2995 && (CLASS_DATA (sym)->attr.dimension
2996 || CLASS_DATA (sym)->attr.codimension))
2997 {
2998 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
2999 {
3000 m = MATCH_ERROR;
3001 break;
3002 }
3003
3004 e = gfc_get_expr ();
3005 e->symtree = symtree;
3006 e->expr_type = EXPR_VARIABLE;
3007 m = gfc_match_varspec (e, 0, false, true);
3008 break;
3009 }
3010
3011 /* Name is not an array, so we peek to see if a '(' implies a
3012 function call or a substring reference. Otherwise the
3013 variable is just a scalar. */
3014
3015 gfc_gobble_whitespace ();
3016 if (gfc_peek_ascii_char () != '(')
3017 {
3018 /* Assume a scalar variable */
3019 e = gfc_get_expr ();
3020 e->symtree = symtree;
3021 e->expr_type = EXPR_VARIABLE;
3022
3023 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3024 {
3025 m = MATCH_ERROR;
3026 break;
3027 }
3028
3029 /*FIXME:??? gfc_match_varspec does set this for us: */
3030 e->ts = sym->ts;
3031 m = gfc_match_varspec (e, 0, false, true);
3032 break;
3033 }
3034
3035 /* See if this is a function reference with a keyword argument
3036 as first argument. We do this because otherwise a spurious
3037 symbol would end up in the symbol table. */
3038
3039 old_loc = gfc_current_locus;
3040 m2 = gfc_match (" ( %n =", argname);
3041 gfc_current_locus = old_loc;
3042
3043 e = gfc_get_expr ();
3044 e->symtree = symtree;
3045
3046 if (m2 != MATCH_YES)
3047 {
3048 /* Try to figure out whether we're dealing with a character type.
3049 We're peeking ahead here, because we don't want to call
3050 match_substring if we're dealing with an implicitly typed
3051 non-character variable. */
3052 implicit_char = false;
3053 if (sym->ts.type == BT_UNKNOWN)
3054 {
3055 ts = gfc_get_default_type (sym->name, NULL);
3056 if (ts->type == BT_CHARACTER)
3057 implicit_char = true;
3058 }
3059
3060 /* See if this could possibly be a substring reference of a name
3061 that we're not sure is a variable yet. */
3062
3063 if ((implicit_char || sym->ts.type == BT_CHARACTER)
3064 && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
3065 {
3066
3067 e->expr_type = EXPR_VARIABLE;
3068
3069 if (sym->attr.flavor != FL_VARIABLE
3070 && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
3071 sym->name, NULL))
3072 {
3073 m = MATCH_ERROR;
3074 break;
3075 }
3076
3077 if (sym->ts.type == BT_UNKNOWN
3078 && !gfc_set_default_type (sym, 1, NULL))
3079 {
3080 m = MATCH_ERROR;
3081 break;
3082 }
3083
3084 e->ts = sym->ts;
3085 if (e->ref)
3086 e->ts.u.cl = NULL;
3087 m = MATCH_YES;
3088 break;
3089 }
3090 }
3091
3092 /* Give up, assume we have a function. */
3093
3094 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3095 sym = symtree->n.sym;
3096 e->expr_type = EXPR_FUNCTION;
3097
3098 if (!sym->attr.function
3099 && !gfc_add_function (&sym->attr, sym->name, NULL))
3100 {
3101 m = MATCH_ERROR;
3102 break;
3103 }
3104
3105 sym->result = sym;
3106
3107 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3108 if (m == MATCH_NO)
3109 gfc_error ("Missing argument list in function %qs at %C", sym->name);
3110
3111 if (m != MATCH_YES)
3112 {
3113 m = MATCH_ERROR;
3114 break;
3115 }
3116
3117 /* If our new function returns a character, array or structure
3118 type, it might have subsequent references. */
3119
3120 m = gfc_match_varspec (e, 0, false, true);
3121 if (m == MATCH_NO)
3122 m = MATCH_YES;
3123
3124 break;
3125
3126 generic_function:
3127 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3128
3129 e = gfc_get_expr ();
3130 e->symtree = symtree;
3131 e->expr_type = EXPR_FUNCTION;
3132
3133 if (sym->attr.flavor == FL_DERIVED)
3134 {
3135 e->value.function.esym = sym;
3136 e->symtree->n.sym->attr.generic = 1;
3137 }
3138
3139 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3140 break;
3141
3142 default:
3143 gfc_error ("Symbol at %C is not appropriate for an expression");
3144 return MATCH_ERROR;
3145 }
3146
3147 if (m == MATCH_YES)
3148 {
3149 e->where = where;
3150 *result = e;
3151 }
3152 else
3153 gfc_free_expr (e);
3154
3155 return m;
3156}
3157
3158
3159/* Match a variable, i.e. something that can be assigned to. This
3160 starts as a symbol, can be a structure component or an array
3161 reference. It can be a function if the function doesn't have a
3162 separate RESULT variable. If the symbol has not been previously
3163 seen, we assume it is a variable.
3164
3165 This function is called by two interface functions:
3166 gfc_match_variable, which has host_flag = 1, and
3167 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3168 match of the symbol to the local scope. */
3169
3170static match
3171match_variable (gfc_expr **result, int equiv_flag, int host_flag)
3172{
3173 gfc_symbol *sym;
3174 gfc_symtree *st;
3175 gfc_expr *expr;
3176 locus where;
3177 match m;
3178
3179 /* Since nothing has any business being an lvalue in a module
3180 specification block, an interface block or a contains section,
3181 we force the changed_symbols mechanism to work by setting
3182 host_flag to 0. This prevents valid symbols that have the name
3183 of keywords, such as 'end', being turned into variables by
3184 failed matching to assignments for, e.g., END INTERFACE. */
3185 if (gfc_current_state () == COMP_MODULE
3186 || gfc_current_state () == COMP_INTERFACE
3187 || gfc_current_state () == COMP_CONTAINS)
3188 host_flag = 0;
3189
3190 where = gfc_current_locus;
3191 m = gfc_match_sym_tree (&st, host_flag);
3192 if (m != MATCH_YES)
3193 return m;
3194
3195 sym = st->n.sym;
3196
3197 /* If this is an implicit do loop index and implicitly typed,
3198 it should not be host associated. */
3199 m = check_for_implicit_index (&st, &sym);
3200 if (m != MATCH_YES)
3201 return m;
3202
3203 sym->attr.implied_index = 0;
3204
3205 gfc_set_sym_referenced (sym);
3206 switch (sym->attr.flavor)
3207 {
3208 case FL_VARIABLE:
3209 /* Everything is alright. */
3210 break;
3211
3212 case FL_UNKNOWN:
3213 {
3214 sym_flavor flavor = FL_UNKNOWN;
3215
3216 gfc_gobble_whitespace ();
3217
3218 if (sym->attr.external || sym->attr.procedure
3219 || sym->attr.function || sym->attr.subroutine)
3220 flavor = FL_PROCEDURE;
3221
3222 /* If it is not a procedure, is not typed and is host associated,
3223 we cannot give it a flavor yet. */
3224 else if (sym->ns == gfc_current_ns->parent
3225 && sym->ts.type == BT_UNKNOWN)
3226 break;
3227
3228 /* These are definitive indicators that this is a variable. */
3229 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
3230 || sym->attr.pointer || sym->as != NULL)
3231 flavor = FL_VARIABLE;
3232
3233 if (flavor != FL_UNKNOWN
3234 && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
3235 return MATCH_ERROR;
3236 }
3237 break;
3238
3239 case FL_PARAMETER:
3240 if (equiv_flag)
3241 {
3242 gfc_error ("Named constant at %C in an EQUIVALENCE");
3243 return MATCH_ERROR;
3244 }
3245 /* Otherwise this is checked for and an error given in the
3246 variable definition context checks. */
3247 break;
3248
3249 case FL_PROCEDURE:
3250 /* Check for a nonrecursive function result variable. */
3251 if (sym->attr.function
3252 && !sym->attr.external
3253 && sym->result == sym
3254 && (gfc_is_function_return_value (sym, gfc_current_ns)
3255 || (sym->attr.entry
3256 && sym->ns == gfc_current_ns)
3257 || (sym->attr.entry
3258 && sym->ns == gfc_current_ns->parent)))
3259 {
3260 /* If a function result is a derived type, then the derived
3261 type may still have to be resolved. */
3262
3263 if (sym->ts.type == BT_DERIVED
3264 && gfc_use_derived (sym->ts.u.derived) == NULL)
3265 return MATCH_ERROR;
3266 break;
3267 }
3268
3269 if (sym->attr.proc_pointer
3270 || replace_hidden_procptr_result (&sym, &st))
3271 break;
3272
3273 /* Fall through to error */
3274
3275 default:
3276 gfc_error ("%qs at %C is not a variable", sym->name);
3277 return MATCH_ERROR;
3278 }
3279
3280 /* Special case for derived type variables that get their types
3281 via an IMPLICIT statement. This can't wait for the
3282 resolution phase. */
3283
3284 {
3285 gfc_namespace * implicit_ns;
3286
3287 if (gfc_current_ns->proc_name == sym)
3288 implicit_ns = gfc_current_ns;
3289 else
3290 implicit_ns = sym->ns;
3291
3292 if (gfc_peek_ascii_char () == '%'
3293 && sym->ts.type == BT_UNKNOWN
3294 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3295 gfc_set_default_type (sym, 0, implicit_ns);
3296 }
3297
3298 expr = gfc_get_expr ();
3299
3300 expr->expr_type = EXPR_VARIABLE;
3301 expr->symtree = st;
3302 expr->ts = sym->ts;
3303 expr->where = where;
3304
3305 /* Now see if we have to do more. */
3306 m = gfc_match_varspec (expr, equiv_flag, false, false);
3307 if (m != MATCH_YES)
3308 {
3309 gfc_free_expr (expr);
3310 return m;
3311 }
3312
3313 *result = expr;
3314 return MATCH_YES;
3315}
3316
3317
3318match
3319gfc_match_variable (gfc_expr **result, int equiv_flag)
3320{
3321 return match_variable (result, equiv_flag, 1);
3322}
3323
3324
3325match
3326gfc_match_equiv_variable (gfc_expr **result)
3327{
3328 return match_variable (result, 1, 0);
3329}
3330