1/* Primary expression subroutines
2 Copyright (C) 2000-2023 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 "options.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 match m;
45
46 *is_iso_c = 0;
47
48 m = gfc_match_small_literal_int (kind, NULL, false);
49 if (m != MATCH_NO)
50 return m;
51
52 m = gfc_match_name (name, false);
53 if (m != MATCH_YES)
54 return m;
55
56 if (gfc_find_symbol (name, NULL, 1, &sym))
57 return MATCH_ERROR;
58
59 if (sym == NULL)
60 return MATCH_NO;
61
62 *is_iso_c = sym->attr.is_iso_c;
63
64 if (sym->attr.flavor != FL_PARAMETER)
65 return MATCH_NO;
66
67 if (sym->value == NULL)
68 return MATCH_NO;
69
70 if (gfc_extract_int (sym->value, kind))
71 return MATCH_NO;
72
73 gfc_set_sym_referenced (sym);
74
75 if (*kind < 0)
76 return MATCH_NO;
77
78 return MATCH_YES;
79}
80
81
82/* Get a trailing kind-specification for non-character variables.
83 Returns:
84 * the integer kind value or
85 * -1 if an error was generated,
86 * -2 if no kind was found.
87 The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
88 symbol like e.g. 'c_int'. */
89
90static int
91get_kind (int *is_iso_c)
92{
93 int kind;
94 match m;
95
96 *is_iso_c = 0;
97
98 if (gfc_match_char ('_', false) != MATCH_YES)
99 return -2;
100
101 m = match_kind_param (kind: &kind, is_iso_c);
102 if (m == MATCH_NO)
103 gfc_error ("Missing kind-parameter at %C");
104
105 return (m == MATCH_YES) ? kind : -1;
106}
107
108
109/* Given a character and a radix, see if the character is a valid
110 digit in that radix. */
111
112bool
113gfc_check_digit (char c, int radix)
114{
115 bool r;
116
117 switch (radix)
118 {
119 case 2:
120 r = ('0' <= c && c <= '1');
121 break;
122
123 case 8:
124 r = ('0' <= c && c <= '7');
125 break;
126
127 case 10:
128 r = ('0' <= c && c <= '9');
129 break;
130
131 case 16:
132 r = ISXDIGIT (c);
133 break;
134
135 default:
136 gfc_internal_error ("gfc_check_digit(): bad radix");
137 }
138
139 return r;
140}
141
142
143/* Match the digit string part of an integer if signflag is not set,
144 the signed digit string part if signflag is set. If the buffer
145 is NULL, we just count characters for the resolution pass. Returns
146 the number of characters matched, -1 for no match. */
147
148static int
149match_digits (int signflag, int radix, char *buffer)
150{
151 locus old_loc;
152 int length;
153 char c;
154
155 length = 0;
156 c = gfc_next_ascii_char ();
157
158 if (signflag && (c == '+' || c == '-'))
159 {
160 if (buffer != NULL)
161 *buffer++ = c;
162 gfc_gobble_whitespace ();
163 c = gfc_next_ascii_char ();
164 length++;
165 }
166
167 if (!gfc_check_digit (c, radix))
168 return -1;
169
170 length++;
171 if (buffer != NULL)
172 *buffer++ = c;
173
174 for (;;)
175 {
176 old_loc = gfc_current_locus;
177 c = gfc_next_ascii_char ();
178
179 if (!gfc_check_digit (c, radix))
180 break;
181
182 if (buffer != NULL)
183 *buffer++ = c;
184 length++;
185 }
186
187 gfc_current_locus = old_loc;
188
189 return length;
190}
191
192/* Convert an integer string to an expression node. */
193
194static gfc_expr *
195convert_integer (const char *buffer, int kind, int radix, locus *where)
196{
197 gfc_expr *e;
198 const char *t;
199
200 e = gfc_get_constant_expr (BT_INTEGER, kind, where);
201 /* A leading plus is allowed, but not by mpz_set_str. */
202 if (buffer[0] == '+')
203 t = buffer + 1;
204 else
205 t = buffer;
206 mpz_set_str (e->value.integer, t, radix);
207
208 return e;
209}
210
211
212/* Convert a real string to an expression node. */
213
214static gfc_expr *
215convert_real (const char *buffer, int kind, locus *where)
216{
217 gfc_expr *e;
218
219 e = gfc_get_constant_expr (BT_REAL, kind, where);
220 mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
221
222 return e;
223}
224
225
226/* Convert a pair of real, constant expression nodes to a single
227 complex expression node. */
228
229static gfc_expr *
230convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
231{
232 gfc_expr *e;
233
234 e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
235 mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
236 GFC_MPC_RND_MODE);
237
238 return e;
239}
240
241
242/* Match an integer (digit string and optional kind).
243 A sign will be accepted if signflag is set. */
244
245static match
246match_integer_constant (gfc_expr **result, int signflag)
247{
248 int length, kind, is_iso_c;
249 locus old_loc;
250 char *buffer;
251 gfc_expr *e;
252
253 old_loc = gfc_current_locus;
254 gfc_gobble_whitespace ();
255
256 length = match_digits (signflag, radix: 10, NULL);
257 gfc_current_locus = old_loc;
258 if (length == -1)
259 return MATCH_NO;
260
261 buffer = (char *) alloca (length + 1);
262 memset (s: buffer, c: '\0', n: length + 1);
263
264 gfc_gobble_whitespace ();
265
266 match_digits (signflag, radix: 10, buffer);
267
268 kind = get_kind (is_iso_c: &is_iso_c);
269 if (kind == -2)
270 kind = gfc_default_integer_kind;
271 if (kind == -1)
272 return MATCH_ERROR;
273
274 if (kind == 4 && flag_integer4_kind == 8)
275 kind = 8;
276
277 if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
278 {
279 gfc_error ("Integer kind %d at %C not available", kind);
280 return MATCH_ERROR;
281 }
282
283 e = convert_integer (buffer, kind, radix: 10, where: &gfc_current_locus);
284 e->ts.is_c_interop = is_iso_c;
285
286 if (gfc_range_check (e) != ARITH_OK)
287 {
288 gfc_error ("Integer too big for its kind at %C. This check can be "
289 "disabled with the option %<-fno-range-check%>");
290
291 gfc_free_expr (e);
292 return MATCH_ERROR;
293 }
294
295 *result = e;
296 return MATCH_YES;
297}
298
299
300/* Match a Hollerith constant. */
301
302static match
303match_hollerith_constant (gfc_expr **result)
304{
305 locus old_loc;
306 gfc_expr *e = NULL;
307 int num, pad;
308 int i;
309
310 old_loc = gfc_current_locus;
311 gfc_gobble_whitespace ();
312
313 if (match_integer_constant (result: &e, signflag: 0) == MATCH_YES
314 && gfc_match_char ('h') == MATCH_YES)
315 {
316 if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
317 goto cleanup;
318
319 if (gfc_extract_int (e, &num, 1))
320 goto cleanup;
321 if (num == 0)
322 {
323 gfc_error ("Invalid Hollerith constant: %L must contain at least "
324 "one character", &old_loc);
325 goto cleanup;
326 }
327 if (e->ts.kind != gfc_default_integer_kind)
328 {
329 gfc_error ("Invalid Hollerith constant: Integer kind at %L "
330 "should be default", &old_loc);
331 goto cleanup;
332 }
333 else
334 {
335 gfc_free_expr (e);
336 e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
337 &gfc_current_locus);
338
339 /* Calculate padding needed to fit default integer memory. */
340 pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
341
342 e->representation.string = XCNEWVEC (char, num + pad + 1);
343
344 for (i = 0; i < num; i++)
345 {
346 gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
347 if (! gfc_wide_fits_in_byte (c))
348 {
349 gfc_error ("Invalid Hollerith constant at %L contains a "
350 "wide character", &old_loc);
351 goto cleanup;
352 }
353
354 e->representation.string[i] = (unsigned char) c;
355 }
356
357 /* Now pad with blanks and end with a null char. */
358 for (i = 0; i < pad; i++)
359 e->representation.string[num + i] = ' ';
360
361 e->representation.string[num + i] = '\0';
362 e->representation.length = num + pad;
363 e->ts.u.pad = pad;
364
365 *result = e;
366 return MATCH_YES;
367 }
368 }
369
370 gfc_free_expr (e);
371 gfc_current_locus = old_loc;
372 return MATCH_NO;
373
374cleanup:
375 gfc_free_expr (e);
376 return MATCH_ERROR;
377}
378
379
380/* Match a binary, octal or hexadecimal constant that can be found in
381 a DATA statement. The standard permits b'010...', o'73...', and
382 z'a1...' where b, o, and z can be capital letters. This function
383 also accepts postfixed forms of the constants: '01...'b, '73...'o,
384 and 'a1...'z. An additional extension is the use of x for z. */
385
386static match
387match_boz_constant (gfc_expr **result)
388{
389 int radix, length, x_hex;
390 locus old_loc, start_loc;
391 char *buffer, post, delim;
392 gfc_expr *e;
393
394 start_loc = old_loc = gfc_current_locus;
395 gfc_gobble_whitespace ();
396
397 x_hex = 0;
398 switch (post = gfc_next_ascii_char ())
399 {
400 case 'b':
401 radix = 2;
402 post = 0;
403 break;
404 case 'o':
405 radix = 8;
406 post = 0;
407 break;
408 case 'x':
409 x_hex = 1;
410 /* Fall through. */
411 case 'z':
412 radix = 16;
413 post = 0;
414 break;
415 case '\'':
416 /* Fall through. */
417 case '\"':
418 delim = post;
419 post = 1;
420 radix = 16; /* Set to accept any valid digit string. */
421 break;
422 default:
423 goto backup;
424 }
425
426 /* No whitespace allowed here. */
427
428 if (post == 0)
429 delim = gfc_next_ascii_char ();
430
431 if (delim != '\'' && delim != '\"')
432 goto backup;
433
434 if (x_hex
435 && gfc_invalid_boz (G_("Hexadecimal constant at %L uses "
436 "nonstandard X instead of Z"), &gfc_current_locus))
437 return MATCH_ERROR;
438
439 old_loc = gfc_current_locus;
440
441 length = match_digits (signflag: 0, radix, NULL);
442 if (length == -1)
443 {
444 gfc_error ("Empty set of digits in BOZ constant at %C");
445 return MATCH_ERROR;
446 }
447
448 if (gfc_next_ascii_char () != delim)
449 {
450 gfc_error ("Illegal character in BOZ constant at %C");
451 return MATCH_ERROR;
452 }
453
454 if (post == 1)
455 {
456 switch (gfc_next_ascii_char ())
457 {
458 case 'b':
459 radix = 2;
460 break;
461 case 'o':
462 radix = 8;
463 break;
464 case 'x':
465 /* Fall through. */
466 case 'z':
467 radix = 16;
468 break;
469 default:
470 goto backup;
471 }
472
473 if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix "
474 "syntax"), &gfc_current_locus))
475 return MATCH_ERROR;
476 }
477
478 gfc_current_locus = old_loc;
479
480 buffer = (char *) alloca (length + 1);
481 memset (s: buffer, c: '\0', n: length + 1);
482
483 match_digits (signflag: 0, radix, buffer);
484 gfc_next_ascii_char (); /* Eat delimiter. */
485 if (post == 1)
486 gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
487
488 e = gfc_get_expr ();
489 e->expr_type = EXPR_CONSTANT;
490 e->ts.type = BT_BOZ;
491 e->where = gfc_current_locus;
492 e->boz.rdx = radix;
493 e->boz.len = length;
494 e->boz.str = XCNEWVEC (char, length + 1);
495 strncpy (dest: e->boz.str, src: buffer, n: length);
496
497 if (!gfc_in_match_data ()
498 && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
499 "statement at %L", &e->where)))
500 return MATCH_ERROR;
501
502 *result = e;
503 return MATCH_YES;
504
505backup:
506 gfc_current_locus = start_loc;
507 return MATCH_NO;
508}
509
510
511/* Match a real constant of some sort. Allow a signed constant if signflag
512 is nonzero. */
513
514static match
515match_real_constant (gfc_expr **result, int signflag)
516{
517 int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent;
518 locus old_loc, temp_loc;
519 char *p, *buffer, c, exp_char;
520 gfc_expr *e;
521 bool negate;
522
523 old_loc = gfc_current_locus;
524 gfc_gobble_whitespace ();
525
526 e = NULL;
527
528 default_exponent = 0;
529 count = 0;
530 seen_dp = 0;
531 seen_digits = 0;
532 exp_char = ' ';
533 negate = false;
534
535 c = gfc_next_ascii_char ();
536 if (signflag && (c == '+' || c == '-'))
537 {
538 if (c == '-')
539 negate = true;
540
541 gfc_gobble_whitespace ();
542 c = gfc_next_ascii_char ();
543 }
544
545 /* Scan significand. */
546 for (;; c = gfc_next_ascii_char (), count++)
547 {
548 if (c == '.')
549 {
550 if (seen_dp)
551 goto done;
552
553 /* Check to see if "." goes with a following operator like
554 ".eq.". */
555 temp_loc = gfc_current_locus;
556 c = gfc_next_ascii_char ();
557
558 if (c == 'e' || c == 'd' || c == 'q')
559 {
560 c = gfc_next_ascii_char ();
561 if (c == '.')
562 goto done; /* Operator named .e. or .d. */
563 }
564
565 if (ISALPHA (c))
566 goto done; /* Distinguish 1.e9 from 1.eq.2 */
567
568 gfc_current_locus = temp_loc;
569 seen_dp = 1;
570 continue;
571 }
572
573 if (ISDIGIT (c))
574 {
575 seen_digits = 1;
576 continue;
577 }
578
579 break;
580 }
581
582 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
583 goto done;
584 exp_char = c;
585
586
587 if (c == 'q')
588 {
589 if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter %<q%> in "
590 "real-literal-constant at %C"))
591 return MATCH_ERROR;
592 else if (warn_real_q_constant)
593 gfc_warning (opt: OPT_Wreal_q_constant,
594 "Extension: exponent-letter %<q%> in real-literal-constant "
595 "at %C");
596 }
597
598 /* Scan exponent. */
599 c = gfc_next_ascii_char ();
600 count++;
601
602 if (c == '+' || c == '-')
603 { /* optional sign */
604 c = gfc_next_ascii_char ();
605 count++;
606 }
607
608 if (!ISDIGIT (c))
609 {
610 /* With -fdec, default exponent to 0 instead of complaining. */
611 if (flag_dec)
612 default_exponent = 1;
613 else
614 {
615 gfc_error ("Missing exponent in real number at %C");
616 return MATCH_ERROR;
617 }
618 }
619
620 while (ISDIGIT (c))
621 {
622 c = gfc_next_ascii_char ();
623 count++;
624 }
625
626done:
627 /* Check that we have a numeric constant. */
628 if (!seen_digits || (!seen_dp && exp_char == ' '))
629 {
630 gfc_current_locus = old_loc;
631 return MATCH_NO;
632 }
633
634 /* Convert the number. */
635 gfc_current_locus = old_loc;
636 gfc_gobble_whitespace ();
637
638 buffer = (char *) alloca (count + default_exponent + 1);
639 memset (s: buffer, c: '\0', n: count + default_exponent + 1);
640
641 p = buffer;
642 c = gfc_next_ascii_char ();
643 if (c == '+' || c == '-')
644 {
645 gfc_gobble_whitespace ();
646 c = gfc_next_ascii_char ();
647 }
648
649 /* Hack for mpfr_set_str(). */
650 for (;;)
651 {
652 if (c == 'd' || c == 'q')
653 *p = 'e';
654 else
655 *p = c;
656 p++;
657 if (--count == 0)
658 break;
659
660 c = gfc_next_ascii_char ();
661 }
662 if (default_exponent)
663 *p++ = '0';
664
665 kind = get_kind (is_iso_c: &is_iso_c);
666 if (kind == -1)
667 goto cleanup;
668
669 if (kind == 4)
670 {
671 if (flag_real4_kind == 8)
672 kind = 8;
673 if (flag_real4_kind == 10)
674 kind = 10;
675 if (flag_real4_kind == 16)
676 kind = 16;
677 }
678 else if (kind == 8)
679 {
680 if (flag_real8_kind == 4)
681 kind = 4;
682 if (flag_real8_kind == 10)
683 kind = 10;
684 if (flag_real8_kind == 16)
685 kind = 16;
686 }
687
688 switch (exp_char)
689 {
690 case 'd':
691 if (kind != -2)
692 {
693 gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
694 "kind");
695 goto cleanup;
696 }
697 kind = gfc_default_double_kind;
698 break;
699
700 case 'q':
701 if (kind != -2)
702 {
703 gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
704 "kind");
705 goto cleanup;
706 }
707
708 /* The maximum possible real kind type parameter is 16. First, try
709 that for the kind, then fallback to trying kind=10 (Intel 80 bit)
710 extended precision. If neither value works, just given up. */
711 kind = 16;
712 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
713 {
714 kind = 10;
715 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
716 {
717 gfc_error ("Invalid exponent-letter %<q%> in "
718 "real-literal-constant at %C");
719 goto cleanup;
720 }
721 }
722 break;
723
724 default:
725 if (kind == -2)
726 kind = gfc_default_real_kind;
727
728 if (gfc_validate_kind (BT_REAL, kind, true) < 0)
729 {
730 gfc_error ("Invalid real kind %d at %C", kind);
731 goto cleanup;
732 }
733 }
734
735 e = convert_real (buffer, kind, where: &gfc_current_locus);
736 if (negate)
737 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
738 e->ts.is_c_interop = is_iso_c;
739
740 switch (gfc_range_check (e))
741 {
742 case ARITH_OK:
743 break;
744 case ARITH_OVERFLOW:
745 gfc_error ("Real constant overflows its kind at %C");
746 goto cleanup;
747
748 case ARITH_UNDERFLOW:
749 if (warn_underflow)
750 gfc_warning (opt: OPT_Wunderflow, "Real constant underflows its kind at %C");
751 mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
752 break;
753
754 default:
755 gfc_internal_error ("gfc_range_check() returned bad value");
756 }
757
758 /* Warn about trailing digits which suggest the user added too many
759 trailing digits, which may cause the appearance of higher precision
760 than the kind can support.
761
762 This is done by replacing the rightmost non-zero digit with zero
763 and comparing with the original value. If these are equal, we
764 assume the user supplied more digits than intended (or forgot to
765 convert to the correct kind).
766 */
767
768 if (warn_conversion_extra)
769 {
770 mpfr_t r;
771 char *c1;
772 bool did_break;
773
774 c1 = strchr (s: buffer, c: 'e');
775 if (c1 == NULL)
776 c1 = buffer + strlen(s: buffer);
777
778 did_break = false;
779 for (p = c1; p > buffer;)
780 {
781 p--;
782 if (*p == '.')
783 continue;
784
785 if (*p != '0')
786 {
787 *p = '0';
788 did_break = true;
789 break;
790 }
791 }
792
793 if (did_break)
794 {
795 mpfr_init (r);
796 mpfr_set_str (r, buffer, 10, GFC_RND_MODE);
797 if (negate)
798 mpfr_neg (r, r, GFC_RND_MODE);
799
800 mpfr_sub (r, r, e->value.real, GFC_RND_MODE);
801
802 if (mpfr_cmp_ui (r, 0) == 0)
803 gfc_warning (opt: OPT_Wconversion_extra, "Non-significant digits "
804 "in %qs number at %C, maybe incorrect KIND",
805 gfc_typename (&e->ts));
806
807 mpfr_clear (r);
808 }
809 }
810
811 *result = e;
812 return MATCH_YES;
813
814cleanup:
815 gfc_free_expr (e);
816 return MATCH_ERROR;
817}
818
819
820/* Match a substring reference. */
821
822static match
823match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
824{
825 gfc_expr *start, *end;
826 locus old_loc;
827 gfc_ref *ref;
828 match m;
829
830 start = NULL;
831 end = NULL;
832
833 old_loc = gfc_current_locus;
834
835 m = gfc_match_char ('(');
836 if (m != MATCH_YES)
837 return MATCH_NO;
838
839 if (gfc_match_char (':') != MATCH_YES)
840 {
841 if (init)
842 m = gfc_match_init_expr (&start);
843 else
844 m = gfc_match_expr (&start);
845
846 if (m != MATCH_YES)
847 {
848 m = MATCH_NO;
849 goto cleanup;
850 }
851
852 m = gfc_match_char (':');
853 if (m != MATCH_YES)
854 goto cleanup;
855 }
856
857 if (gfc_match_char (')') != MATCH_YES)
858 {
859 if (init)
860 m = gfc_match_init_expr (&end);
861 else
862 m = gfc_match_expr (&end);
863
864 if (m == MATCH_NO)
865 goto syntax;
866 if (m == MATCH_ERROR)
867 goto cleanup;
868
869 m = gfc_match_char (')');
870 if (m == MATCH_NO)
871 goto syntax;
872 }
873
874 /* Optimize away the (:) reference. */
875 if (start == NULL && end == NULL && !deferred)
876 ref = NULL;
877 else
878 {
879 ref = gfc_get_ref ();
880
881 ref->type = REF_SUBSTRING;
882 if (start == NULL)
883 start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
884 ref->u.ss.start = start;
885 if (end == NULL && cl)
886 end = gfc_copy_expr (cl->length);
887 ref->u.ss.end = end;
888 ref->u.ss.length = cl;
889 }
890
891 *result = ref;
892 return MATCH_YES;
893
894syntax:
895 gfc_error ("Syntax error in SUBSTRING specification at %C");
896 m = MATCH_ERROR;
897
898cleanup:
899 gfc_free_expr (start);
900 gfc_free_expr (end);
901
902 gfc_current_locus = old_loc;
903 return m;
904}
905
906
907/* Reads the next character of a string constant, taking care to
908 return doubled delimiters on the input as a single instance of
909 the delimiter.
910
911 Special return values for "ret" argument are:
912 -1 End of the string, as determined by the delimiter
913 -2 Unterminated string detected
914
915 Backslash codes are also expanded at this time. */
916
917static gfc_char_t
918next_string_char (gfc_char_t delimiter, int *ret)
919{
920 locus old_locus;
921 gfc_char_t c;
922
923 c = gfc_next_char_literal (INSTRING_WARN);
924 *ret = 0;
925
926 if (c == '\n')
927 {
928 *ret = -2;
929 return 0;
930 }
931
932 if (flag_backslash && c == '\\')
933 {
934 old_locus = gfc_current_locus;
935
936 if (gfc_match_special_char (&c) == MATCH_NO)
937 gfc_current_locus = old_locus;
938
939 if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
940 gfc_warning (opt: 0, "Extension: backslash character at %C");
941 }
942
943 if (c != delimiter)
944 return c;
945
946 old_locus = gfc_current_locus;
947 c = gfc_next_char_literal (NONSTRING);
948
949 if (c == delimiter)
950 return c;
951 gfc_current_locus = old_locus;
952
953 *ret = -1;
954 return 0;
955}
956
957
958/* Special case of gfc_match_name() that matches a parameter kind name
959 before a string constant. This takes case of the weird but legal
960 case of:
961
962 kind_____'string'
963
964 where kind____ is a parameter. gfc_match_name() will happily slurp
965 up all the underscores, which leads to problems. If we return
966 MATCH_YES, the parse pointer points to the final underscore, which
967 is not part of the name. We never return MATCH_ERROR-- errors in
968 the name will be detected later. */
969
970static match
971match_charkind_name (char *name)
972{
973 locus old_loc;
974 char c, peek;
975 int len;
976
977 gfc_gobble_whitespace ();
978 c = gfc_next_ascii_char ();
979 if (!ISALPHA (c))
980 return MATCH_NO;
981
982 *name++ = c;
983 len = 1;
984
985 for (;;)
986 {
987 old_loc = gfc_current_locus;
988 c = gfc_next_ascii_char ();
989
990 if (c == '_')
991 {
992 peek = gfc_peek_ascii_char ();
993
994 if (peek == '\'' || peek == '\"')
995 {
996 gfc_current_locus = old_loc;
997 *name = '\0';
998 return MATCH_YES;
999 }
1000 }
1001
1002 if (!ISALNUM (c)
1003 && c != '_'
1004 && (c != '$' || !flag_dollar_ok))
1005 break;
1006
1007 *name++ = c;
1008 if (++len > GFC_MAX_SYMBOL_LEN)
1009 break;
1010 }
1011
1012 return MATCH_NO;
1013}
1014
1015
1016/* See if the current input matches a character constant. Lots of
1017 contortions have to be done to match the kind parameter which comes
1018 before the actual string. The main consideration is that we don't
1019 want to error out too quickly. For example, we don't actually do
1020 any validation of the kinds until we have actually seen a legal
1021 delimiter. Using match_kind_param() generates errors too quickly. */
1022
1023static match
1024match_string_constant (gfc_expr **result)
1025{
1026 char name[GFC_MAX_SYMBOL_LEN + 1], peek;
1027 size_t length;
1028 int kind,save_warn_ampersand, ret;
1029 locus old_locus, start_locus;
1030 gfc_symbol *sym;
1031 gfc_expr *e;
1032 match m;
1033 gfc_char_t c, delimiter, *p;
1034
1035 old_locus = gfc_current_locus;
1036
1037 gfc_gobble_whitespace ();
1038
1039 c = gfc_next_char ();
1040 if (c == '\'' || c == '"')
1041 {
1042 kind = gfc_default_character_kind;
1043 start_locus = gfc_current_locus;
1044 goto got_delim;
1045 }
1046
1047 if (gfc_wide_is_digit (c))
1048 {
1049 kind = 0;
1050
1051 while (gfc_wide_is_digit (c))
1052 {
1053 kind = kind * 10 + c - '0';
1054 if (kind > 9999999)
1055 goto no_match;
1056 c = gfc_next_char ();
1057 }
1058
1059 }
1060 else
1061 {
1062 gfc_current_locus = old_locus;
1063
1064 m = match_charkind_name (name);
1065 if (m != MATCH_YES)
1066 goto no_match;
1067
1068 if (gfc_find_symbol (name, NULL, 1, &sym)
1069 || sym == NULL
1070 || sym->attr.flavor != FL_PARAMETER)
1071 goto no_match;
1072
1073 kind = -1;
1074 c = gfc_next_char ();
1075 }
1076
1077 if (c != '_')
1078 goto no_match;
1079
1080 c = gfc_next_char ();
1081 if (c != '\'' && c != '"')
1082 goto no_match;
1083
1084 start_locus = gfc_current_locus;
1085
1086 if (kind == -1)
1087 {
1088 if (gfc_extract_int (sym->value, &kind, 1))
1089 return MATCH_ERROR;
1090 gfc_set_sym_referenced (sym);
1091 }
1092
1093 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1094 {
1095 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
1096 return MATCH_ERROR;
1097 }
1098
1099got_delim:
1100 /* Scan the string into a block of memory by first figuring out how
1101 long it is, allocating the structure, then re-reading it. This
1102 isn't particularly efficient, but string constants aren't that
1103 common in most code. TODO: Use obstacks? */
1104
1105 delimiter = c;
1106 length = 0;
1107
1108 for (;;)
1109 {
1110 c = next_string_char (delimiter, ret: &ret);
1111 if (ret == -1)
1112 break;
1113 if (ret == -2)
1114 {
1115 gfc_current_locus = start_locus;
1116 gfc_error ("Unterminated character constant beginning at %C");
1117 return MATCH_ERROR;
1118 }
1119
1120 length++;
1121 }
1122
1123 /* Peek at the next character to see if it is a b, o, z, or x for the
1124 postfixed BOZ literal constants. */
1125 peek = gfc_peek_ascii_char ();
1126 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
1127 goto no_match;
1128
1129 e = gfc_get_character_expr (kind, &start_locus, NULL, len: length);
1130
1131 gfc_current_locus = start_locus;
1132
1133 /* We disable the warning for the following loop as the warning has already
1134 been printed in the loop above. */
1135 save_warn_ampersand = warn_ampersand;
1136 warn_ampersand = false;
1137
1138 p = e->value.character.string;
1139 for (size_t i = 0; i < length; i++)
1140 {
1141 c = next_string_char (delimiter, ret: &ret);
1142
1143 if (!gfc_check_character_range (c, kind))
1144 {
1145 gfc_free_expr (e);
1146 gfc_error ("Character %qs in string at %C is not representable "
1147 "in character kind %d", gfc_print_wide_char (c), kind);
1148 return MATCH_ERROR;
1149 }
1150
1151 *p++ = c;
1152 }
1153
1154 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1155 warn_ampersand = save_warn_ampersand;
1156
1157 next_string_char (delimiter, ret: &ret);
1158 if (ret != -1)
1159 gfc_internal_error ("match_string_constant(): Delimiter not found");
1160
1161 if (match_substring (NULL, init: 0, result: &e->ref, deferred: false) != MATCH_NO)
1162 e->expr_type = EXPR_SUBSTRING;
1163
1164 /* Substrings with constant starting and ending points are eligible as
1165 designators (F2018, section 9.1). Simplify substrings to make them usable
1166 e.g. in data statements. */
1167 if (e->expr_type == EXPR_SUBSTRING
1168 && e->ref && e->ref->type == REF_SUBSTRING
1169 && e->ref->u.ss.start->expr_type == EXPR_CONSTANT
1170 && (e->ref->u.ss.end == NULL
1171 || e->ref->u.ss.end->expr_type == EXPR_CONSTANT))
1172 {
1173 gfc_expr *res;
1174 ptrdiff_t istart, iend;
1175 size_t length;
1176 bool equal_length = false;
1177
1178 /* Basic checks on substring starting and ending indices. */
1179 if (!gfc_resolve_substring (e->ref, &equal_length))
1180 return MATCH_ERROR;
1181
1182 length = e->value.character.length;
1183 istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer);
1184 if (e->ref->u.ss.end == NULL)
1185 iend = length;
1186 else
1187 iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer);
1188
1189 if (istart <= iend)
1190 {
1191 if (istart < 1)
1192 {
1193 gfc_error ("Substring start index (%ld) at %L below 1",
1194 (long) istart, &e->ref->u.ss.start->where);
1195 return MATCH_ERROR;
1196 }
1197 if (iend > (ssize_t) length)
1198 {
1199 gfc_error ("Substring end index (%ld) at %L exceeds string "
1200 "length", (long) iend, &e->ref->u.ss.end->where);
1201 return MATCH_ERROR;
1202 }
1203 length = iend - istart + 1;
1204 }
1205 else
1206 length = 0;
1207
1208 res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
1209 res->value.character.string = gfc_get_wide_string (length + 1);
1210 res->value.character.length = length;
1211 if (length > 0)
1212 memcpy (dest: res->value.character.string,
1213 src: &e->value.character.string[istart - 1],
1214 n: length * sizeof (gfc_char_t));
1215 res->value.character.string[length] = '\0';
1216 e = res;
1217 }
1218
1219 *result = e;
1220
1221 return MATCH_YES;
1222
1223no_match:
1224 gfc_current_locus = old_locus;
1225 return MATCH_NO;
1226}
1227
1228
1229/* Match a .true. or .false. Returns 1 if a .true. was found,
1230 0 if a .false. was found, and -1 otherwise. */
1231static int
1232match_logical_constant_string (void)
1233{
1234 locus orig_loc = gfc_current_locus;
1235
1236 gfc_gobble_whitespace ();
1237 if (gfc_next_ascii_char () == '.')
1238 {
1239 char ch = gfc_next_ascii_char ();
1240 if (ch == 'f')
1241 {
1242 if (gfc_next_ascii_char () == 'a'
1243 && gfc_next_ascii_char () == 'l'
1244 && gfc_next_ascii_char () == 's'
1245 && gfc_next_ascii_char () == 'e'
1246 && gfc_next_ascii_char () == '.')
1247 /* Matched ".false.". */
1248 return 0;
1249 }
1250 else if (ch == 't')
1251 {
1252 if (gfc_next_ascii_char () == 'r'
1253 && gfc_next_ascii_char () == 'u'
1254 && gfc_next_ascii_char () == 'e'
1255 && gfc_next_ascii_char () == '.')
1256 /* Matched ".true.". */
1257 return 1;
1258 }
1259 }
1260 gfc_current_locus = orig_loc;
1261 return -1;
1262}
1263
1264/* Match a .true. or .false. */
1265
1266static match
1267match_logical_constant (gfc_expr **result)
1268{
1269 gfc_expr *e;
1270 int i, kind, is_iso_c;
1271
1272 i = match_logical_constant_string ();
1273 if (i == -1)
1274 return MATCH_NO;
1275
1276 kind = get_kind (is_iso_c: &is_iso_c);
1277 if (kind == -1)
1278 return MATCH_ERROR;
1279 if (kind == -2)
1280 kind = gfc_default_logical_kind;
1281
1282 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1283 {
1284 gfc_error ("Bad kind for logical constant at %C");
1285 return MATCH_ERROR;
1286 }
1287
1288 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1289 e->ts.is_c_interop = is_iso_c;
1290
1291 *result = e;
1292 return MATCH_YES;
1293}
1294
1295
1296/* Match a real or imaginary part of a complex constant that is a
1297 symbolic constant. */
1298
1299static match
1300match_sym_complex_part (gfc_expr **result)
1301{
1302 char name[GFC_MAX_SYMBOL_LEN + 1];
1303 gfc_symbol *sym;
1304 gfc_expr *e;
1305 match m;
1306
1307 m = gfc_match_name (name);
1308 if (m != MATCH_YES)
1309 return m;
1310
1311 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1312 return MATCH_NO;
1313
1314 if (sym->attr.flavor != FL_PARAMETER)
1315 {
1316 /* Give the matcher for implied do-loops a chance to run. This yields
1317 a much saner error message for "write(*,*) (i, i=1, 6" where the
1318 right parenthesis is missing. */
1319 char c;
1320 gfc_gobble_whitespace ();
1321 c = gfc_peek_ascii_char ();
1322 if (c == '=' || c == ',')
1323 {
1324 m = MATCH_NO;
1325 }
1326 else
1327 {
1328 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1329 m = MATCH_ERROR;
1330 }
1331 return m;
1332 }
1333
1334 if (!sym->value)
1335 goto error;
1336
1337 if (!gfc_numeric_ts (&sym->value->ts))
1338 {
1339 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1340 return MATCH_ERROR;
1341 }
1342
1343 if (sym->value->rank != 0)
1344 {
1345 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1346 return MATCH_ERROR;
1347 }
1348
1349 if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
1350 "complex constant at %C"))
1351 return MATCH_ERROR;
1352
1353 switch (sym->value->ts.type)
1354 {
1355 case BT_REAL:
1356 e = gfc_copy_expr (sym->value);
1357 break;
1358
1359 case BT_COMPLEX:
1360 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1361 if (e == NULL)
1362 goto error;
1363 break;
1364
1365 case BT_INTEGER:
1366 e = gfc_int2real (sym->value, gfc_default_real_kind);
1367 if (e == NULL)
1368 goto error;
1369 break;
1370
1371 default:
1372 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1373 }
1374
1375 *result = e; /* e is a scalar, real, constant expression. */
1376 return MATCH_YES;
1377
1378error:
1379 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1380 return MATCH_ERROR;
1381}
1382
1383
1384/* Match a real or imaginary part of a complex number. */
1385
1386static match
1387match_complex_part (gfc_expr **result)
1388{
1389 match m;
1390
1391 m = match_sym_complex_part (result);
1392 if (m != MATCH_NO)
1393 return m;
1394
1395 m = match_real_constant (result, signflag: 1);
1396 if (m != MATCH_NO)
1397 return m;
1398
1399 return match_integer_constant (result, signflag: 1);
1400}
1401
1402
1403/* Try to match a complex constant. */
1404
1405static match
1406match_complex_constant (gfc_expr **result)
1407{
1408 gfc_expr *e, *real, *imag;
1409 gfc_error_buffer old_error;
1410 gfc_typespec target;
1411 locus old_loc;
1412 int kind;
1413 match m;
1414
1415 old_loc = gfc_current_locus;
1416 real = imag = e = NULL;
1417
1418 m = gfc_match_char ('(');
1419 if (m != MATCH_YES)
1420 return m;
1421
1422 gfc_push_error (&old_error);
1423
1424 m = match_complex_part (result: &real);
1425 if (m == MATCH_NO)
1426 {
1427 gfc_free_error (&old_error);
1428 goto cleanup;
1429 }
1430
1431 if (gfc_match_char (',') == MATCH_NO)
1432 {
1433 /* It is possible that gfc_int2real issued a warning when
1434 converting an integer to real. Throw this away here. */
1435
1436 gfc_clear_warning ();
1437 gfc_pop_error (&old_error);
1438 m = MATCH_NO;
1439 goto cleanup;
1440 }
1441
1442 /* If m is error, then something was wrong with the real part and we
1443 assume we have a complex constant because we've seen the ','. An
1444 ambiguous case here is the start of an iterator list of some
1445 sort. These sort of lists are matched prior to coming here. */
1446
1447 if (m == MATCH_ERROR)
1448 {
1449 gfc_free_error (&old_error);
1450 goto cleanup;
1451 }
1452 gfc_pop_error (&old_error);
1453
1454 m = match_complex_part (result: &imag);
1455 if (m == MATCH_NO)
1456 goto syntax;
1457 if (m == MATCH_ERROR)
1458 goto cleanup;
1459
1460 m = gfc_match_char (')');
1461 if (m == MATCH_NO)
1462 {
1463 /* Give the matcher for implied do-loops a chance to run. This
1464 yields a much saner error message for (/ (i, 4=i, 6) /). */
1465 if (gfc_peek_ascii_char () == '=')
1466 {
1467 m = MATCH_ERROR;
1468 goto cleanup;
1469 }
1470 else
1471 goto syntax;
1472 }
1473
1474 if (m == MATCH_ERROR)
1475 goto cleanup;
1476
1477 /* Decide on the kind of this complex number. */
1478 if (real->ts.type == BT_REAL)
1479 {
1480 if (imag->ts.type == BT_REAL)
1481 kind = gfc_kind_max (real, imag);
1482 else
1483 kind = real->ts.kind;
1484 }
1485 else
1486 {
1487 if (imag->ts.type == BT_REAL)
1488 kind = imag->ts.kind;
1489 else
1490 kind = gfc_default_real_kind;
1491 }
1492 gfc_clear_ts (&target);
1493 target.type = BT_REAL;
1494 target.kind = kind;
1495
1496 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1497 gfc_convert_type (real, &target, 2);
1498 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1499 gfc_convert_type (imag, &target, 2);
1500
1501 e = convert_complex (real, imag, kind);
1502 e->where = gfc_current_locus;
1503
1504 gfc_free_expr (real);
1505 gfc_free_expr (imag);
1506
1507 *result = e;
1508 return MATCH_YES;
1509
1510syntax:
1511 gfc_error ("Syntax error in COMPLEX constant at %C");
1512 m = MATCH_ERROR;
1513
1514cleanup:
1515 gfc_free_expr (e);
1516 gfc_free_expr (real);
1517 gfc_free_expr (imag);
1518 gfc_current_locus = old_loc;
1519
1520 return m;
1521}
1522
1523
1524/* Match constants in any of several forms. Returns nonzero for a
1525 match, zero for no match. */
1526
1527match
1528gfc_match_literal_constant (gfc_expr **result, int signflag)
1529{
1530 match m;
1531
1532 m = match_complex_constant (result);
1533 if (m != MATCH_NO)
1534 return m;
1535
1536 m = match_string_constant (result);
1537 if (m != MATCH_NO)
1538 return m;
1539
1540 m = match_boz_constant (result);
1541 if (m != MATCH_NO)
1542 return m;
1543
1544 m = match_real_constant (result, signflag);
1545 if (m != MATCH_NO)
1546 return m;
1547
1548 m = match_hollerith_constant (result);
1549 if (m != MATCH_NO)
1550 return m;
1551
1552 m = match_integer_constant (result, signflag);
1553 if (m != MATCH_NO)
1554 return m;
1555
1556 m = match_logical_constant (result);
1557 if (m != MATCH_NO)
1558 return m;
1559
1560 return MATCH_NO;
1561}
1562
1563
1564/* This checks if a symbol is the return value of an encompassing function.
1565 Function nesting can be maximally two levels deep, but we may have
1566 additional local namespaces like BLOCK etc. */
1567
1568bool
1569gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1570{
1571 if (!sym->attr.function || (sym->result != sym))
1572 return false;
1573 while (ns)
1574 {
1575 if (ns->proc_name == sym)
1576 return true;
1577 ns = ns->parent;
1578 }
1579 return false;
1580}
1581
1582
1583/* Match a single actual argument value. An actual argument is
1584 usually an expression, but can also be a procedure name. If the
1585 argument is a single name, it is not always possible to tell
1586 whether the name is a dummy procedure or not. We treat these cases
1587 by creating an argument that looks like a dummy procedure and
1588 fixing things later during resolution. */
1589
1590static match
1591match_actual_arg (gfc_expr **result)
1592{
1593 char name[GFC_MAX_SYMBOL_LEN + 1];
1594 gfc_symtree *symtree;
1595 locus where, w;
1596 gfc_expr *e;
1597 char c;
1598
1599 gfc_gobble_whitespace ();
1600 where = gfc_current_locus;
1601
1602 switch (gfc_match_name (name))
1603 {
1604 case MATCH_ERROR:
1605 return MATCH_ERROR;
1606
1607 case MATCH_NO:
1608 break;
1609
1610 case MATCH_YES:
1611 w = gfc_current_locus;
1612 gfc_gobble_whitespace ();
1613 c = gfc_next_ascii_char ();
1614 gfc_current_locus = w;
1615
1616 if (c != ',' && c != ')')
1617 break;
1618
1619 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1620 break;
1621 /* Handle error elsewhere. */
1622
1623 /* Eliminate a couple of common cases where we know we don't
1624 have a function argument. */
1625 if (symtree == NULL)
1626 {
1627 gfc_get_sym_tree (name, NULL, &symtree, false);
1628 gfc_set_sym_referenced (symtree->n.sym);
1629 }
1630 else
1631 {
1632 gfc_symbol *sym;
1633
1634 sym = symtree->n.sym;
1635 gfc_set_sym_referenced (sym);
1636 if (sym->attr.flavor == FL_NAMELIST)
1637 {
1638 gfc_error ("Namelist %qs cannot be an argument at %L",
1639 sym->name, &where);
1640 break;
1641 }
1642 if (sym->attr.flavor != FL_PROCEDURE
1643 && sym->attr.flavor != FL_UNKNOWN)
1644 break;
1645
1646 if (sym->attr.in_common && !sym->attr.proc_pointer)
1647 {
1648 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
1649 sym->name, &sym->declared_at))
1650 return MATCH_ERROR;
1651 break;
1652 }
1653
1654 /* If the symbol is a function with itself as the result and
1655 is being defined, then we have a variable. */
1656 if (sym->attr.function && sym->result == sym)
1657 {
1658 if (gfc_is_function_return_value (sym, ns: gfc_current_ns))
1659 break;
1660
1661 if (sym->attr.entry
1662 && (sym->ns == gfc_current_ns
1663 || sym->ns == gfc_current_ns->parent))
1664 {
1665 gfc_entry_list *el = NULL;
1666
1667 for (el = sym->ns->entries; el; el = el->next)
1668 if (sym == el->sym)
1669 break;
1670
1671 if (el)
1672 break;
1673 }
1674 }
1675 }
1676
1677 e = gfc_get_expr (); /* Leave it unknown for now */
1678 e->symtree = symtree;
1679 e->expr_type = EXPR_VARIABLE;
1680 e->ts.type = BT_PROCEDURE;
1681 e->where = where;
1682
1683 *result = e;
1684 return MATCH_YES;
1685 }
1686
1687 gfc_current_locus = where;
1688 return gfc_match_expr (result);
1689}
1690
1691
1692/* Match a keyword argument or type parameter spec list.. */
1693
1694static match
1695match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
1696{
1697 char name[GFC_MAX_SYMBOL_LEN + 1];
1698 gfc_actual_arglist *a;
1699 locus name_locus;
1700 match m;
1701
1702 name_locus = gfc_current_locus;
1703 m = gfc_match_name (name);
1704
1705 if (m != MATCH_YES)
1706 goto cleanup;
1707 if (gfc_match_char ('=') != MATCH_YES)
1708 {
1709 m = MATCH_NO;
1710 goto cleanup;
1711 }
1712
1713 if (pdt)
1714 {
1715 if (gfc_match_char ('*') == MATCH_YES)
1716 {
1717 actual->spec_type = SPEC_ASSUMED;
1718 goto add_name;
1719 }
1720 else if (gfc_match_char (':') == MATCH_YES)
1721 {
1722 actual->spec_type = SPEC_DEFERRED;
1723 goto add_name;
1724 }
1725 else
1726 actual->spec_type = SPEC_EXPLICIT;
1727 }
1728
1729 m = match_actual_arg (result: &actual->expr);
1730 if (m != MATCH_YES)
1731 goto cleanup;
1732
1733 /* Make sure this name has not appeared yet. */
1734add_name:
1735 if (name[0] != '\0')
1736 {
1737 for (a = base; a; a = a->next)
1738 if (a->name != NULL && strcmp (s1: a->name, s2: name) == 0)
1739 {
1740 gfc_error ("Keyword %qs at %C has already appeared in the "
1741 "current argument list", name);
1742 return MATCH_ERROR;
1743 }
1744 }
1745
1746 actual->name = gfc_get_string ("%s", name);
1747 return MATCH_YES;
1748
1749cleanup:
1750 gfc_current_locus = name_locus;
1751 return m;
1752}
1753
1754
1755/* Match an argument list function, such as %VAL. */
1756
1757static match
1758match_arg_list_function (gfc_actual_arglist *result)
1759{
1760 char name[GFC_MAX_SYMBOL_LEN + 1];
1761 locus old_locus;
1762 match m;
1763
1764 old_locus = gfc_current_locus;
1765
1766 if (gfc_match_char ('%') != MATCH_YES)
1767 {
1768 m = MATCH_NO;
1769 goto cleanup;
1770 }
1771
1772 m = gfc_match ("%n (", name);
1773 if (m != MATCH_YES)
1774 goto cleanup;
1775
1776 if (name[0] != '\0')
1777 {
1778 switch (name[0])
1779 {
1780 case 'l':
1781 if (startswith (str: name, prefix: "loc"))
1782 {
1783 result->name = "%LOC";
1784 break;
1785 }
1786 /* FALLTHRU */
1787 case 'r':
1788 if (startswith (str: name, prefix: "ref"))
1789 {
1790 result->name = "%REF";
1791 break;
1792 }
1793 /* FALLTHRU */
1794 case 'v':
1795 if (startswith (str: name, prefix: "val"))
1796 {
1797 result->name = "%VAL";
1798 break;
1799 }
1800 /* FALLTHRU */
1801 default:
1802 m = MATCH_ERROR;
1803 goto cleanup;
1804 }
1805 }
1806
1807 if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
1808 {
1809 m = MATCH_ERROR;
1810 goto cleanup;
1811 }
1812
1813 m = match_actual_arg (result: &result->expr);
1814 if (m != MATCH_YES)
1815 goto cleanup;
1816
1817 if (gfc_match_char (')') != MATCH_YES)
1818 {
1819 m = MATCH_NO;
1820 goto cleanup;
1821 }
1822
1823 return MATCH_YES;
1824
1825cleanup:
1826 gfc_current_locus = old_locus;
1827 return m;
1828}
1829
1830
1831/* Matches an actual argument list of a function or subroutine, from
1832 the opening parenthesis to the closing parenthesis. The argument
1833 list is assumed to allow keyword arguments because we don't know if
1834 the symbol associated with the procedure has an implicit interface
1835 or not. We make sure keywords are unique. If sub_flag is set,
1836 we're matching the argument list of a subroutine.
1837
1838 NOTE: An alternative use for this function is to match type parameter
1839 spec lists, which are so similar to actual argument lists that the
1840 machinery can be reused. This use is flagged by the optional argument
1841 'pdt'. */
1842
1843match
1844gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
1845{
1846 gfc_actual_arglist *head, *tail;
1847 int seen_keyword;
1848 gfc_st_label *label;
1849 locus old_loc;
1850 match m;
1851
1852 *argp = tail = NULL;
1853 old_loc = gfc_current_locus;
1854
1855 seen_keyword = 0;
1856
1857 if (gfc_match_char ('(') == MATCH_NO)
1858 return (sub_flag) ? MATCH_YES : MATCH_NO;
1859
1860 if (gfc_match_char (')') == MATCH_YES)
1861 return MATCH_YES;
1862
1863 head = NULL;
1864
1865 matching_actual_arglist++;
1866
1867 for (;;)
1868 {
1869 if (head == NULL)
1870 head = tail = gfc_get_actual_arglist ();
1871 else
1872 {
1873 tail->next = gfc_get_actual_arglist ();
1874 tail = tail->next;
1875 }
1876
1877 if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
1878 {
1879 m = gfc_match_st_label (&label);
1880 if (m == MATCH_NO)
1881 gfc_error ("Expected alternate return label at %C");
1882 if (m != MATCH_YES)
1883 goto cleanup;
1884
1885 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
1886 "at %C"))
1887 goto cleanup;
1888
1889 tail->label = label;
1890 goto next;
1891 }
1892
1893 if (pdt && !seen_keyword)
1894 {
1895 if (gfc_match_char (':') == MATCH_YES)
1896 {
1897 tail->spec_type = SPEC_DEFERRED;
1898 goto next;
1899 }
1900 else if (gfc_match_char ('*') == MATCH_YES)
1901 {
1902 tail->spec_type = SPEC_ASSUMED;
1903 goto next;
1904 }
1905 else
1906 tail->spec_type = SPEC_EXPLICIT;
1907
1908 m = match_keyword_arg (actual: tail, base: head, pdt);
1909 if (m == MATCH_YES)
1910 {
1911 seen_keyword = 1;
1912 goto next;
1913 }
1914 if (m == MATCH_ERROR)
1915 goto cleanup;
1916 }
1917
1918 /* After the first keyword argument is seen, the following
1919 arguments must also have keywords. */
1920 if (seen_keyword)
1921 {
1922 m = match_keyword_arg (actual: tail, base: head, pdt);
1923
1924 if (m == MATCH_ERROR)
1925 goto cleanup;
1926 if (m == MATCH_NO)
1927 {
1928 gfc_error ("Missing keyword name in actual argument list at %C");
1929 goto cleanup;
1930 }
1931
1932 }
1933 else
1934 {
1935 /* Try an argument list function, like %VAL. */
1936 m = match_arg_list_function (result: tail);
1937 if (m == MATCH_ERROR)
1938 goto cleanup;
1939
1940 /* See if we have the first keyword argument. */
1941 if (m == MATCH_NO)
1942 {
1943 m = match_keyword_arg (actual: tail, base: head, pdt: false);
1944 if (m == MATCH_YES)
1945 seen_keyword = 1;
1946 if (m == MATCH_ERROR)
1947 goto cleanup;
1948 }
1949
1950 if (m == MATCH_NO)
1951 {
1952 /* Try for a non-keyword argument. */
1953 m = match_actual_arg (result: &tail->expr);
1954 if (m == MATCH_ERROR)
1955 goto cleanup;
1956 if (m == MATCH_NO)
1957 goto syntax;
1958 }
1959 }
1960
1961
1962 next:
1963 if (gfc_match_char (')') == MATCH_YES)
1964 break;
1965 if (gfc_match_char (',') != MATCH_YES)
1966 goto syntax;
1967 }
1968
1969 *argp = head;
1970 matching_actual_arglist--;
1971 return MATCH_YES;
1972
1973syntax:
1974 gfc_error ("Syntax error in argument list at %C");
1975
1976cleanup:
1977 gfc_free_actual_arglist (head);
1978 gfc_current_locus = old_loc;
1979 matching_actual_arglist--;
1980 return MATCH_ERROR;
1981}
1982
1983
1984/* Used by gfc_match_varspec() to extend the reference list by one
1985 element. */
1986
1987static gfc_ref *
1988extend_ref (gfc_expr *primary, gfc_ref *tail)
1989{
1990 if (primary->ref == NULL)
1991 primary->ref = tail = gfc_get_ref ();
1992 else
1993 {
1994 if (tail == NULL)
1995 gfc_internal_error ("extend_ref(): Bad tail");
1996 tail->next = gfc_get_ref ();
1997 tail = tail->next;
1998 }
1999
2000 return tail;
2001}
2002
2003
2004/* Used by gfc_match_varspec() to match an inquiry reference. */
2005
2006static bool
2007is_inquiry_ref (const char *name, gfc_ref **ref)
2008{
2009 inquiry_type type;
2010
2011 if (name == NULL)
2012 return false;
2013
2014 if (ref) *ref = NULL;
2015
2016 if (strcmp (s1: name, s2: "re") == 0)
2017 type = INQUIRY_RE;
2018 else if (strcmp (s1: name, s2: "im") == 0)
2019 type = INQUIRY_IM;
2020 else if (strcmp (s1: name, s2: "kind") == 0)
2021 type = INQUIRY_KIND;
2022 else if (strcmp (s1: name, s2: "len") == 0)
2023 type = INQUIRY_LEN;
2024 else
2025 return false;
2026
2027 if (ref)
2028 {
2029 *ref = gfc_get_ref ();
2030 (*ref)->type = REF_INQUIRY;
2031 (*ref)->u.i = type;
2032 }
2033
2034 return true;
2035}
2036
2037
2038/* Match any additional specifications associated with the current
2039 variable like member references or substrings. If equiv_flag is
2040 set we only match stuff that is allowed inside an EQUIVALENCE
2041 statement. sub_flag tells whether we expect a type-bound procedure found
2042 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
2043 components, 'ppc_arg' determines whether the PPC may be called (with an
2044 argument list), or whether it may just be referred to as a pointer. */
2045
2046match
2047gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
2048 bool ppc_arg)
2049{
2050 char name[GFC_MAX_SYMBOL_LEN + 1];
2051 gfc_ref *substring, *tail, *tmp;
2052 gfc_component *component = NULL;
2053 gfc_component *previous = NULL;
2054 gfc_symbol *sym = primary->symtree->n.sym;
2055 gfc_expr *tgt_expr = NULL;
2056 match m;
2057 bool unknown;
2058 bool inquiry;
2059 bool intrinsic;
2060 locus old_loc;
2061 char sep;
2062
2063 tail = NULL;
2064
2065 gfc_gobble_whitespace ();
2066
2067 if (gfc_peek_ascii_char () == '[')
2068 {
2069 if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
2070 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
2071 && CLASS_DATA (sym)->attr.dimension))
2072 {
2073 gfc_error ("Array section designator, e.g. %<(:)%>, is required "
2074 "besides the coarray designator %<[...]%> at %C");
2075 return MATCH_ERROR;
2076 }
2077 if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
2078 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
2079 && !CLASS_DATA (sym)->attr.codimension))
2080 {
2081 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2082 sym->name);
2083 return MATCH_ERROR;
2084 }
2085 }
2086
2087 if (sym->assoc && sym->assoc->target)
2088 tgt_expr = sym->assoc->target;
2089
2090 /* For associate names, we may not yet know whether they are arrays or not.
2091 If the selector expression is unambiguously an array; eg. a full array
2092 or an array section, then the associate name must be an array and we can
2093 fix it now. Otherwise, if parentheses follow and it is not a character
2094 type, we have to assume that it actually is one for now. The final
2095 decision will be made at resolution, of course. */
2096 if (sym->assoc
2097 && gfc_peek_ascii_char () == '('
2098 && sym->ts.type != BT_CLASS
2099 && !sym->attr.dimension)
2100 {
2101 gfc_ref *ref = NULL;
2102
2103 if (!sym->assoc->dangling && tgt_expr)
2104 {
2105 if (tgt_expr->expr_type == EXPR_VARIABLE)
2106 gfc_resolve_expr (tgt_expr);
2107
2108 ref = tgt_expr->ref;
2109 for (; ref; ref = ref->next)
2110 if (ref->type == REF_ARRAY
2111 && (ref->u.ar.type == AR_FULL
2112 || ref->u.ar.type == AR_SECTION))
2113 break;
2114 }
2115
2116 if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
2117 && sym->assoc->st
2118 && sym->assoc->st->n.sym
2119 && sym->assoc->st->n.sym->attr.dimension == 0))
2120 {
2121 sym->attr.dimension = 1;
2122 if (sym->as == NULL
2123 && sym->assoc->st
2124 && sym->assoc->st->n.sym
2125 && sym->assoc->st->n.sym->as)
2126 sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
2127 }
2128 }
2129 else if (sym->ts.type == BT_CLASS
2130 && tgt_expr
2131 && tgt_expr->expr_type == EXPR_VARIABLE
2132 && sym->ts.u.derived != tgt_expr->ts.u.derived)
2133 {
2134 gfc_resolve_expr (tgt_expr);
2135 if (tgt_expr->rank)
2136 sym->ts.u.derived = tgt_expr->ts.u.derived;
2137 }
2138
2139 if ((equiv_flag && gfc_peek_ascii_char () == '(')
2140 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
2141 || (sym->attr.dimension && sym->ts.type != BT_CLASS
2142 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
2143 && !(gfc_matching_procptr_assignment
2144 && sym->attr.flavor == FL_PROCEDURE))
2145 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2146 && sym->ts.u.derived && CLASS_DATA (sym)
2147 && (CLASS_DATA (sym)->attr.dimension
2148 || CLASS_DATA (sym)->attr.codimension)))
2149 {
2150 gfc_array_spec *as;
2151
2152 tail = extend_ref (primary, tail);
2153 tail->type = REF_ARRAY;
2154
2155 /* In EQUIVALENCE, we don't know yet whether we are seeing
2156 an array, character variable or array of character
2157 variables. We'll leave the decision till resolve time. */
2158
2159 if (equiv_flag)
2160 as = NULL;
2161 else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
2162 as = CLASS_DATA (sym)->as;
2163 else
2164 as = sym->as;
2165
2166 m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
2167 as ? as->corank : 0);
2168 if (m != MATCH_YES)
2169 return m;
2170
2171 gfc_gobble_whitespace ();
2172 if (equiv_flag && gfc_peek_ascii_char () == '(')
2173 {
2174 tail = extend_ref (primary, tail);
2175 tail->type = REF_ARRAY;
2176
2177 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
2178 if (m != MATCH_YES)
2179 return m;
2180 }
2181 }
2182
2183 primary->ts = sym->ts;
2184
2185 if (equiv_flag)
2186 return MATCH_YES;
2187
2188 /* With DEC extensions, member separator may be '.' or '%'. */
2189 sep = gfc_peek_ascii_char ();
2190 m = gfc_match_member_sep (sym);
2191 if (m == MATCH_ERROR)
2192 return MATCH_ERROR;
2193
2194 inquiry = false;
2195 if (m == MATCH_YES && sep == '%'
2196 && primary->ts.type != BT_CLASS
2197 && primary->ts.type != BT_DERIVED)
2198 {
2199 match mm;
2200 old_loc = gfc_current_locus;
2201 mm = gfc_match_name (name);
2202 if (mm == MATCH_YES && is_inquiry_ref (name, ref: &tmp))
2203 inquiry = true;
2204 gfc_current_locus = old_loc;
2205 }
2206
2207 if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
2208 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2209 gfc_set_default_type (sym, 0, sym->ns);
2210
2211 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2212 if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
2213 {
2214 bool permissible;
2215
2216 /* These target expressions can be resolved at any time. */
2217 permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
2218 && (tgt_expr->symtree->n.sym->attr.use_assoc
2219 || tgt_expr->symtree->n.sym->attr.host_assoc
2220 || tgt_expr->symtree->n.sym->attr.if_source
2221 == IFSRC_DECL);
2222 permissible = permissible
2223 || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
2224
2225 if (permissible)
2226 {
2227 gfc_resolve_expr (tgt_expr);
2228 sym->ts = tgt_expr->ts;
2229 }
2230
2231 if (sym->ts.type == BT_UNKNOWN)
2232 {
2233 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
2234 return MATCH_ERROR;
2235 }
2236 }
2237 else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
2238 && m == MATCH_YES && !inquiry)
2239 {
2240 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2241 sep, sym->name);
2242 return MATCH_ERROR;
2243 }
2244
2245 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
2246 || m != MATCH_YES)
2247 goto check_substring;
2248
2249 if (!inquiry)
2250 sym = sym->ts.u.derived;
2251 else
2252 sym = NULL;
2253
2254 for (;;)
2255 {
2256 bool t;
2257 gfc_symtree *tbp;
2258
2259 m = gfc_match_name (name);
2260 if (m == MATCH_NO)
2261 gfc_error ("Expected structure component name at %C");
2262 if (m != MATCH_YES)
2263 return MATCH_ERROR;
2264
2265 intrinsic = false;
2266 if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
2267 {
2268 inquiry = is_inquiry_ref (name, ref: &tmp);
2269 if (inquiry)
2270 sym = NULL;
2271
2272 if (sep == '%')
2273 {
2274 if (tmp)
2275 {
2276 switch (tmp->u.i)
2277 {
2278 case INQUIRY_RE:
2279 case INQUIRY_IM:
2280 if (!gfc_notify_std (GFC_STD_F2008,
2281 "RE or IM part_ref at %C"))
2282 return MATCH_ERROR;
2283 break;
2284
2285 case INQUIRY_KIND:
2286 if (!gfc_notify_std (GFC_STD_F2003,
2287 "KIND part_ref at %C"))
2288 return MATCH_ERROR;
2289 break;
2290
2291 case INQUIRY_LEN:
2292 if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
2293 return MATCH_ERROR;
2294 break;
2295 }
2296
2297 if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
2298 && primary->ts.type != BT_COMPLEX)
2299 {
2300 gfc_error ("The RE or IM part_ref at %C must be "
2301 "applied to a COMPLEX expression");
2302 return MATCH_ERROR;
2303 }
2304 else if (tmp->u.i == INQUIRY_LEN
2305 && primary->ts.type != BT_CHARACTER)
2306 {
2307 gfc_error ("The LEN part_ref at %C must be applied "
2308 "to a CHARACTER expression");
2309 return MATCH_ERROR;
2310 }
2311 }
2312 if (primary->ts.type != BT_UNKNOWN)
2313 intrinsic = true;
2314 }
2315 }
2316 else
2317 inquiry = false;
2318
2319 if (sym && sym->f2k_derived)
2320 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
2321 else
2322 tbp = NULL;
2323
2324 if (tbp)
2325 {
2326 gfc_symbol* tbp_sym;
2327
2328 if (!t)
2329 return MATCH_ERROR;
2330
2331 gcc_assert (!tail || !tail->next);
2332
2333 if (!(primary->expr_type == EXPR_VARIABLE
2334 || (primary->expr_type == EXPR_STRUCTURE
2335 && primary->symtree && primary->symtree->n.sym
2336 && primary->symtree->n.sym->attr.flavor)))
2337 return MATCH_ERROR;
2338
2339 if (tbp->n.tb->is_generic)
2340 tbp_sym = NULL;
2341 else
2342 tbp_sym = tbp->n.tb->u.specific->n.sym;
2343
2344 primary->expr_type = EXPR_COMPCALL;
2345 primary->value.compcall.tbp = tbp->n.tb;
2346 primary->value.compcall.name = tbp->name;
2347 primary->value.compcall.ignore_pass = 0;
2348 primary->value.compcall.assign = 0;
2349 primary->value.compcall.base_object = NULL;
2350 gcc_assert (primary->symtree->n.sym->attr.referenced);
2351 if (tbp_sym)
2352 primary->ts = tbp_sym->ts;
2353 else
2354 gfc_clear_ts (&primary->ts);
2355
2356 m = gfc_match_actual_arglist (sub_flag: tbp->n.tb->subroutine,
2357 argp: &primary->value.compcall.actual);
2358 if (m == MATCH_ERROR)
2359 return MATCH_ERROR;
2360 if (m == MATCH_NO)
2361 {
2362 if (sub_flag)
2363 primary->value.compcall.actual = NULL;
2364 else
2365 {
2366 gfc_error ("Expected argument list at %C");
2367 return MATCH_ERROR;
2368 }
2369 }
2370
2371 break;
2372 }
2373
2374 previous = component;
2375
2376 if (!inquiry && !intrinsic)
2377 component = gfc_find_component (sym, name, false, false, &tmp);
2378 else
2379 component = NULL;
2380
2381 if (intrinsic && !inquiry)
2382 {
2383 if (previous)
2384 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2385 "type component %qs", name, previous->name);
2386 else
2387 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2388 "type component", name);
2389 return MATCH_ERROR;
2390 }
2391 else if (component == NULL && !inquiry)
2392 return MATCH_ERROR;
2393
2394 /* Extend the reference chain determined by gfc_find_component or
2395 is_inquiry_ref. */
2396 if (primary->ref == NULL)
2397 primary->ref = tmp;
2398 else
2399 {
2400 /* Set by the for loop below for the last component ref. */
2401 gcc_assert (tail != NULL);
2402 tail->next = tmp;
2403 }
2404
2405 /* The reference chain may be longer than one hop for union
2406 subcomponents; find the new tail. */
2407 for (tail = tmp; tail->next; tail = tail->next)
2408 ;
2409
2410 if (tmp && tmp->type == REF_INQUIRY)
2411 {
2412 if (!primary->where.lb || !primary->where.nextc)
2413 primary->where = gfc_current_locus;
2414 gfc_simplify_expr (primary, 0);
2415
2416 if (primary->expr_type == EXPR_CONSTANT)
2417 goto check_done;
2418
2419 switch (tmp->u.i)
2420 {
2421 case INQUIRY_RE:
2422 case INQUIRY_IM:
2423 if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
2424 return MATCH_ERROR;
2425
2426 if (primary->ts.type != BT_COMPLEX)
2427 {
2428 gfc_error ("The RE or IM part_ref at %C must be "
2429 "applied to a COMPLEX expression");
2430 return MATCH_ERROR;
2431 }
2432 primary->ts.type = BT_REAL;
2433 break;
2434
2435 case INQUIRY_LEN:
2436 if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
2437 return MATCH_ERROR;
2438
2439 if (primary->ts.type != BT_CHARACTER)
2440 {
2441 gfc_error ("The LEN part_ref at %C must be applied "
2442 "to a CHARACTER expression");
2443 return MATCH_ERROR;
2444 }
2445 primary->ts.u.cl = NULL;
2446 primary->ts.type = BT_INTEGER;
2447 primary->ts.kind = gfc_default_integer_kind;
2448 break;
2449
2450 case INQUIRY_KIND:
2451 if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
2452 return MATCH_ERROR;
2453
2454 if (primary->ts.type == BT_CLASS
2455 || primary->ts.type == BT_DERIVED)
2456 {
2457 gfc_error ("The KIND part_ref at %C must be applied "
2458 "to an expression of intrinsic type");
2459 return MATCH_ERROR;
2460 }
2461 primary->ts.type = BT_INTEGER;
2462 primary->ts.kind = gfc_default_integer_kind;
2463 break;
2464
2465 default:
2466 gcc_unreachable ();
2467 }
2468
2469 goto check_done;
2470 }
2471
2472 primary->ts = component->ts;
2473
2474 if (component->attr.proc_pointer && ppc_arg)
2475 {
2476 /* Procedure pointer component call: Look for argument list. */
2477 m = gfc_match_actual_arglist (sub_flag,
2478 argp: &primary->value.compcall.actual);
2479 if (m == MATCH_ERROR)
2480 return MATCH_ERROR;
2481
2482 if (m == MATCH_NO && !gfc_matching_ptr_assignment
2483 && !gfc_matching_procptr_assignment && !matching_actual_arglist)
2484 {
2485 gfc_error ("Procedure pointer component %qs requires an "
2486 "argument list at %C", component->name);
2487 return MATCH_ERROR;
2488 }
2489
2490 if (m == MATCH_YES)
2491 primary->expr_type = EXPR_PPC;
2492
2493 break;
2494 }
2495
2496 if (component->as != NULL && !component->attr.proc_pointer)
2497 {
2498 tail = extend_ref (primary, tail);
2499 tail->type = REF_ARRAY;
2500
2501 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
2502 component->as->corank);
2503 if (m != MATCH_YES)
2504 return m;
2505 }
2506 else if (component->ts.type == BT_CLASS && component->attr.class_ok
2507 && CLASS_DATA (component)->as && !component->attr.proc_pointer)
2508 {
2509 tail = extend_ref (primary, tail);
2510 tail->type = REF_ARRAY;
2511
2512 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
2513 equiv_flag,
2514 CLASS_DATA (component)->as->corank);
2515 if (m != MATCH_YES)
2516 return m;
2517 }
2518
2519check_done:
2520 /* In principle, we could have eg. expr%re%kind so we must allow for
2521 this possibility. */
2522 if (gfc_match_char ('%') == MATCH_YES)
2523 {
2524 if (component && (component->ts.type == BT_DERIVED
2525 || component->ts.type == BT_CLASS))
2526 sym = component->ts.u.derived;
2527 continue;
2528 }
2529 else if (inquiry)
2530 break;
2531
2532 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
2533 || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
2534 break;
2535
2536 if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
2537 sym = component->ts.u.derived;
2538 }
2539
2540check_substring:
2541 unknown = false;
2542 if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
2543 {
2544 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
2545 {
2546 gfc_set_default_type (sym, 0, sym->ns);
2547 primary->ts = sym->ts;
2548 unknown = true;
2549 }
2550 }
2551
2552 if (primary->ts.type == BT_CHARACTER)
2553 {
2554 bool def = primary->ts.deferred == 1;
2555 switch (match_substring (cl: primary->ts.u.cl, init: equiv_flag, result: &substring, deferred: def))
2556 {
2557 case MATCH_YES:
2558 if (tail == NULL)
2559 primary->ref = substring;
2560 else
2561 tail->next = substring;
2562
2563 if (primary->expr_type == EXPR_CONSTANT)
2564 primary->expr_type = EXPR_SUBSTRING;
2565
2566 if (substring)
2567 primary->ts.u.cl = NULL;
2568
2569 break;
2570
2571 case MATCH_NO:
2572 if (unknown)
2573 {
2574 gfc_clear_ts (&primary->ts);
2575 gfc_clear_ts (&sym->ts);
2576 }
2577 break;
2578
2579 case MATCH_ERROR:
2580 return MATCH_ERROR;
2581 }
2582 }
2583
2584 /* F08:C611. */
2585 if (primary->ts.type == BT_DERIVED && primary->ref
2586 && primary->ts.u.derived && primary->ts.u.derived->attr.abstract)
2587 {
2588 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2589 return MATCH_ERROR;
2590 }
2591
2592 /* F08:C727. */
2593 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
2594 {
2595 gfc_error ("Coindexed procedure-pointer component at %C");
2596 return MATCH_ERROR;
2597 }
2598
2599 return MATCH_YES;
2600}
2601
2602
2603/* Given an expression that is a variable, figure out what the
2604 ultimate variable's type and attribute is, traversing the reference
2605 structures if necessary.
2606
2607 This subroutine is trickier than it looks. We start at the base
2608 symbol and store the attribute. Component references load a
2609 completely new attribute.
2610
2611 A couple of rules come into play. Subobjects of targets are always
2612 targets themselves. If we see a component that goes through a
2613 pointer, then the expression must also be a target, since the
2614 pointer is associated with something (if it isn't core will soon be
2615 dumped). If we see a full part or section of an array, the
2616 expression is also an array.
2617
2618 We can have at most one full array reference. */
2619
2620symbol_attribute
2621gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2622{
2623 int dimension, codimension, pointer, allocatable, target, optional;
2624 symbol_attribute attr;
2625 gfc_ref *ref;
2626 gfc_symbol *sym;
2627 gfc_component *comp;
2628 bool has_inquiry_part;
2629
2630 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2631 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2632
2633 sym = expr->symtree->n.sym;
2634 attr = sym->attr;
2635
2636 optional = attr.optional;
2637 if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
2638 {
2639 dimension = CLASS_DATA (sym)->attr.dimension;
2640 codimension = CLASS_DATA (sym)->attr.codimension;
2641 pointer = CLASS_DATA (sym)->attr.class_pointer;
2642 allocatable = CLASS_DATA (sym)->attr.allocatable;
2643 }
2644 else
2645 {
2646 dimension = attr.dimension;
2647 codimension = attr.codimension;
2648 pointer = attr.pointer;
2649 allocatable = attr.allocatable;
2650 }
2651
2652 target = attr.target;
2653 if (pointer || attr.proc_pointer)
2654 target = 1;
2655
2656 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2657 *ts = sym->ts;
2658
2659 has_inquiry_part = false;
2660 for (ref = expr->ref; ref; ref = ref->next)
2661 if (ref->type == REF_INQUIRY)
2662 {
2663 has_inquiry_part = true;
2664 optional = false;
2665 break;
2666 }
2667
2668 for (ref = expr->ref; ref; ref = ref->next)
2669 switch (ref->type)
2670 {
2671 case REF_ARRAY:
2672
2673 switch (ref->u.ar.type)
2674 {
2675 case AR_FULL:
2676 dimension = 1;
2677 break;
2678
2679 case AR_SECTION:
2680 allocatable = pointer = 0;
2681 dimension = 1;
2682 optional = false;
2683 break;
2684
2685 case AR_ELEMENT:
2686 /* Handle coarrays. */
2687 if (ref->u.ar.dimen > 0)
2688 allocatable = pointer = optional = false;
2689 break;
2690
2691 case AR_UNKNOWN:
2692 /* For standard conforming code, AR_UNKNOWN should not happen.
2693 For nonconforming code, gfortran can end up here. Treat it
2694 as a no-op. */
2695 break;
2696 }
2697
2698 break;
2699
2700 case REF_COMPONENT:
2701 optional = false;
2702 comp = ref->u.c.component;
2703 attr = comp->attr;
2704 if (ts != NULL && !has_inquiry_part)
2705 {
2706 *ts = comp->ts;
2707 /* Don't set the string length if a substring reference
2708 follows. */
2709 if (ts->type == BT_CHARACTER
2710 && ref->next && ref->next->type == REF_SUBSTRING)
2711 ts->u.cl = NULL;
2712 }
2713
2714 if (comp->ts.type == BT_CLASS)
2715 {
2716 codimension = CLASS_DATA (comp)->attr.codimension;
2717 pointer = CLASS_DATA (comp)->attr.class_pointer;
2718 allocatable = CLASS_DATA (comp)->attr.allocatable;
2719 }
2720 else
2721 {
2722 codimension = comp->attr.codimension;
2723 if (expr->ts.type == BT_CLASS && strcmp (s1: comp->name, s2: "_data") == 0)
2724 pointer = comp->attr.class_pointer;
2725 else
2726 pointer = comp->attr.pointer;
2727 allocatable = comp->attr.allocatable;
2728 }
2729 if (pointer || attr.proc_pointer)
2730 target = 1;
2731
2732 break;
2733
2734 case REF_INQUIRY:
2735 case REF_SUBSTRING:
2736 allocatable = pointer = optional = false;
2737 break;
2738 }
2739
2740 attr.dimension = dimension;
2741 attr.codimension = codimension;
2742 attr.pointer = pointer;
2743 attr.allocatable = allocatable;
2744 attr.target = target;
2745 attr.save = sym->attr.save;
2746 attr.optional = optional;
2747
2748 return attr;
2749}
2750
2751
2752/* Return the attribute from a general expression. */
2753
2754symbol_attribute
2755gfc_expr_attr (gfc_expr *e)
2756{
2757 symbol_attribute attr;
2758
2759 switch (e->expr_type)
2760 {
2761 case EXPR_VARIABLE:
2762 attr = gfc_variable_attr (expr: e, NULL);
2763 break;
2764
2765 case EXPR_FUNCTION:
2766 gfc_clear_attr (&attr);
2767
2768 if (e->value.function.esym && e->value.function.esym->result)
2769 {
2770 gfc_symbol *sym = e->value.function.esym->result;
2771 attr = sym->attr;
2772 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2773 {
2774 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2775 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2776 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2777 }
2778 }
2779 else if (e->value.function.isym
2780 && e->value.function.isym->transformational
2781 && e->ts.type == BT_CLASS)
2782 attr = CLASS_DATA (e)->attr;
2783 else if (e->symtree)
2784 attr = gfc_variable_attr (expr: e, NULL);
2785
2786 /* TODO: NULL() returns pointers. May have to take care of this
2787 here. */
2788
2789 break;
2790
2791 default:
2792 gfc_clear_attr (&attr);
2793 break;
2794 }
2795
2796 return attr;
2797}
2798
2799
2800/* Given an expression, figure out what the ultimate expression
2801 attribute is. This routine is similar to gfc_variable_attr with
2802 parts of gfc_expr_attr, but focuses more on the needs of
2803 coarrays. For coarrays a codimension attribute is kind of
2804 "infectious" being propagated once set and never cleared.
2805 The coarray_comp is only set, when the expression refs a coarray
2806 component. REFS_COMP is set when present to true only, when this EXPR
2807 refs a (non-_data) component. To check whether EXPR refs an allocatable
2808 component in a derived type coarray *refs_comp needs to be set and
2809 coarray_comp has to false. */
2810
2811static symbol_attribute
2812caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
2813{
2814 int dimension, codimension, pointer, allocatable, target, coarray_comp;
2815 symbol_attribute attr;
2816 gfc_ref *ref;
2817 gfc_symbol *sym;
2818 gfc_component *comp;
2819
2820 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2821 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2822
2823 sym = expr->symtree->n.sym;
2824 gfc_clear_attr (&attr);
2825
2826 if (refs_comp)
2827 *refs_comp = false;
2828
2829 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2830 {
2831 dimension = CLASS_DATA (sym)->attr.dimension;
2832 codimension = CLASS_DATA (sym)->attr.codimension;
2833 pointer = CLASS_DATA (sym)->attr.class_pointer;
2834 allocatable = CLASS_DATA (sym)->attr.allocatable;
2835 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
2836 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
2837 }
2838 else
2839 {
2840 dimension = sym->attr.dimension;
2841 codimension = sym->attr.codimension;
2842 pointer = sym->attr.pointer;
2843 allocatable = sym->attr.allocatable;
2844 attr.alloc_comp = sym->ts.type == BT_DERIVED
2845 ? sym->ts.u.derived->attr.alloc_comp : 0;
2846 attr.pointer_comp = sym->ts.type == BT_DERIVED
2847 ? sym->ts.u.derived->attr.pointer_comp : 0;
2848 }
2849
2850 target = coarray_comp = 0;
2851 if (pointer || attr.proc_pointer)
2852 target = 1;
2853
2854 for (ref = expr->ref; ref; ref = ref->next)
2855 switch (ref->type)
2856 {
2857 case REF_ARRAY:
2858
2859 switch (ref->u.ar.type)
2860 {
2861 case AR_FULL:
2862 case AR_SECTION:
2863 dimension = 1;
2864 break;
2865
2866 case AR_ELEMENT:
2867 /* Handle coarrays. */
2868 if (ref->u.ar.dimen > 0 && !in_allocate)
2869 allocatable = pointer = 0;
2870 break;
2871
2872 case AR_UNKNOWN:
2873 /* If any of start, end or stride is not integer, there will
2874 already have been an error issued. */
2875 int errors;
2876 gfc_get_errors (NULL, &errors);
2877 if (errors == 0)
2878 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2879 }
2880
2881 break;
2882
2883 case REF_COMPONENT:
2884 comp = ref->u.c.component;
2885
2886 if (comp->ts.type == BT_CLASS)
2887 {
2888 /* Set coarray_comp only, when this component introduces the
2889 coarray. */
2890 coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
2891 codimension |= CLASS_DATA (comp)->attr.codimension;
2892 pointer = CLASS_DATA (comp)->attr.class_pointer;
2893 allocatable = CLASS_DATA (comp)->attr.allocatable;
2894 }
2895 else
2896 {
2897 /* Set coarray_comp only, when this component introduces the
2898 coarray. */
2899 coarray_comp = !codimension && comp->attr.codimension;
2900 codimension |= comp->attr.codimension;
2901 pointer = comp->attr.pointer;
2902 allocatable = comp->attr.allocatable;
2903 }
2904
2905 if (refs_comp && strcmp (s1: comp->name, s2: "_data") != 0
2906 && (ref->next == NULL
2907 || (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
2908 *refs_comp = true;
2909
2910 if (pointer || attr.proc_pointer)
2911 target = 1;
2912
2913 break;
2914
2915 case REF_SUBSTRING:
2916 case REF_INQUIRY:
2917 allocatable = pointer = 0;
2918 break;
2919 }
2920
2921 attr.dimension = dimension;
2922 attr.codimension = codimension;
2923 attr.pointer = pointer;
2924 attr.allocatable = allocatable;
2925 attr.target = target;
2926 attr.save = sym->attr.save;
2927 attr.coarray_comp = coarray_comp;
2928
2929 return attr;
2930}
2931
2932
2933symbol_attribute
2934gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
2935{
2936 symbol_attribute attr;
2937
2938 switch (e->expr_type)
2939 {
2940 case EXPR_VARIABLE:
2941 attr = caf_variable_attr (expr: e, in_allocate, refs_comp);
2942 break;
2943
2944 case EXPR_FUNCTION:
2945 gfc_clear_attr (&attr);
2946
2947 if (e->value.function.esym && e->value.function.esym->result)
2948 {
2949 gfc_symbol *sym = e->value.function.esym->result;
2950 attr = sym->attr;
2951 if (sym->ts.type == BT_CLASS)
2952 {
2953 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2954 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2955 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2956 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
2957 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
2958 ->attr.pointer_comp;
2959 }
2960 }
2961 else if (e->symtree)
2962 attr = caf_variable_attr (expr: e, in_allocate, refs_comp);
2963 else
2964 gfc_clear_attr (&attr);
2965 break;
2966
2967 default:
2968 gfc_clear_attr (&attr);
2969 break;
2970 }
2971
2972 return attr;
2973}
2974
2975
2976/* Match a structure constructor. The initial symbol has already been
2977 seen. */
2978
2979typedef struct gfc_structure_ctor_component
2980{
2981 char* name;
2982 gfc_expr* val;
2983 locus where;
2984 struct gfc_structure_ctor_component* next;
2985}
2986gfc_structure_ctor_component;
2987
2988#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2989
2990static void
2991gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2992{
2993 free (ptr: comp->name);
2994 gfc_free_expr (comp->val);
2995 free (ptr: comp);
2996}
2997
2998
2999/* Translate the component list into the actual constructor by sorting it in
3000 the order required; this also checks along the way that each and every
3001 component actually has an initializer and handles default initializers
3002 for components without explicit value given. */
3003static bool
3004build_actual_constructor (gfc_structure_ctor_component **comp_head,
3005 gfc_constructor_base *ctor_head, gfc_symbol *sym)
3006{
3007 gfc_structure_ctor_component *comp_iter;
3008 gfc_component *comp;
3009
3010 for (comp = sym->components; comp; comp = comp->next)
3011 {
3012 gfc_structure_ctor_component **next_ptr;
3013 gfc_expr *value = NULL;
3014
3015 /* Try to find the initializer for the current component by name. */
3016 next_ptr = comp_head;
3017 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
3018 {
3019 if (!strcmp (s1: comp_iter->name, s2: comp->name))
3020 break;
3021 next_ptr = &comp_iter->next;
3022 }
3023
3024 /* If an extension, try building the parent derived type by building
3025 a value expression for the parent derived type and calling self. */
3026 if (!comp_iter && comp == sym->components && sym->attr.extension)
3027 {
3028 value = gfc_get_structure_constructor_expr (comp->ts.type,
3029 comp->ts.kind,
3030 &gfc_current_locus);
3031 value->ts = comp->ts;
3032
3033 if (!build_actual_constructor (comp_head,
3034 ctor_head: &value->value.constructor,
3035 sym: comp->ts.u.derived))
3036 {
3037 gfc_free_expr (value);
3038 return false;
3039 }
3040
3041 gfc_constructor_append_expr (base: ctor_head, e: value, NULL);
3042 continue;
3043 }
3044
3045 /* If it was not found, apply NULL expression to set the component as
3046 unallocated. Then try the default initializer if there's any;
3047 otherwise, it's an error unless this is a deferred parameter. */
3048 if (!comp_iter)
3049 {
3050 /* F2018 7.5.10: If an allocatable component has no corresponding
3051 component-data-source, then that component has an allocation
3052 status of unallocated.... */
3053 if (comp->attr.allocatable
3054 || (comp->ts.type == BT_CLASS
3055 && CLASS_DATA (comp)->attr.allocatable))
3056 {
3057 if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
3058 "allocatable component %qs given in the "
3059 "structure constructor at %C", comp->name))
3060 return false;
3061 value = gfc_get_null_expr (&gfc_current_locus);
3062 }
3063 /* ....(Preceding sentence) If a component with default
3064 initialization has no corresponding component-data-source, then
3065 the default initialization is applied to that component. */
3066 else if (comp->initializer)
3067 {
3068 if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
3069 "with missing optional arguments at %C"))
3070 return false;
3071 value = gfc_copy_expr (comp->initializer);
3072 }
3073 /* Do not trap components such as the string length for deferred
3074 length character components. */
3075 else if (!comp->attr.artificial)
3076 {
3077 gfc_error ("No initializer for component %qs given in the"
3078 " structure constructor at %C", comp->name);
3079 return false;
3080 }
3081 }
3082 else
3083 value = comp_iter->val;
3084
3085 /* Add the value to the constructor chain built. */
3086 gfc_constructor_append_expr (base: ctor_head, e: value, NULL);
3087
3088 /* Remove the entry from the component list. We don't want the expression
3089 value to be free'd, so set it to NULL. */
3090 if (comp_iter)
3091 {
3092 *next_ptr = comp_iter->next;
3093 comp_iter->val = NULL;
3094 gfc_free_structure_ctor_component (comp: comp_iter);
3095 }
3096 }
3097 return true;
3098}
3099
3100
3101bool
3102gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
3103 gfc_actual_arglist **arglist,
3104 bool parent)
3105{
3106 gfc_actual_arglist *actual;
3107 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
3108 gfc_constructor_base ctor_head = NULL;
3109 gfc_component *comp; /* Is set NULL when named component is first seen */
3110 const char* last_name = NULL;
3111 locus old_locus;
3112 gfc_expr *expr;
3113
3114 expr = parent ? *cexpr : e;
3115 old_locus = gfc_current_locus;
3116 if (parent)
3117 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3118 else
3119 gfc_current_locus = expr->where;
3120
3121 comp_tail = comp_head = NULL;
3122
3123 if (!parent && sym->attr.abstract)
3124 {
3125 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3126 sym->name, &expr->where);
3127 goto cleanup;
3128 }
3129
3130 comp = sym->components;
3131 actual = parent ? *arglist : expr->value.function.actual;
3132 for ( ; actual; )
3133 {
3134 gfc_component *this_comp = NULL;
3135
3136 if (!comp_head)
3137 comp_tail = comp_head = gfc_get_structure_ctor_component ();
3138 else
3139 {
3140 comp_tail->next = gfc_get_structure_ctor_component ();
3141 comp_tail = comp_tail->next;
3142 }
3143 if (actual->name)
3144 {
3145 if (!gfc_notify_std (GFC_STD_F2003, "Structure"
3146 " constructor with named arguments at %C"))
3147 goto cleanup;
3148
3149 comp_tail->name = xstrdup (actual->name);
3150 last_name = comp_tail->name;
3151 comp = NULL;
3152 }
3153 else
3154 {
3155 /* Components without name are not allowed after the first named
3156 component initializer! */
3157 if (!comp || comp->attr.artificial)
3158 {
3159 if (last_name)
3160 gfc_error ("Component initializer without name after component"
3161 " named %s at %L", last_name,
3162 actual->expr ? &actual->expr->where
3163 : &gfc_current_locus);
3164 else
3165 gfc_error ("Too many components in structure constructor at "
3166 "%L", actual->expr ? &actual->expr->where
3167 : &gfc_current_locus);
3168 goto cleanup;
3169 }
3170
3171 comp_tail->name = xstrdup (comp->name);
3172 }
3173
3174 /* Find the current component in the structure definition and check
3175 its access is not private. */
3176 if (comp)
3177 this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
3178 else
3179 {
3180 this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
3181 false, false, NULL);
3182 comp = NULL; /* Reset needed! */
3183 }
3184
3185 /* Here we can check if a component name is given which does not
3186 correspond to any component of the defined structure. */
3187 if (!this_comp)
3188 goto cleanup;
3189
3190 /* For a constant string constructor, make sure the length is
3191 correct; truncate or fill with blanks if needed. */
3192 if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
3193 && this_comp->ts.u.cl && this_comp->ts.u.cl->length
3194 && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
3195 && this_comp->ts.u.cl->length->ts.type == BT_INTEGER
3196 && actual->expr->ts.type == BT_CHARACTER
3197 && actual->expr->expr_type == EXPR_CONSTANT)
3198 {
3199 ptrdiff_t c, e1;
3200 c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
3201 e1 = actual->expr->value.character.length;
3202
3203 if (c != e1)
3204 {
3205 ptrdiff_t i, to;
3206 gfc_char_t *dest;
3207 dest = gfc_get_wide_string (c + 1);
3208
3209 to = e1 < c ? e1 : c;
3210 for (i = 0; i < to; i++)
3211 dest[i] = actual->expr->value.character.string[i];
3212
3213 for (i = e1; i < c; i++)
3214 dest[i] = ' ';
3215
3216 dest[c] = '\0';
3217 free (ptr: actual->expr->value.character.string);
3218
3219 actual->expr->value.character.length = c;
3220 actual->expr->value.character.string = dest;
3221
3222 if (warn_line_truncation && c < e1)
3223 gfc_warning_now (opt: OPT_Wcharacter_truncation,
3224 "CHARACTER expression will be truncated "
3225 "in constructor (%ld/%ld) at %L", (long int) c,
3226 (long int) e1, &actual->expr->where);
3227 }
3228 }
3229
3230 comp_tail->val = actual->expr;
3231 if (actual->expr != NULL)
3232 comp_tail->where = actual->expr->where;
3233 actual->expr = NULL;
3234
3235 /* Check if this component is already given a value. */
3236 for (comp_iter = comp_head; comp_iter != comp_tail;
3237 comp_iter = comp_iter->next)
3238 {
3239 gcc_assert (comp_iter);
3240 if (!strcmp (s1: comp_iter->name, s2: comp_tail->name))
3241 {
3242 gfc_error ("Component %qs is initialized twice in the structure"
3243 " constructor at %L", comp_tail->name,
3244 comp_tail->val ? &comp_tail->where
3245 : &gfc_current_locus);
3246 goto cleanup;
3247 }
3248 }
3249
3250 /* F2008, R457/C725, for PURE C1283. */
3251 if (this_comp->attr.pointer && comp_tail->val
3252 && gfc_is_coindexed (comp_tail->val))
3253 {
3254 gfc_error ("Coindexed expression to pointer component %qs in "
3255 "structure constructor at %L", comp_tail->name,
3256 &comp_tail->where);
3257 goto cleanup;
3258 }
3259
3260 /* If not explicitly a parent constructor, gather up the components
3261 and build one. */
3262 if (comp && comp == sym->components
3263 && sym->attr.extension
3264 && comp_tail->val
3265 && (!gfc_bt_struct (comp_tail->val->ts.type)
3266 ||
3267 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
3268 {
3269 bool m;
3270 gfc_actual_arglist *arg_null = NULL;
3271
3272 actual->expr = comp_tail->val;
3273 comp_tail->val = NULL;
3274
3275 m = gfc_convert_to_structure_constructor (NULL,
3276 sym: comp->ts.u.derived, cexpr: &comp_tail->val,
3277 arglist: comp->ts.u.derived->attr.zero_comp
3278 ? &arg_null : &actual, parent: true);
3279 if (!m)
3280 goto cleanup;
3281
3282 if (comp->ts.u.derived->attr.zero_comp)
3283 {
3284 comp = comp->next;
3285 continue;
3286 }
3287 }
3288
3289 if (comp)
3290 comp = comp->next;
3291 if (parent && !comp)
3292 break;
3293
3294 if (actual)
3295 actual = actual->next;
3296 }
3297
3298 if (!build_actual_constructor (comp_head: &comp_head, ctor_head: &ctor_head, sym))
3299 goto cleanup;
3300
3301 /* No component should be left, as this should have caused an error in the
3302 loop constructing the component-list (name that does not correspond to any
3303 component in the structure definition). */
3304 if (comp_head && sym->attr.extension)
3305 {
3306 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
3307 {
3308 gfc_error ("component %qs at %L has already been set by a "
3309 "parent derived type constructor", comp_iter->name,
3310 &comp_iter->where);
3311 }
3312 goto cleanup;
3313 }
3314 else
3315 gcc_assert (!comp_head);
3316
3317 if (parent)
3318 {
3319 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
3320 expr->ts.u.derived = sym;
3321 expr->value.constructor = ctor_head;
3322 *cexpr = expr;
3323 }
3324 else
3325 {
3326 expr->ts.u.derived = sym;
3327 expr->ts.kind = 0;
3328 expr->ts.type = BT_DERIVED;
3329 expr->value.constructor = ctor_head;
3330 expr->expr_type = EXPR_STRUCTURE;
3331 }
3332
3333 gfc_current_locus = old_locus;
3334 if (parent)
3335 *arglist = actual;
3336 return true;
3337
3338 cleanup:
3339 gfc_current_locus = old_locus;
3340
3341 for (comp_iter = comp_head; comp_iter; )
3342 {
3343 gfc_structure_ctor_component *next = comp_iter->next;
3344 gfc_free_structure_ctor_component (comp: comp_iter);
3345 comp_iter = next;
3346 }
3347 gfc_constructor_free (base: ctor_head);
3348
3349 return false;
3350}
3351
3352
3353match
3354gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
3355{
3356 match m;
3357 gfc_expr *e;
3358 gfc_symtree *symtree;
3359 bool t = true;
3360
3361 gfc_get_ha_sym_tree (sym->name, &symtree);
3362
3363 e = gfc_get_expr ();
3364 e->symtree = symtree;
3365 e->expr_type = EXPR_FUNCTION;
3366 e->where = gfc_current_locus;
3367
3368 gcc_assert (gfc_fl_struct (sym->attr.flavor)
3369 && symtree->n.sym->attr.flavor == FL_PROCEDURE);
3370 e->value.function.esym = sym;
3371 e->symtree->n.sym->attr.generic = 1;
3372
3373 m = gfc_match_actual_arglist (sub_flag: 0, argp: &e->value.function.actual);
3374 if (m != MATCH_YES)
3375 {
3376 gfc_free_expr (e);
3377 return m;
3378 }
3379
3380 if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, parent: false))
3381 {
3382 gfc_free_expr (e);
3383 return MATCH_ERROR;
3384 }
3385
3386 /* If a structure constructor is in a DATA statement, then each entity
3387 in the structure constructor must be a constant. Try to reduce the
3388 expression here. */
3389 if (gfc_in_match_data ())
3390 t = gfc_reduce_init_expr (expr: e);
3391
3392 if (t)
3393 {
3394 *result = e;
3395 return MATCH_YES;
3396 }
3397 else
3398 {
3399 gfc_free_expr (e);
3400 return MATCH_ERROR;
3401 }
3402}
3403
3404
3405/* If the symbol is an implicit do loop index and implicitly typed,
3406 it should not be host associated. Provide a symtree from the
3407 current namespace. */
3408static match
3409check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
3410{
3411 if ((*sym)->attr.flavor == FL_VARIABLE
3412 && (*sym)->ns != gfc_current_ns
3413 && (*sym)->attr.implied_index
3414 && (*sym)->attr.implicit_type
3415 && !(*sym)->attr.use_assoc)
3416 {
3417 int i;
3418 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
3419 if (i)
3420 return MATCH_ERROR;
3421 *sym = (*st)->n.sym;
3422 }
3423 return MATCH_YES;
3424}
3425
3426
3427/* Procedure pointer as function result: Replace the function symbol by the
3428 auto-generated hidden result variable named "ppr@". */
3429
3430static bool
3431replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
3432{
3433 /* Check for procedure pointer result variable. */
3434 if ((*sym)->attr.function && !(*sym)->attr.external
3435 && (*sym)->result && (*sym)->result != *sym
3436 && (*sym)->result->attr.proc_pointer
3437 && (*sym) == gfc_current_ns->proc_name
3438 && (*sym) == (*sym)->result->ns->proc_name
3439 && strcmp (s1: "ppr@", s2: (*sym)->result->name) == 0)
3440 {
3441 /* Automatic replacement with "hidden" result variable. */
3442 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
3443 *sym = (*sym)->result;
3444 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
3445 return true;
3446 }
3447 return false;
3448}
3449
3450
3451/* Matches a variable name followed by anything that might follow it--
3452 array reference, argument list of a function, etc. */
3453
3454match
3455gfc_match_rvalue (gfc_expr **result)
3456{
3457 gfc_actual_arglist *actual_arglist;
3458 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
3459 gfc_state_data *st;
3460 gfc_symbol *sym;
3461 gfc_symtree *symtree;
3462 locus where, old_loc;
3463 gfc_expr *e;
3464 match m, m2;
3465 int i;
3466 gfc_typespec *ts;
3467 bool implicit_char;
3468 gfc_ref *ref;
3469
3470 m = gfc_match ("%%loc");
3471 if (m == MATCH_YES)
3472 {
3473 if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
3474 return MATCH_ERROR;
3475 strncpy (dest: name, src: "loc", n: 4);
3476 }
3477
3478 else
3479 {
3480 m = gfc_match_name (name);
3481 if (m != MATCH_YES)
3482 return m;
3483 }
3484
3485 /* Check if the symbol exists. */
3486 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
3487 return MATCH_ERROR;
3488
3489 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3490 type. For derived types we create a generic symbol which links to the
3491 derived type symbol; STRUCTUREs are simpler and must not conflict with
3492 variables. */
3493 if (!symtree)
3494 if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
3495 return MATCH_ERROR;
3496 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
3497 {
3498 if (gfc_find_state (COMP_INTERFACE)
3499 && !gfc_current_ns->has_import_set)
3500 i = gfc_get_sym_tree (name, NULL, &symtree, false);
3501 else
3502 i = gfc_get_ha_sym_tree (name, &symtree);
3503 if (i)
3504 return MATCH_ERROR;
3505 }
3506
3507
3508 sym = symtree->n.sym;
3509 e = NULL;
3510 where = gfc_current_locus;
3511
3512 replace_hidden_procptr_result (sym: &sym, st: &symtree);
3513
3514 /* If this is an implicit do loop index and implicitly typed,
3515 it should not be host associated. */
3516 m = check_for_implicit_index (st: &symtree, sym: &sym);
3517 if (m != MATCH_YES)
3518 return m;
3519
3520 gfc_set_sym_referenced (sym);
3521 sym->attr.implied_index = 0;
3522
3523 if (sym->attr.function && sym->result == sym)
3524 {
3525 /* See if this is a directly recursive function call. */
3526 gfc_gobble_whitespace ();
3527 if (sym->attr.recursive
3528 && gfc_peek_ascii_char () == '('
3529 && gfc_current_ns->proc_name == sym
3530 && !sym->attr.dimension)
3531 {
3532 gfc_error ("%qs at %C is the name of a recursive function "
3533 "and so refers to the result variable. Use an "
3534 "explicit RESULT variable for direct recursion "
3535 "(12.5.2.1)", sym->name);
3536 return MATCH_ERROR;
3537 }
3538
3539 if (gfc_is_function_return_value (sym, ns: gfc_current_ns))
3540 goto variable;
3541
3542 if (sym->attr.entry
3543 && (sym->ns == gfc_current_ns
3544 || sym->ns == gfc_current_ns->parent))
3545 {
3546 gfc_entry_list *el = NULL;
3547
3548 for (el = sym->ns->entries; el; el = el->next)
3549 if (sym == el->sym)
3550 goto variable;
3551 }
3552 }
3553
3554 if (gfc_matching_procptr_assignment)
3555 {
3556 /* It can be a procedure or a derived-type procedure or a not-yet-known
3557 type. */
3558 if (sym->attr.flavor != FL_UNKNOWN
3559 && sym->attr.flavor != FL_PROCEDURE
3560 && sym->attr.flavor != FL_PARAMETER
3561 && sym->attr.flavor != FL_VARIABLE)
3562 {
3563 gfc_error ("Symbol at %C is not appropriate for an expression");
3564 return MATCH_ERROR;
3565 }
3566 goto procptr0;
3567 }
3568
3569 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
3570 goto function0;
3571
3572 if (sym->attr.generic)
3573 goto generic_function;
3574
3575 switch (sym->attr.flavor)
3576 {
3577 case FL_VARIABLE:
3578 variable:
3579 e = gfc_get_expr ();
3580
3581 e->expr_type = EXPR_VARIABLE;
3582 e->symtree = symtree;
3583
3584 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3585 break;
3586
3587 case FL_PARAMETER:
3588 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3589 end up here. Unfortunately, sym->value->expr_type is set to
3590 EXPR_CONSTANT, and so the if () branch would be followed without
3591 the !sym->as check. */
3592 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
3593 e = gfc_copy_expr (sym->value);
3594 else
3595 {
3596 e = gfc_get_expr ();
3597 e->expr_type = EXPR_VARIABLE;
3598 }
3599
3600 e->symtree = symtree;
3601 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3602
3603 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
3604 break;
3605
3606 /* Variable array references to derived type parameters cause
3607 all sorts of headaches in simplification. Treating such
3608 expressions as variable works just fine for all array
3609 references. */
3610 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
3611 {
3612 for (ref = e->ref; ref; ref = ref->next)
3613 if (ref->type == REF_ARRAY)
3614 break;
3615
3616 if (ref == NULL || ref->u.ar.type == AR_FULL)
3617 break;
3618
3619 ref = e->ref;
3620 e->ref = NULL;
3621 gfc_free_expr (e);
3622 e = gfc_get_expr ();
3623 e->expr_type = EXPR_VARIABLE;
3624 e->symtree = symtree;
3625 e->ref = ref;
3626 }
3627
3628 break;
3629
3630 case FL_STRUCT:
3631 case FL_DERIVED:
3632 sym = gfc_use_derived (sym);
3633 if (sym == NULL)
3634 m = MATCH_ERROR;
3635 else
3636 goto generic_function;
3637 break;
3638
3639 /* If we're here, then the name is known to be the name of a
3640 procedure, yet it is not sure to be the name of a function. */
3641 case FL_PROCEDURE:
3642
3643 /* Procedure Pointer Assignments. */
3644 procptr0:
3645 if (gfc_matching_procptr_assignment)
3646 {
3647 gfc_gobble_whitespace ();
3648 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
3649 /* Parse functions returning a procptr. */
3650 goto function0;
3651
3652 e = gfc_get_expr ();
3653 e->expr_type = EXPR_VARIABLE;
3654 e->symtree = symtree;
3655 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3656 if (!e->ref && sym->attr.flavor == FL_UNKNOWN
3657 && sym->ts.type == BT_UNKNOWN
3658 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
3659 {
3660 m = MATCH_ERROR;
3661 break;
3662 }
3663 break;
3664 }
3665
3666 if (sym->attr.subroutine)
3667 {
3668 gfc_error ("Unexpected use of subroutine name %qs at %C",
3669 sym->name);
3670 m = MATCH_ERROR;
3671 break;
3672 }
3673
3674 /* At this point, the name has to be a non-statement function.
3675 If the name is the same as the current function being
3676 compiled, then we have a variable reference (to the function
3677 result) if the name is non-recursive. */
3678
3679 st = gfc_enclosing_unit (NULL);
3680
3681 if (st != NULL
3682 && st->state == COMP_FUNCTION
3683 && st->sym == sym
3684 && !sym->attr.recursive)
3685 {
3686 e = gfc_get_expr ();
3687 e->symtree = symtree;
3688 e->expr_type = EXPR_VARIABLE;
3689
3690 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3691 break;
3692 }
3693
3694 /* Match a function reference. */
3695 function0:
3696 m = gfc_match_actual_arglist (sub_flag: 0, argp: &actual_arglist);
3697 if (m == MATCH_NO)
3698 {
3699 if (sym->attr.proc == PROC_ST_FUNCTION)
3700 gfc_error ("Statement function %qs requires argument list at %C",
3701 sym->name);
3702 else
3703 gfc_error ("Function %qs requires an argument list at %C",
3704 sym->name);
3705
3706 m = MATCH_ERROR;
3707 break;
3708 }
3709
3710 if (m != MATCH_YES)
3711 {
3712 m = MATCH_ERROR;
3713 break;
3714 }
3715
3716 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
3717 sym = symtree->n.sym;
3718
3719 replace_hidden_procptr_result (sym: &sym, st: &symtree);
3720
3721 e = gfc_get_expr ();
3722 e->symtree = symtree;
3723 e->expr_type = EXPR_FUNCTION;
3724 e->value.function.actual = actual_arglist;
3725 e->where = gfc_current_locus;
3726
3727 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3728 && CLASS_DATA (sym)->as)
3729 e->rank = CLASS_DATA (sym)->as->rank;
3730 else if (sym->as != NULL)
3731 e->rank = sym->as->rank;
3732
3733 if (!sym->attr.function
3734 && !gfc_add_function (&sym->attr, sym->name, NULL))
3735 {
3736 m = MATCH_ERROR;
3737 break;
3738 }
3739
3740 /* Check here for the existence of at least one argument for the
3741 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3742 argument(s) given will be checked in gfc_iso_c_func_interface,
3743 during resolution of the function call. */
3744 if (sym->attr.is_iso_c == 1
3745 && (sym->from_intmod == INTMOD_ISO_C_BINDING
3746 && (sym->intmod_sym_id == ISOCBINDING_LOC
3747 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
3748 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
3749 {
3750 /* make sure we were given a param */
3751 if (actual_arglist == NULL)
3752 {
3753 gfc_error ("Missing argument to %qs at %C", sym->name);
3754 m = MATCH_ERROR;
3755 break;
3756 }
3757 }
3758
3759 if (sym->result == NULL)
3760 sym->result = sym;
3761
3762 gfc_gobble_whitespace ();
3763 /* F08:C612. */
3764 if (gfc_peek_ascii_char() == '%')
3765 {
3766 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3767 "function reference at %C");
3768 m = MATCH_ERROR;
3769 break;
3770 }
3771
3772 m = MATCH_YES;
3773 break;
3774
3775 case FL_UNKNOWN:
3776
3777 /* Special case for derived type variables that get their types
3778 via an IMPLICIT statement. This can't wait for the
3779 resolution phase. */
3780
3781 old_loc = gfc_current_locus;
3782 if (gfc_match_member_sep (sym) == MATCH_YES
3783 && sym->ts.type == BT_UNKNOWN
3784 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
3785 gfc_set_default_type (sym, 0, sym->ns);
3786 gfc_current_locus = old_loc;
3787
3788 /* If the symbol has a (co)dimension attribute, the expression is a
3789 variable. */
3790
3791 if (sym->attr.dimension || sym->attr.codimension)
3792 {
3793 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3794 {
3795 m = MATCH_ERROR;
3796 break;
3797 }
3798
3799 e = gfc_get_expr ();
3800 e->symtree = symtree;
3801 e->expr_type = EXPR_VARIABLE;
3802 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3803 break;
3804 }
3805
3806 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3807 && (CLASS_DATA (sym)->attr.dimension
3808 || CLASS_DATA (sym)->attr.codimension))
3809 {
3810 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3811 {
3812 m = MATCH_ERROR;
3813 break;
3814 }
3815
3816 e = gfc_get_expr ();
3817 e->symtree = symtree;
3818 e->expr_type = EXPR_VARIABLE;
3819 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3820 break;
3821 }
3822
3823 /* Name is not an array, so we peek to see if a '(' implies a
3824 function call or a substring reference. Otherwise the
3825 variable is just a scalar. */
3826
3827 gfc_gobble_whitespace ();
3828 if (gfc_peek_ascii_char () != '(')
3829 {
3830 /* Assume a scalar variable */
3831 e = gfc_get_expr ();
3832 e->symtree = symtree;
3833 e->expr_type = EXPR_VARIABLE;
3834
3835 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3836 {
3837 m = MATCH_ERROR;
3838 break;
3839 }
3840
3841 /*FIXME:??? gfc_match_varspec does set this for us: */
3842 e->ts = sym->ts;
3843 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3844 break;
3845 }
3846
3847 /* See if this is a function reference with a keyword argument
3848 as first argument. We do this because otherwise a spurious
3849 symbol would end up in the symbol table. */
3850
3851 old_loc = gfc_current_locus;
3852 m2 = gfc_match (" ( %n =", argname);
3853 gfc_current_locus = old_loc;
3854
3855 e = gfc_get_expr ();
3856 e->symtree = symtree;
3857
3858 if (m2 != MATCH_YES)
3859 {
3860 /* Try to figure out whether we're dealing with a character type.
3861 We're peeking ahead here, because we don't want to call
3862 match_substring if we're dealing with an implicitly typed
3863 non-character variable. */
3864 implicit_char = false;
3865 if (sym->ts.type == BT_UNKNOWN)
3866 {
3867 ts = gfc_get_default_type (sym->name, NULL);
3868 if (ts->type == BT_CHARACTER)
3869 implicit_char = true;
3870 }
3871
3872 /* See if this could possibly be a substring reference of a name
3873 that we're not sure is a variable yet. */
3874
3875 if ((implicit_char || sym->ts.type == BT_CHARACTER)
3876 && match_substring (cl: sym->ts.u.cl, init: 0, result: &e->ref, deferred: false) == MATCH_YES)
3877 {
3878
3879 e->expr_type = EXPR_VARIABLE;
3880
3881 if (sym->attr.flavor != FL_VARIABLE
3882 && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
3883 sym->name, NULL))
3884 {
3885 m = MATCH_ERROR;
3886 break;
3887 }
3888
3889 if (sym->ts.type == BT_UNKNOWN
3890 && !gfc_set_default_type (sym, 1, NULL))
3891 {
3892 m = MATCH_ERROR;
3893 break;
3894 }
3895
3896 e->ts = sym->ts;
3897 if (e->ref)
3898 e->ts.u.cl = NULL;
3899 m = MATCH_YES;
3900 break;
3901 }
3902 }
3903
3904 /* Give up, assume we have a function. */
3905
3906 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3907 sym = symtree->n.sym;
3908 e->expr_type = EXPR_FUNCTION;
3909
3910 if (!sym->attr.function
3911 && !gfc_add_function (&sym->attr, sym->name, NULL))
3912 {
3913 m = MATCH_ERROR;
3914 break;
3915 }
3916
3917 sym->result = sym;
3918
3919 m = gfc_match_actual_arglist (sub_flag: 0, argp: &e->value.function.actual);
3920 if (m == MATCH_NO)
3921 gfc_error ("Missing argument list in function %qs at %C", sym->name);
3922
3923 if (m != MATCH_YES)
3924 {
3925 m = MATCH_ERROR;
3926 break;
3927 }
3928
3929 /* If our new function returns a character, array or structure
3930 type, it might have subsequent references. */
3931
3932 m = gfc_match_varspec (primary: e, equiv_flag: 0, sub_flag: false, ppc_arg: true);
3933 if (m == MATCH_NO)
3934 m = MATCH_YES;
3935
3936 break;
3937
3938 generic_function:
3939 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3940 specially. Creates a generic symbol for derived types. */
3941 gfc_find_sym_tree (name, NULL, 1, &symtree);
3942 if (!symtree)
3943 gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
3944 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
3945 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3946
3947 e = gfc_get_expr ();
3948 e->symtree = symtree;
3949 e->expr_type = EXPR_FUNCTION;
3950
3951 if (gfc_fl_struct (sym->attr.flavor))
3952 {
3953 e->value.function.esym = sym;
3954 e->symtree->n.sym->attr.generic = 1;
3955 }
3956
3957 m = gfc_match_actual_arglist (sub_flag: 0, argp: &e->value.function.actual);
3958 break;
3959
3960 case FL_NAMELIST:
3961 m = MATCH_ERROR;
3962 break;
3963
3964 default:
3965 gfc_error ("Symbol at %C is not appropriate for an expression");
3966 return MATCH_ERROR;
3967 }
3968
3969 if (m == MATCH_YES)
3970 {
3971 e->where = where;
3972 *result = e;
3973 }
3974 else
3975 gfc_free_expr (e);
3976
3977 return m;
3978}
3979
3980
3981/* Match a variable, i.e. something that can be assigned to. This
3982 starts as a symbol, can be a structure component or an array
3983 reference. It can be a function if the function doesn't have a
3984 separate RESULT variable. If the symbol has not been previously
3985 seen, we assume it is a variable.
3986
3987 This function is called by two interface functions:
3988 gfc_match_variable, which has host_flag = 1, and
3989 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3990 match of the symbol to the local scope. */
3991
3992static match
3993match_variable (gfc_expr **result, int equiv_flag, int host_flag)
3994{
3995 gfc_symbol *sym, *dt_sym;
3996 gfc_symtree *st;
3997 gfc_expr *expr;
3998 locus where, old_loc;
3999 match m;
4000
4001 /* Since nothing has any business being an lvalue in a module
4002 specification block, an interface block or a contains section,
4003 we force the changed_symbols mechanism to work by setting
4004 host_flag to 0. This prevents valid symbols that have the name
4005 of keywords, such as 'end', being turned into variables by
4006 failed matching to assignments for, e.g., END INTERFACE. */
4007 if (gfc_current_state () == COMP_MODULE
4008 || gfc_current_state () == COMP_SUBMODULE
4009 || gfc_current_state () == COMP_INTERFACE
4010 || gfc_current_state () == COMP_CONTAINS)
4011 host_flag = 0;
4012
4013 where = gfc_current_locus;
4014 m = gfc_match_sym_tree (&st, host_flag);
4015 if (m != MATCH_YES)
4016 return m;
4017
4018 sym = st->n.sym;
4019
4020 /* If this is an implicit do loop index and implicitly typed,
4021 it should not be host associated. */
4022 m = check_for_implicit_index (st: &st, sym: &sym);
4023 if (m != MATCH_YES)
4024 return m;
4025
4026 sym->attr.implied_index = 0;
4027
4028 gfc_set_sym_referenced (sym);
4029
4030 /* STRUCTUREs may share names with variables, but derived types may not. */
4031 if (sym->attr.flavor == FL_PROCEDURE && sym->generic
4032 && (dt_sym = gfc_find_dt_in_generic (sym)))
4033 {
4034 if (dt_sym->attr.flavor == FL_DERIVED)
4035 gfc_error ("Derived type %qs cannot be used as a variable at %C",
4036 sym->name);
4037 return MATCH_ERROR;
4038 }
4039
4040 switch (sym->attr.flavor)
4041 {
4042 case FL_VARIABLE:
4043 /* Everything is alright. */
4044 break;
4045
4046 case FL_UNKNOWN:
4047 {
4048 sym_flavor flavor = FL_UNKNOWN;
4049
4050 gfc_gobble_whitespace ();
4051
4052 if (sym->attr.external || sym->attr.procedure
4053 || sym->attr.function || sym->attr.subroutine)
4054 flavor = FL_PROCEDURE;
4055
4056 /* If it is not a procedure, is not typed and is host associated,
4057 we cannot give it a flavor yet. */
4058 else if (sym->ns == gfc_current_ns->parent
4059 && sym->ts.type == BT_UNKNOWN)
4060 break;
4061
4062 /* These are definitive indicators that this is a variable. */
4063 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
4064 || sym->attr.pointer || sym->as != NULL)
4065 flavor = FL_VARIABLE;
4066
4067 if (flavor != FL_UNKNOWN
4068 && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
4069 return MATCH_ERROR;
4070 }
4071 break;
4072
4073 case FL_PARAMETER:
4074 if (equiv_flag)
4075 {
4076 gfc_error ("Named constant at %C in an EQUIVALENCE");
4077 return MATCH_ERROR;
4078 }
4079 if (gfc_in_match_data())
4080 {
4081 gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %C",
4082 sym->name);
4083 return MATCH_ERROR;
4084 }
4085 /* Otherwise this is checked for an error given in the
4086 variable definition context checks. */
4087 break;
4088
4089 case FL_PROCEDURE:
4090 /* Check for a nonrecursive function result variable. */
4091 if (sym->attr.function
4092 && !sym->attr.external
4093 && sym->result == sym
4094 && (gfc_is_function_return_value (sym, ns: gfc_current_ns)
4095 || (sym->attr.entry
4096 && sym->ns == gfc_current_ns)
4097 || (sym->attr.entry
4098 && sym->ns == gfc_current_ns->parent)))
4099 {
4100 /* If a function result is a derived type, then the derived
4101 type may still have to be resolved. */
4102
4103 if (sym->ts.type == BT_DERIVED
4104 && gfc_use_derived (sym->ts.u.derived) == NULL)
4105 return MATCH_ERROR;
4106 break;
4107 }
4108
4109 if (sym->attr.proc_pointer
4110 || replace_hidden_procptr_result (sym: &sym, st: &st))
4111 break;
4112
4113 /* Fall through to error */
4114 gcc_fallthrough ();
4115
4116 default:
4117 gfc_error ("%qs at %C is not a variable", sym->name);
4118 return MATCH_ERROR;
4119 }
4120
4121 /* Special case for derived type variables that get their types
4122 via an IMPLICIT statement. This can't wait for the
4123 resolution phase. */
4124
4125 {
4126 gfc_namespace * implicit_ns;
4127
4128 if (gfc_current_ns->proc_name == sym)
4129 implicit_ns = gfc_current_ns;
4130 else
4131 implicit_ns = sym->ns;
4132
4133 old_loc = gfc_current_locus;
4134 if (gfc_match_member_sep (sym) == MATCH_YES
4135 && sym->ts.type == BT_UNKNOWN
4136 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
4137 gfc_set_default_type (sym, 0, implicit_ns);
4138 gfc_current_locus = old_loc;
4139 }
4140
4141 expr = gfc_get_expr ();
4142
4143 expr->expr_type = EXPR_VARIABLE;
4144 expr->symtree = st;
4145 expr->ts = sym->ts;
4146 expr->where = where;
4147
4148 /* Now see if we have to do more. */
4149 m = gfc_match_varspec (primary: expr, equiv_flag, sub_flag: false, ppc_arg: false);
4150 if (m != MATCH_YES)
4151 {
4152 gfc_free_expr (expr);
4153 return m;
4154 }
4155
4156 *result = expr;
4157 return MATCH_YES;
4158}
4159
4160
4161match
4162gfc_match_variable (gfc_expr **result, int equiv_flag)
4163{
4164 return match_variable (result, equiv_flag, host_flag: 1);
4165}
4166
4167
4168match
4169gfc_match_equiv_variable (gfc_expr **result)
4170{
4171 return match_variable (result, equiv_flag: 1, host_flag: 0);
4172}
4173
4174

source code of gcc/fortran/primary.cc