1 /* Primary expression subroutines
2 Copyright (C) 2000-2021 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
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
31 int 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
39 static match
match_kind_param(int * kind,int * is_iso_c)40 match_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);
49 if (m != MATCH_NO)
50 return m;
51
52 m = gfc_match_name (name);
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
90 static int
get_kind(int * is_iso_c)91 get_kind (int *is_iso_c)
92 {
93 int kind;
94 match m;
95
96 *is_iso_c = 0;
97
98 if (gfc_match_char ('_') != MATCH_YES)
99 return -2;
100
101 m = match_kind_param (&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
112 int
gfc_check_digit(char c,int radix)113 gfc_check_digit (char c, int radix)
114 {
115 int 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
148 static int
match_digits(int signflag,int radix,char * buffer)149 match_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
194 static gfc_expr *
convert_integer(const char * buffer,int kind,int radix,locus * where)195 convert_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
214 static gfc_expr *
convert_real(const char * buffer,int kind,locus * where)215 convert_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
229 static gfc_expr *
convert_complex(gfc_expr * real,gfc_expr * imag,int kind)230 convert_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
245 static match
match_integer_constant(gfc_expr ** result,int signflag)246 match_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, 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 (buffer, '\0', length + 1);
263
264 gfc_gobble_whitespace ();
265
266 match_digits (signflag, 10, buffer);
267
268 kind = get_kind (&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, 10, &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
302 static match
match_hollerith_constant(gfc_expr ** result)303 match_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 (&e, 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
374 cleanup:
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
386 static match
match_boz_constant(gfc_expr ** result)387 match_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 (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 (buffer, '\0', length + 1);
482
483 match_digits (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 (e->boz.str, buffer, 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
505 backup:
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
514 static match
match_real_constant(gfc_expr ** result,int signflag)515 match_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_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
626 done:
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 (buffer, '\0', 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);
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, &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_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 pecision
760 than the kind kan 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 (buffer, 'e');
775 if (c1 == NULL)
776 c1 = buffer + strlen(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_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
814 cleanup:
815 gfc_free_expr (e);
816 return MATCH_ERROR;
817 }
818
819
820 /* Match a substring reference. */
821
822 static match
match_substring(gfc_charlen * cl,int init,gfc_ref ** result,bool deferred)823 match_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
894 syntax:
895 gfc_error ("Syntax error in SUBSTRING specification at %C");
896 m = MATCH_ERROR;
897
898 cleanup:
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
917 static gfc_char_t
next_string_char(gfc_char_t delimiter,int * ret)918 next_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 (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
970 static match
match_charkind_name(char * name)971 match_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
1023 static match
match_string_constant(gfc_expr ** result)1024 match_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 {
1079 gfc_gobble_whitespace ();
1080 c = gfc_next_char ();
1081 }
1082
1083 if (c != '_')
1084 goto no_match;
1085
1086 gfc_gobble_whitespace ();
1087
1088 c = gfc_next_char ();
1089 if (c != '\'' && c != '"')
1090 goto no_match;
1091
1092 start_locus = gfc_current_locus;
1093
1094 if (kind == -1)
1095 {
1096 if (gfc_extract_int (sym->value, &kind, 1))
1097 return MATCH_ERROR;
1098 gfc_set_sym_referenced (sym);
1099 }
1100
1101 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1102 {
1103 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
1104 return MATCH_ERROR;
1105 }
1106
1107 got_delim:
1108 /* Scan the string into a block of memory by first figuring out how
1109 long it is, allocating the structure, then re-reading it. This
1110 isn't particularly efficient, but string constants aren't that
1111 common in most code. TODO: Use obstacks? */
1112
1113 delimiter = c;
1114 length = 0;
1115
1116 for (;;)
1117 {
1118 c = next_string_char (delimiter, &ret);
1119 if (ret == -1)
1120 break;
1121 if (ret == -2)
1122 {
1123 gfc_current_locus = start_locus;
1124 gfc_error ("Unterminated character constant beginning at %C");
1125 return MATCH_ERROR;
1126 }
1127
1128 length++;
1129 }
1130
1131 /* Peek at the next character to see if it is a b, o, z, or x for the
1132 postfixed BOZ literal constants. */
1133 peek = gfc_peek_ascii_char ();
1134 if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
1135 goto no_match;
1136
1137 e = gfc_get_character_expr (kind, &start_locus, NULL, length);
1138
1139 gfc_current_locus = start_locus;
1140
1141 /* We disable the warning for the following loop as the warning has already
1142 been printed in the loop above. */
1143 save_warn_ampersand = warn_ampersand;
1144 warn_ampersand = false;
1145
1146 p = e->value.character.string;
1147 for (size_t i = 0; i < length; i++)
1148 {
1149 c = next_string_char (delimiter, &ret);
1150
1151 if (!gfc_check_character_range (c, kind))
1152 {
1153 gfc_free_expr (e);
1154 gfc_error ("Character %qs in string at %C is not representable "
1155 "in character kind %d", gfc_print_wide_char (c), kind);
1156 return MATCH_ERROR;
1157 }
1158
1159 *p++ = c;
1160 }
1161
1162 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1163 warn_ampersand = save_warn_ampersand;
1164
1165 next_string_char (delimiter, &ret);
1166 if (ret != -1)
1167 gfc_internal_error ("match_string_constant(): Delimiter not found");
1168
1169 if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
1170 e->expr_type = EXPR_SUBSTRING;
1171
1172 /* Substrings with constant starting and ending points are eligible as
1173 designators (F2018, section 9.1). Simplify substrings to make them usable
1174 e.g. in data statements. */
1175 if (e->expr_type == EXPR_SUBSTRING
1176 && e->ref && e->ref->type == REF_SUBSTRING
1177 && e->ref->u.ss.start->expr_type == EXPR_CONSTANT
1178 && (e->ref->u.ss.end == NULL
1179 || e->ref->u.ss.end->expr_type == EXPR_CONSTANT))
1180 {
1181 gfc_expr *res;
1182 ptrdiff_t istart, iend;
1183 size_t length;
1184 bool equal_length = false;
1185
1186 /* Basic checks on substring starting and ending indices. */
1187 if (!gfc_resolve_substring (e->ref, &equal_length))
1188 return MATCH_ERROR;
1189
1190 length = e->value.character.length;
1191 istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer);
1192 if (e->ref->u.ss.end == NULL)
1193 iend = length;
1194 else
1195 iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer);
1196
1197 if (istart <= iend)
1198 {
1199 if (istart < 1)
1200 {
1201 gfc_error ("Substring start index (%ld) at %L below 1",
1202 (long) istart, &e->ref->u.ss.start->where);
1203 return MATCH_ERROR;
1204 }
1205 if (iend > (ssize_t) length)
1206 {
1207 gfc_error ("Substring end index (%ld) at %L exceeds string "
1208 "length", (long) iend, &e->ref->u.ss.end->where);
1209 return MATCH_ERROR;
1210 }
1211 length = iend - istart + 1;
1212 }
1213 else
1214 length = 0;
1215
1216 res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
1217 res->value.character.string = gfc_get_wide_string (length + 1);
1218 res->value.character.length = length;
1219 if (length > 0)
1220 memcpy (res->value.character.string,
1221 &e->value.character.string[istart - 1],
1222 length * sizeof (gfc_char_t));
1223 res->value.character.string[length] = '\0';
1224 e = res;
1225 }
1226
1227 *result = e;
1228
1229 return MATCH_YES;
1230
1231 no_match:
1232 gfc_current_locus = old_locus;
1233 return MATCH_NO;
1234 }
1235
1236
1237 /* Match a .true. or .false. Returns 1 if a .true. was found,
1238 0 if a .false. was found, and -1 otherwise. */
1239 static int
match_logical_constant_string(void)1240 match_logical_constant_string (void)
1241 {
1242 locus orig_loc = gfc_current_locus;
1243
1244 gfc_gobble_whitespace ();
1245 if (gfc_next_ascii_char () == '.')
1246 {
1247 char ch = gfc_next_ascii_char ();
1248 if (ch == 'f')
1249 {
1250 if (gfc_next_ascii_char () == 'a'
1251 && gfc_next_ascii_char () == 'l'
1252 && gfc_next_ascii_char () == 's'
1253 && gfc_next_ascii_char () == 'e'
1254 && gfc_next_ascii_char () == '.')
1255 /* Matched ".false.". */
1256 return 0;
1257 }
1258 else if (ch == 't')
1259 {
1260 if (gfc_next_ascii_char () == 'r'
1261 && gfc_next_ascii_char () == 'u'
1262 && gfc_next_ascii_char () == 'e'
1263 && gfc_next_ascii_char () == '.')
1264 /* Matched ".true.". */
1265 return 1;
1266 }
1267 }
1268 gfc_current_locus = orig_loc;
1269 return -1;
1270 }
1271
1272 /* Match a .true. or .false. */
1273
1274 static match
match_logical_constant(gfc_expr ** result)1275 match_logical_constant (gfc_expr **result)
1276 {
1277 gfc_expr *e;
1278 int i, kind, is_iso_c;
1279
1280 i = match_logical_constant_string ();
1281 if (i == -1)
1282 return MATCH_NO;
1283
1284 kind = get_kind (&is_iso_c);
1285 if (kind == -1)
1286 return MATCH_ERROR;
1287 if (kind == -2)
1288 kind = gfc_default_logical_kind;
1289
1290 if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1291 {
1292 gfc_error ("Bad kind for logical constant at %C");
1293 return MATCH_ERROR;
1294 }
1295
1296 e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1297 e->ts.is_c_interop = is_iso_c;
1298
1299 *result = e;
1300 return MATCH_YES;
1301 }
1302
1303
1304 /* Match a real or imaginary part of a complex constant that is a
1305 symbolic constant. */
1306
1307 static match
match_sym_complex_part(gfc_expr ** result)1308 match_sym_complex_part (gfc_expr **result)
1309 {
1310 char name[GFC_MAX_SYMBOL_LEN + 1];
1311 gfc_symbol *sym;
1312 gfc_expr *e;
1313 match m;
1314
1315 m = gfc_match_name (name);
1316 if (m != MATCH_YES)
1317 return m;
1318
1319 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1320 return MATCH_NO;
1321
1322 if (sym->attr.flavor != FL_PARAMETER)
1323 {
1324 /* Give the matcher for implied do-loops a chance to run. This yields
1325 a much saner error message for "write(*,*) (i, i=1, 6" where the
1326 right parenthesis is missing. */
1327 char c;
1328 gfc_gobble_whitespace ();
1329 c = gfc_peek_ascii_char ();
1330 if (c == '=' || c == ',')
1331 {
1332 m = MATCH_NO;
1333 }
1334 else
1335 {
1336 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1337 m = MATCH_ERROR;
1338 }
1339 return m;
1340 }
1341
1342 if (!sym->value)
1343 goto error;
1344
1345 if (!gfc_numeric_ts (&sym->value->ts))
1346 {
1347 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1348 return MATCH_ERROR;
1349 }
1350
1351 if (sym->value->rank != 0)
1352 {
1353 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1354 return MATCH_ERROR;
1355 }
1356
1357 if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
1358 "complex constant at %C"))
1359 return MATCH_ERROR;
1360
1361 switch (sym->value->ts.type)
1362 {
1363 case BT_REAL:
1364 e = gfc_copy_expr (sym->value);
1365 break;
1366
1367 case BT_COMPLEX:
1368 e = gfc_complex2real (sym->value, sym->value->ts.kind);
1369 if (e == NULL)
1370 goto error;
1371 break;
1372
1373 case BT_INTEGER:
1374 e = gfc_int2real (sym->value, gfc_default_real_kind);
1375 if (e == NULL)
1376 goto error;
1377 break;
1378
1379 default:
1380 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1381 }
1382
1383 *result = e; /* e is a scalar, real, constant expression. */
1384 return MATCH_YES;
1385
1386 error:
1387 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1388 return MATCH_ERROR;
1389 }
1390
1391
1392 /* Match a real or imaginary part of a complex number. */
1393
1394 static match
match_complex_part(gfc_expr ** result)1395 match_complex_part (gfc_expr **result)
1396 {
1397 match m;
1398
1399 m = match_sym_complex_part (result);
1400 if (m != MATCH_NO)
1401 return m;
1402
1403 m = match_real_constant (result, 1);
1404 if (m != MATCH_NO)
1405 return m;
1406
1407 return match_integer_constant (result, 1);
1408 }
1409
1410
1411 /* Try to match a complex constant. */
1412
1413 static match
match_complex_constant(gfc_expr ** result)1414 match_complex_constant (gfc_expr **result)
1415 {
1416 gfc_expr *e, *real, *imag;
1417 gfc_error_buffer old_error;
1418 gfc_typespec target;
1419 locus old_loc;
1420 int kind;
1421 match m;
1422
1423 old_loc = gfc_current_locus;
1424 real = imag = e = NULL;
1425
1426 m = gfc_match_char ('(');
1427 if (m != MATCH_YES)
1428 return m;
1429
1430 gfc_push_error (&old_error);
1431
1432 m = match_complex_part (&real);
1433 if (m == MATCH_NO)
1434 {
1435 gfc_free_error (&old_error);
1436 goto cleanup;
1437 }
1438
1439 if (gfc_match_char (',') == MATCH_NO)
1440 {
1441 /* It is possible that gfc_int2real issued a warning when
1442 converting an integer to real. Throw this away here. */
1443
1444 gfc_clear_warning ();
1445 gfc_pop_error (&old_error);
1446 m = MATCH_NO;
1447 goto cleanup;
1448 }
1449
1450 /* If m is error, then something was wrong with the real part and we
1451 assume we have a complex constant because we've seen the ','. An
1452 ambiguous case here is the start of an iterator list of some
1453 sort. These sort of lists are matched prior to coming here. */
1454
1455 if (m == MATCH_ERROR)
1456 {
1457 gfc_free_error (&old_error);
1458 goto cleanup;
1459 }
1460 gfc_pop_error (&old_error);
1461
1462 m = match_complex_part (&imag);
1463 if (m == MATCH_NO)
1464 goto syntax;
1465 if (m == MATCH_ERROR)
1466 goto cleanup;
1467
1468 m = gfc_match_char (')');
1469 if (m == MATCH_NO)
1470 {
1471 /* Give the matcher for implied do-loops a chance to run. This
1472 yields a much saner error message for (/ (i, 4=i, 6) /). */
1473 if (gfc_peek_ascii_char () == '=')
1474 {
1475 m = MATCH_ERROR;
1476 goto cleanup;
1477 }
1478 else
1479 goto syntax;
1480 }
1481
1482 if (m == MATCH_ERROR)
1483 goto cleanup;
1484
1485 /* Decide on the kind of this complex number. */
1486 if (real->ts.type == BT_REAL)
1487 {
1488 if (imag->ts.type == BT_REAL)
1489 kind = gfc_kind_max (real, imag);
1490 else
1491 kind = real->ts.kind;
1492 }
1493 else
1494 {
1495 if (imag->ts.type == BT_REAL)
1496 kind = imag->ts.kind;
1497 else
1498 kind = gfc_default_real_kind;
1499 }
1500 gfc_clear_ts (&target);
1501 target.type = BT_REAL;
1502 target.kind = kind;
1503
1504 if (real->ts.type != BT_REAL || kind != real->ts.kind)
1505 gfc_convert_type (real, &target, 2);
1506 if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1507 gfc_convert_type (imag, &target, 2);
1508
1509 e = convert_complex (real, imag, kind);
1510 e->where = gfc_current_locus;
1511
1512 gfc_free_expr (real);
1513 gfc_free_expr (imag);
1514
1515 *result = e;
1516 return MATCH_YES;
1517
1518 syntax:
1519 gfc_error ("Syntax error in COMPLEX constant at %C");
1520 m = MATCH_ERROR;
1521
1522 cleanup:
1523 gfc_free_expr (e);
1524 gfc_free_expr (real);
1525 gfc_free_expr (imag);
1526 gfc_current_locus = old_loc;
1527
1528 return m;
1529 }
1530
1531
1532 /* Match constants in any of several forms. Returns nonzero for a
1533 match, zero for no match. */
1534
1535 match
gfc_match_literal_constant(gfc_expr ** result,int signflag)1536 gfc_match_literal_constant (gfc_expr **result, int signflag)
1537 {
1538 match m;
1539
1540 m = match_complex_constant (result);
1541 if (m != MATCH_NO)
1542 return m;
1543
1544 m = match_string_constant (result);
1545 if (m != MATCH_NO)
1546 return m;
1547
1548 m = match_boz_constant (result);
1549 if (m != MATCH_NO)
1550 return m;
1551
1552 m = match_real_constant (result, signflag);
1553 if (m != MATCH_NO)
1554 return m;
1555
1556 m = match_hollerith_constant (result);
1557 if (m != MATCH_NO)
1558 return m;
1559
1560 m = match_integer_constant (result, signflag);
1561 if (m != MATCH_NO)
1562 return m;
1563
1564 m = match_logical_constant (result);
1565 if (m != MATCH_NO)
1566 return m;
1567
1568 return MATCH_NO;
1569 }
1570
1571
1572 /* This checks if a symbol is the return value of an encompassing function.
1573 Function nesting can be maximally two levels deep, but we may have
1574 additional local namespaces like BLOCK etc. */
1575
1576 bool
gfc_is_function_return_value(gfc_symbol * sym,gfc_namespace * ns)1577 gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1578 {
1579 if (!sym->attr.function || (sym->result != sym))
1580 return false;
1581 while (ns)
1582 {
1583 if (ns->proc_name == sym)
1584 return true;
1585 ns = ns->parent;
1586 }
1587 return false;
1588 }
1589
1590
1591 /* Match a single actual argument value. An actual argument is
1592 usually an expression, but can also be a procedure name. If the
1593 argument is a single name, it is not always possible to tell
1594 whether the name is a dummy procedure or not. We treat these cases
1595 by creating an argument that looks like a dummy procedure and
1596 fixing things later during resolution. */
1597
1598 static match
match_actual_arg(gfc_expr ** result)1599 match_actual_arg (gfc_expr **result)
1600 {
1601 char name[GFC_MAX_SYMBOL_LEN + 1];
1602 gfc_symtree *symtree;
1603 locus where, w;
1604 gfc_expr *e;
1605 char c;
1606
1607 gfc_gobble_whitespace ();
1608 where = gfc_current_locus;
1609
1610 switch (gfc_match_name (name))
1611 {
1612 case MATCH_ERROR:
1613 return MATCH_ERROR;
1614
1615 case MATCH_NO:
1616 break;
1617
1618 case MATCH_YES:
1619 w = gfc_current_locus;
1620 gfc_gobble_whitespace ();
1621 c = gfc_next_ascii_char ();
1622 gfc_current_locus = w;
1623
1624 if (c != ',' && c != ')')
1625 break;
1626
1627 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1628 break;
1629 /* Handle error elsewhere. */
1630
1631 /* Eliminate a couple of common cases where we know we don't
1632 have a function argument. */
1633 if (symtree == NULL)
1634 {
1635 gfc_get_sym_tree (name, NULL, &symtree, false);
1636 gfc_set_sym_referenced (symtree->n.sym);
1637 }
1638 else
1639 {
1640 gfc_symbol *sym;
1641
1642 sym = symtree->n.sym;
1643 gfc_set_sym_referenced (sym);
1644 if (sym->attr.flavor == FL_NAMELIST)
1645 {
1646 gfc_error ("Namelist %qs cannot be an argument at %L",
1647 sym->name, &where);
1648 break;
1649 }
1650 if (sym->attr.flavor != FL_PROCEDURE
1651 && sym->attr.flavor != FL_UNKNOWN)
1652 break;
1653
1654 if (sym->attr.in_common && !sym->attr.proc_pointer)
1655 {
1656 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
1657 sym->name, &sym->declared_at))
1658 return MATCH_ERROR;
1659 break;
1660 }
1661
1662 /* If the symbol is a function with itself as the result and
1663 is being defined, then we have a variable. */
1664 if (sym->attr.function && sym->result == sym)
1665 {
1666 if (gfc_is_function_return_value (sym, gfc_current_ns))
1667 break;
1668
1669 if (sym->attr.entry
1670 && (sym->ns == gfc_current_ns
1671 || sym->ns == gfc_current_ns->parent))
1672 {
1673 gfc_entry_list *el = NULL;
1674
1675 for (el = sym->ns->entries; el; el = el->next)
1676 if (sym == el->sym)
1677 break;
1678
1679 if (el)
1680 break;
1681 }
1682 }
1683 }
1684
1685 e = gfc_get_expr (); /* Leave it unknown for now */
1686 e->symtree = symtree;
1687 e->expr_type = EXPR_VARIABLE;
1688 e->ts.type = BT_PROCEDURE;
1689 e->where = where;
1690
1691 *result = e;
1692 return MATCH_YES;
1693 }
1694
1695 gfc_current_locus = where;
1696 return gfc_match_expr (result);
1697 }
1698
1699
1700 /* Match a keyword argument or type parameter spec list.. */
1701
1702 static match
match_keyword_arg(gfc_actual_arglist * actual,gfc_actual_arglist * base,bool pdt)1703 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
1704 {
1705 char name[GFC_MAX_SYMBOL_LEN + 1];
1706 gfc_actual_arglist *a;
1707 locus name_locus;
1708 match m;
1709
1710 name_locus = gfc_current_locus;
1711 m = gfc_match_name (name);
1712
1713 if (m != MATCH_YES)
1714 goto cleanup;
1715 if (gfc_match_char ('=') != MATCH_YES)
1716 {
1717 m = MATCH_NO;
1718 goto cleanup;
1719 }
1720
1721 if (pdt)
1722 {
1723 if (gfc_match_char ('*') == MATCH_YES)
1724 {
1725 actual->spec_type = SPEC_ASSUMED;
1726 goto add_name;
1727 }
1728 else if (gfc_match_char (':') == MATCH_YES)
1729 {
1730 actual->spec_type = SPEC_DEFERRED;
1731 goto add_name;
1732 }
1733 else
1734 actual->spec_type = SPEC_EXPLICIT;
1735 }
1736
1737 m = match_actual_arg (&actual->expr);
1738 if (m != MATCH_YES)
1739 goto cleanup;
1740
1741 /* Make sure this name has not appeared yet. */
1742 add_name:
1743 if (name[0] != '\0')
1744 {
1745 for (a = base; a; a = a->next)
1746 if (a->name != NULL && strcmp (a->name, name) == 0)
1747 {
1748 gfc_error ("Keyword %qs at %C has already appeared in the "
1749 "current argument list", name);
1750 return MATCH_ERROR;
1751 }
1752 }
1753
1754 actual->name = gfc_get_string ("%s", name);
1755 return MATCH_YES;
1756
1757 cleanup:
1758 gfc_current_locus = name_locus;
1759 return m;
1760 }
1761
1762
1763 /* Match an argument list function, such as %VAL. */
1764
1765 static match
match_arg_list_function(gfc_actual_arglist * result)1766 match_arg_list_function (gfc_actual_arglist *result)
1767 {
1768 char name[GFC_MAX_SYMBOL_LEN + 1];
1769 locus old_locus;
1770 match m;
1771
1772 old_locus = gfc_current_locus;
1773
1774 if (gfc_match_char ('%') != MATCH_YES)
1775 {
1776 m = MATCH_NO;
1777 goto cleanup;
1778 }
1779
1780 m = gfc_match ("%n (", name);
1781 if (m != MATCH_YES)
1782 goto cleanup;
1783
1784 if (name[0] != '\0')
1785 {
1786 switch (name[0])
1787 {
1788 case 'l':
1789 if (startswith (name, "loc"))
1790 {
1791 result->name = "%LOC";
1792 break;
1793 }
1794 /* FALLTHRU */
1795 case 'r':
1796 if (startswith (name, "ref"))
1797 {
1798 result->name = "%REF";
1799 break;
1800 }
1801 /* FALLTHRU */
1802 case 'v':
1803 if (startswith (name, "val"))
1804 {
1805 result->name = "%VAL";
1806 break;
1807 }
1808 /* FALLTHRU */
1809 default:
1810 m = MATCH_ERROR;
1811 goto cleanup;
1812 }
1813 }
1814
1815 if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
1816 {
1817 m = MATCH_ERROR;
1818 goto cleanup;
1819 }
1820
1821 m = match_actual_arg (&result->expr);
1822 if (m != MATCH_YES)
1823 goto cleanup;
1824
1825 if (gfc_match_char (')') != MATCH_YES)
1826 {
1827 m = MATCH_NO;
1828 goto cleanup;
1829 }
1830
1831 return MATCH_YES;
1832
1833 cleanup:
1834 gfc_current_locus = old_locus;
1835 return m;
1836 }
1837
1838
1839 /* Matches an actual argument list of a function or subroutine, from
1840 the opening parenthesis to the closing parenthesis. The argument
1841 list is assumed to allow keyword arguments because we don't know if
1842 the symbol associated with the procedure has an implicit interface
1843 or not. We make sure keywords are unique. If sub_flag is set,
1844 we're matching the argument list of a subroutine.
1845
1846 NOTE: An alternative use for this function is to match type parameter
1847 spec lists, which are so similar to actual argument lists that the
1848 machinery can be reused. This use is flagged by the optional argument
1849 'pdt'. */
1850
1851 match
gfc_match_actual_arglist(int sub_flag,gfc_actual_arglist ** argp,bool pdt)1852 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
1853 {
1854 gfc_actual_arglist *head, *tail;
1855 int seen_keyword;
1856 gfc_st_label *label;
1857 locus old_loc;
1858 match m;
1859
1860 *argp = tail = NULL;
1861 old_loc = gfc_current_locus;
1862
1863 seen_keyword = 0;
1864
1865 if (gfc_match_char ('(') == MATCH_NO)
1866 return (sub_flag) ? MATCH_YES : MATCH_NO;
1867
1868 if (gfc_match_char (')') == MATCH_YES)
1869 return MATCH_YES;
1870
1871 head = NULL;
1872
1873 matching_actual_arglist++;
1874
1875 for (;;)
1876 {
1877 if (head == NULL)
1878 head = tail = gfc_get_actual_arglist ();
1879 else
1880 {
1881 tail->next = gfc_get_actual_arglist ();
1882 tail = tail->next;
1883 }
1884
1885 if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES)
1886 {
1887 m = gfc_match_st_label (&label);
1888 if (m == MATCH_NO)
1889 gfc_error ("Expected alternate return label at %C");
1890 if (m != MATCH_YES)
1891 goto cleanup;
1892
1893 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
1894 "at %C"))
1895 goto cleanup;
1896
1897 tail->label = label;
1898 goto next;
1899 }
1900
1901 if (pdt && !seen_keyword)
1902 {
1903 if (gfc_match_char (':') == MATCH_YES)
1904 {
1905 tail->spec_type = SPEC_DEFERRED;
1906 goto next;
1907 }
1908 else if (gfc_match_char ('*') == MATCH_YES)
1909 {
1910 tail->spec_type = SPEC_ASSUMED;
1911 goto next;
1912 }
1913 else
1914 tail->spec_type = SPEC_EXPLICIT;
1915
1916 m = match_keyword_arg (tail, head, pdt);
1917 if (m == MATCH_YES)
1918 {
1919 seen_keyword = 1;
1920 goto next;
1921 }
1922 if (m == MATCH_ERROR)
1923 goto cleanup;
1924 }
1925
1926 /* After the first keyword argument is seen, the following
1927 arguments must also have keywords. */
1928 if (seen_keyword)
1929 {
1930 m = match_keyword_arg (tail, head, pdt);
1931
1932 if (m == MATCH_ERROR)
1933 goto cleanup;
1934 if (m == MATCH_NO)
1935 {
1936 gfc_error ("Missing keyword name in actual argument list at %C");
1937 goto cleanup;
1938 }
1939
1940 }
1941 else
1942 {
1943 /* Try an argument list function, like %VAL. */
1944 m = match_arg_list_function (tail);
1945 if (m == MATCH_ERROR)
1946 goto cleanup;
1947
1948 /* See if we have the first keyword argument. */
1949 if (m == MATCH_NO)
1950 {
1951 m = match_keyword_arg (tail, head, false);
1952 if (m == MATCH_YES)
1953 seen_keyword = 1;
1954 if (m == MATCH_ERROR)
1955 goto cleanup;
1956 }
1957
1958 if (m == MATCH_NO)
1959 {
1960 /* Try for a non-keyword argument. */
1961 m = match_actual_arg (&tail->expr);
1962 if (m == MATCH_ERROR)
1963 goto cleanup;
1964 if (m == MATCH_NO)
1965 goto syntax;
1966 }
1967 }
1968
1969
1970 next:
1971 if (gfc_match_char (')') == MATCH_YES)
1972 break;
1973 if (gfc_match_char (',') != MATCH_YES)
1974 goto syntax;
1975 }
1976
1977 *argp = head;
1978 matching_actual_arglist--;
1979 return MATCH_YES;
1980
1981 syntax:
1982 gfc_error ("Syntax error in argument list at %C");
1983
1984 cleanup:
1985 gfc_free_actual_arglist (head);
1986 gfc_current_locus = old_loc;
1987 matching_actual_arglist--;
1988 return MATCH_ERROR;
1989 }
1990
1991
1992 /* Used by gfc_match_varspec() to extend the reference list by one
1993 element. */
1994
1995 static gfc_ref *
extend_ref(gfc_expr * primary,gfc_ref * tail)1996 extend_ref (gfc_expr *primary, gfc_ref *tail)
1997 {
1998 if (primary->ref == NULL)
1999 primary->ref = tail = gfc_get_ref ();
2000 else
2001 {
2002 if (tail == NULL)
2003 gfc_internal_error ("extend_ref(): Bad tail");
2004 tail->next = gfc_get_ref ();
2005 tail = tail->next;
2006 }
2007
2008 return tail;
2009 }
2010
2011
2012 /* Used by gfc_match_varspec() to match an inquiry reference. */
2013
2014 static bool
is_inquiry_ref(const char * name,gfc_ref ** ref)2015 is_inquiry_ref (const char *name, gfc_ref **ref)
2016 {
2017 inquiry_type type;
2018
2019 if (name == NULL)
2020 return false;
2021
2022 if (ref) *ref = NULL;
2023
2024 if (strcmp (name, "re") == 0)
2025 type = INQUIRY_RE;
2026 else if (strcmp (name, "im") == 0)
2027 type = INQUIRY_IM;
2028 else if (strcmp (name, "kind") == 0)
2029 type = INQUIRY_KIND;
2030 else if (strcmp (name, "len") == 0)
2031 type = INQUIRY_LEN;
2032 else
2033 return false;
2034
2035 if (ref)
2036 {
2037 *ref = gfc_get_ref ();
2038 (*ref)->type = REF_INQUIRY;
2039 (*ref)->u.i = type;
2040 }
2041
2042 return true;
2043 }
2044
2045
2046 /* Match any additional specifications associated with the current
2047 variable like member references or substrings. If equiv_flag is
2048 set we only match stuff that is allowed inside an EQUIVALENCE
2049 statement. sub_flag tells whether we expect a type-bound procedure found
2050 to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
2051 components, 'ppc_arg' determines whether the PPC may be called (with an
2052 argument list), or whether it may just be referred to as a pointer. */
2053
2054 match
gfc_match_varspec(gfc_expr * primary,int equiv_flag,bool sub_flag,bool ppc_arg)2055 gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
2056 bool ppc_arg)
2057 {
2058 char name[GFC_MAX_SYMBOL_LEN + 1];
2059 gfc_ref *substring, *tail, *tmp;
2060 gfc_component *component = NULL;
2061 gfc_component *previous = NULL;
2062 gfc_symbol *sym = primary->symtree->n.sym;
2063 gfc_expr *tgt_expr = NULL;
2064 match m;
2065 bool unknown;
2066 bool inquiry;
2067 bool intrinsic;
2068 locus old_loc;
2069 char sep;
2070
2071 tail = NULL;
2072
2073 gfc_gobble_whitespace ();
2074
2075 if (gfc_peek_ascii_char () == '[')
2076 {
2077 if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
2078 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
2079 && CLASS_DATA (sym)->attr.dimension))
2080 {
2081 gfc_error ("Array section designator, e.g. '(:)', is required "
2082 "besides the coarray designator '[...]' at %C");
2083 return MATCH_ERROR;
2084 }
2085 if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
2086 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
2087 && !CLASS_DATA (sym)->attr.codimension))
2088 {
2089 gfc_error ("Coarray designator at %C but %qs is not a coarray",
2090 sym->name);
2091 return MATCH_ERROR;
2092 }
2093 }
2094
2095 if (sym->assoc && sym->assoc->target)
2096 tgt_expr = sym->assoc->target;
2097
2098 /* For associate names, we may not yet know whether they are arrays or not.
2099 If the selector expression is unambiguously an array; eg. a full array
2100 or an array section, then the associate name must be an array and we can
2101 fix it now. Otherwise, if parentheses follow and it is not a character
2102 type, we have to assume that it actually is one for now. The final
2103 decision will be made at resolution, of course. */
2104 if (sym->assoc
2105 && gfc_peek_ascii_char () == '('
2106 && sym->ts.type != BT_CLASS
2107 && !sym->attr.dimension)
2108 {
2109 gfc_ref *ref = NULL;
2110
2111 if (!sym->assoc->dangling && tgt_expr)
2112 {
2113 if (tgt_expr->expr_type == EXPR_VARIABLE)
2114 gfc_resolve_expr (tgt_expr);
2115
2116 ref = tgt_expr->ref;
2117 for (; ref; ref = ref->next)
2118 if (ref->type == REF_ARRAY
2119 && (ref->u.ar.type == AR_FULL
2120 || ref->u.ar.type == AR_SECTION))
2121 break;
2122 }
2123
2124 if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
2125 && sym->assoc->st
2126 && sym->assoc->st->n.sym
2127 && sym->assoc->st->n.sym->attr.dimension == 0))
2128 {
2129 sym->attr.dimension = 1;
2130 if (sym->as == NULL
2131 && sym->assoc->st
2132 && sym->assoc->st->n.sym
2133 && sym->assoc->st->n.sym->as)
2134 sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
2135 }
2136 }
2137 else if (sym->ts.type == BT_CLASS
2138 && tgt_expr
2139 && tgt_expr->expr_type == EXPR_VARIABLE
2140 && sym->ts.u.derived != tgt_expr->ts.u.derived)
2141 {
2142 gfc_resolve_expr (tgt_expr);
2143 if (tgt_expr->rank)
2144 sym->ts.u.derived = tgt_expr->ts.u.derived;
2145 }
2146
2147 if ((equiv_flag && gfc_peek_ascii_char () == '(')
2148 || gfc_peek_ascii_char () == '[' || sym->attr.codimension
2149 || (sym->attr.dimension && sym->ts.type != BT_CLASS
2150 && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
2151 && !(gfc_matching_procptr_assignment
2152 && sym->attr.flavor == FL_PROCEDURE))
2153 || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2154 && (CLASS_DATA (sym)->attr.dimension
2155 || CLASS_DATA (sym)->attr.codimension)))
2156 {
2157 gfc_array_spec *as;
2158
2159 tail = extend_ref (primary, tail);
2160 tail->type = REF_ARRAY;
2161
2162 /* In EQUIVALENCE, we don't know yet whether we are seeing
2163 an array, character variable or array of character
2164 variables. We'll leave the decision till resolve time. */
2165
2166 if (equiv_flag)
2167 as = NULL;
2168 else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
2169 as = CLASS_DATA (sym)->as;
2170 else
2171 as = sym->as;
2172
2173 m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
2174 as ? as->corank : 0);
2175 if (m != MATCH_YES)
2176 return m;
2177
2178 gfc_gobble_whitespace ();
2179 if (equiv_flag && gfc_peek_ascii_char () == '(')
2180 {
2181 tail = extend_ref (primary, tail);
2182 tail->type = REF_ARRAY;
2183
2184 m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
2185 if (m != MATCH_YES)
2186 return m;
2187 }
2188 }
2189
2190 primary->ts = sym->ts;
2191
2192 if (equiv_flag)
2193 return MATCH_YES;
2194
2195 /* With DEC extensions, member separator may be '.' or '%'. */
2196 sep = gfc_peek_ascii_char ();
2197 m = gfc_match_member_sep (sym);
2198 if (m == MATCH_ERROR)
2199 return MATCH_ERROR;
2200
2201 inquiry = false;
2202 if (m == MATCH_YES && sep == '%'
2203 && primary->ts.type != BT_CLASS
2204 && primary->ts.type != BT_DERIVED)
2205 {
2206 match mm;
2207 old_loc = gfc_current_locus;
2208 mm = gfc_match_name (name);
2209 if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
2210 inquiry = true;
2211 gfc_current_locus = old_loc;
2212 }
2213
2214 if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
2215 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2216 gfc_set_default_type (sym, 0, sym->ns);
2217
2218 /* See if there is a usable typespec in the "no IMPLICIT type" error. */
2219 if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
2220 {
2221 bool permissible;
2222
2223 /* These target expressions can be resolved at any time. */
2224 permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
2225 && (tgt_expr->symtree->n.sym->attr.use_assoc
2226 || tgt_expr->symtree->n.sym->attr.host_assoc
2227 || tgt_expr->symtree->n.sym->attr.if_source
2228 == IFSRC_DECL);
2229 permissible = permissible
2230 || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
2231
2232 if (permissible)
2233 {
2234 gfc_resolve_expr (tgt_expr);
2235 sym->ts = tgt_expr->ts;
2236 }
2237
2238 if (sym->ts.type == BT_UNKNOWN)
2239 {
2240 gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
2241 return MATCH_ERROR;
2242 }
2243 }
2244 else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
2245 && m == MATCH_YES && !inquiry)
2246 {
2247 gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2248 sep, sym->name);
2249 return MATCH_ERROR;
2250 }
2251
2252 if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
2253 || m != MATCH_YES)
2254 goto check_substring;
2255
2256 if (!inquiry)
2257 sym = sym->ts.u.derived;
2258 else
2259 sym = NULL;
2260
2261 for (;;)
2262 {
2263 bool t;
2264 gfc_symtree *tbp;
2265
2266 m = gfc_match_name (name);
2267 if (m == MATCH_NO)
2268 gfc_error ("Expected structure component name at %C");
2269 if (m != MATCH_YES)
2270 return MATCH_ERROR;
2271
2272 intrinsic = false;
2273 if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
2274 {
2275 inquiry = is_inquiry_ref (name, &tmp);
2276 if (inquiry)
2277 sym = NULL;
2278
2279 if (sep == '%')
2280 {
2281 if (tmp)
2282 {
2283 switch (tmp->u.i)
2284 {
2285 case INQUIRY_RE:
2286 case INQUIRY_IM:
2287 if (!gfc_notify_std (GFC_STD_F2008,
2288 "RE or IM part_ref at %C"))
2289 return MATCH_ERROR;
2290 break;
2291
2292 case INQUIRY_KIND:
2293 if (!gfc_notify_std (GFC_STD_F2003,
2294 "KIND part_ref at %C"))
2295 return MATCH_ERROR;
2296 break;
2297
2298 case INQUIRY_LEN:
2299 if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
2300 return MATCH_ERROR;
2301 break;
2302 }
2303
2304 if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
2305 && primary->ts.type != BT_COMPLEX)
2306 {
2307 gfc_error ("The RE or IM part_ref at %C must be "
2308 "applied to a COMPLEX expression");
2309 return MATCH_ERROR;
2310 }
2311 else if (tmp->u.i == INQUIRY_LEN
2312 && primary->ts.type != BT_CHARACTER)
2313 {
2314 gfc_error ("The LEN part_ref at %C must be applied "
2315 "to a CHARACTER expression");
2316 return MATCH_ERROR;
2317 }
2318 }
2319 if (primary->ts.type != BT_UNKNOWN)
2320 intrinsic = true;
2321 }
2322 }
2323 else
2324 inquiry = false;
2325
2326 if (sym && sym->f2k_derived)
2327 tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
2328 else
2329 tbp = NULL;
2330
2331 if (tbp)
2332 {
2333 gfc_symbol* tbp_sym;
2334
2335 if (!t)
2336 return MATCH_ERROR;
2337
2338 gcc_assert (!tail || !tail->next);
2339
2340 if (!(primary->expr_type == EXPR_VARIABLE
2341 || (primary->expr_type == EXPR_STRUCTURE
2342 && primary->symtree && primary->symtree->n.sym
2343 && primary->symtree->n.sym->attr.flavor)))
2344 return MATCH_ERROR;
2345
2346 if (tbp->n.tb->is_generic)
2347 tbp_sym = NULL;
2348 else
2349 tbp_sym = tbp->n.tb->u.specific->n.sym;
2350
2351 primary->expr_type = EXPR_COMPCALL;
2352 primary->value.compcall.tbp = tbp->n.tb;
2353 primary->value.compcall.name = tbp->name;
2354 primary->value.compcall.ignore_pass = 0;
2355 primary->value.compcall.assign = 0;
2356 primary->value.compcall.base_object = NULL;
2357 gcc_assert (primary->symtree->n.sym->attr.referenced);
2358 if (tbp_sym)
2359 primary->ts = tbp_sym->ts;
2360 else
2361 gfc_clear_ts (&primary->ts);
2362
2363 m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
2364 &primary->value.compcall.actual);
2365 if (m == MATCH_ERROR)
2366 return MATCH_ERROR;
2367 if (m == MATCH_NO)
2368 {
2369 if (sub_flag)
2370 primary->value.compcall.actual = NULL;
2371 else
2372 {
2373 gfc_error ("Expected argument list at %C");
2374 return MATCH_ERROR;
2375 }
2376 }
2377
2378 break;
2379 }
2380
2381 previous = component;
2382
2383 if (!inquiry && !intrinsic)
2384 component = gfc_find_component (sym, name, false, false, &tmp);
2385 else
2386 component = NULL;
2387
2388 if (intrinsic && !inquiry)
2389 {
2390 if (previous)
2391 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2392 "type component %qs", name, previous->name);
2393 else
2394 gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2395 "type component", name);
2396 return MATCH_ERROR;
2397 }
2398 else if (component == NULL && !inquiry)
2399 return MATCH_ERROR;
2400
2401 /* Extend the reference chain determined by gfc_find_component or
2402 is_inquiry_ref. */
2403 if (primary->ref == NULL)
2404 primary->ref = tmp;
2405 else
2406 {
2407 /* Set by the for loop below for the last component ref. */
2408 gcc_assert (tail != NULL);
2409 tail->next = tmp;
2410 }
2411
2412 /* The reference chain may be longer than one hop for union
2413 subcomponents; find the new tail. */
2414 for (tail = tmp; tail->next; tail = tail->next)
2415 ;
2416
2417 if (tmp && tmp->type == REF_INQUIRY)
2418 {
2419 if (!primary->where.lb || !primary->where.nextc)
2420 primary->where = gfc_current_locus;
2421 gfc_simplify_expr (primary, 0);
2422
2423 if (primary->expr_type == EXPR_CONSTANT)
2424 goto check_done;
2425
2426 switch (tmp->u.i)
2427 {
2428 case INQUIRY_RE:
2429 case INQUIRY_IM:
2430 if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
2431 return MATCH_ERROR;
2432
2433 if (primary->ts.type != BT_COMPLEX)
2434 {
2435 gfc_error ("The RE or IM part_ref at %C must be "
2436 "applied to a COMPLEX expression");
2437 return MATCH_ERROR;
2438 }
2439 primary->ts.type = BT_REAL;
2440 break;
2441
2442 case INQUIRY_LEN:
2443 if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
2444 return MATCH_ERROR;
2445
2446 if (primary->ts.type != BT_CHARACTER)
2447 {
2448 gfc_error ("The LEN part_ref at %C must be applied "
2449 "to a CHARACTER expression");
2450 return MATCH_ERROR;
2451 }
2452 primary->ts.u.cl = NULL;
2453 primary->ts.type = BT_INTEGER;
2454 primary->ts.kind = gfc_default_integer_kind;
2455 break;
2456
2457 case INQUIRY_KIND:
2458 if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
2459 return MATCH_ERROR;
2460
2461 if (primary->ts.type == BT_CLASS
2462 || primary->ts.type == BT_DERIVED)
2463 {
2464 gfc_error ("The KIND part_ref at %C must be applied "
2465 "to an expression of intrinsic type");
2466 return MATCH_ERROR;
2467 }
2468 primary->ts.type = BT_INTEGER;
2469 primary->ts.kind = gfc_default_integer_kind;
2470 break;
2471
2472 default:
2473 gcc_unreachable ();
2474 }
2475
2476 goto check_done;
2477 }
2478
2479 primary->ts = component->ts;
2480
2481 if (component->attr.proc_pointer && ppc_arg)
2482 {
2483 /* Procedure pointer component call: Look for argument list. */
2484 m = gfc_match_actual_arglist (sub_flag,
2485 &primary->value.compcall.actual);
2486 if (m == MATCH_ERROR)
2487 return MATCH_ERROR;
2488
2489 if (m == MATCH_NO && !gfc_matching_ptr_assignment
2490 && !gfc_matching_procptr_assignment && !matching_actual_arglist)
2491 {
2492 gfc_error ("Procedure pointer component %qs requires an "
2493 "argument list at %C", component->name);
2494 return MATCH_ERROR;
2495 }
2496
2497 if (m == MATCH_YES)
2498 primary->expr_type = EXPR_PPC;
2499
2500 break;
2501 }
2502
2503 if (component->as != NULL && !component->attr.proc_pointer)
2504 {
2505 tail = extend_ref (primary, tail);
2506 tail->type = REF_ARRAY;
2507
2508 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
2509 component->as->corank);
2510 if (m != MATCH_YES)
2511 return m;
2512 }
2513 else if (component->ts.type == BT_CLASS && component->attr.class_ok
2514 && CLASS_DATA (component)->as && !component->attr.proc_pointer)
2515 {
2516 tail = extend_ref (primary, tail);
2517 tail->type = REF_ARRAY;
2518
2519 m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
2520 equiv_flag,
2521 CLASS_DATA (component)->as->corank);
2522 if (m != MATCH_YES)
2523 return m;
2524 }
2525
2526 check_done:
2527 /* In principle, we could have eg. expr%re%kind so we must allow for
2528 this possibility. */
2529 if (gfc_match_char ('%') == MATCH_YES)
2530 {
2531 if (component && (component->ts.type == BT_DERIVED
2532 || component->ts.type == BT_CLASS))
2533 sym = component->ts.u.derived;
2534 continue;
2535 }
2536 else if (inquiry)
2537 break;
2538
2539 if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
2540 || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
2541 break;
2542
2543 if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
2544 sym = component->ts.u.derived;
2545 }
2546
2547 check_substring:
2548 unknown = false;
2549 if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
2550 {
2551 if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
2552 {
2553 gfc_set_default_type (sym, 0, sym->ns);
2554 primary->ts = sym->ts;
2555 unknown = true;
2556 }
2557 }
2558
2559 if (primary->ts.type == BT_CHARACTER)
2560 {
2561 bool def = primary->ts.deferred == 1;
2562 switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
2563 {
2564 case MATCH_YES:
2565 if (tail == NULL)
2566 primary->ref = substring;
2567 else
2568 tail->next = substring;
2569
2570 if (primary->expr_type == EXPR_CONSTANT)
2571 primary->expr_type = EXPR_SUBSTRING;
2572
2573 if (substring)
2574 primary->ts.u.cl = NULL;
2575
2576 break;
2577
2578 case MATCH_NO:
2579 if (unknown)
2580 {
2581 gfc_clear_ts (&primary->ts);
2582 gfc_clear_ts (&sym->ts);
2583 }
2584 break;
2585
2586 case MATCH_ERROR:
2587 return MATCH_ERROR;
2588 }
2589 }
2590
2591 /* F08:C611. */
2592 if (primary->ts.type == BT_DERIVED && primary->ref
2593 && primary->ts.u.derived && primary->ts.u.derived->attr.abstract)
2594 {
2595 gfc_error ("Nonpolymorphic reference to abstract type at %C");
2596 return MATCH_ERROR;
2597 }
2598
2599 /* F08:C727. */
2600 if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
2601 {
2602 gfc_error ("Coindexed procedure-pointer component at %C");
2603 return MATCH_ERROR;
2604 }
2605
2606 return MATCH_YES;
2607 }
2608
2609
2610 /* Given an expression that is a variable, figure out what the
2611 ultimate variable's type and attribute is, traversing the reference
2612 structures if necessary.
2613
2614 This subroutine is trickier than it looks. We start at the base
2615 symbol and store the attribute. Component references load a
2616 completely new attribute.
2617
2618 A couple of rules come into play. Subobjects of targets are always
2619 targets themselves. If we see a component that goes through a
2620 pointer, then the expression must also be a target, since the
2621 pointer is associated with something (if it isn't core will soon be
2622 dumped). If we see a full part or section of an array, the
2623 expression is also an array.
2624
2625 We can have at most one full array reference. */
2626
2627 symbol_attribute
gfc_variable_attr(gfc_expr * expr,gfc_typespec * ts)2628 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2629 {
2630 int dimension, codimension, pointer, allocatable, target, optional;
2631 symbol_attribute attr;
2632 gfc_ref *ref;
2633 gfc_symbol *sym;
2634 gfc_component *comp;
2635 bool has_inquiry_part;
2636
2637 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2638 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2639
2640 sym = expr->symtree->n.sym;
2641 attr = sym->attr;
2642
2643 optional = attr.optional;
2644 if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
2645 {
2646 dimension = CLASS_DATA (sym)->attr.dimension;
2647 codimension = CLASS_DATA (sym)->attr.codimension;
2648 pointer = CLASS_DATA (sym)->attr.class_pointer;
2649 allocatable = CLASS_DATA (sym)->attr.allocatable;
2650 optional |= CLASS_DATA (sym)->attr.optional;
2651 }
2652 else
2653 {
2654 dimension = attr.dimension;
2655 codimension = attr.codimension;
2656 pointer = attr.pointer;
2657 allocatable = attr.allocatable;
2658 }
2659
2660 target = attr.target;
2661 if (pointer || attr.proc_pointer)
2662 target = 1;
2663
2664 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2665 *ts = sym->ts;
2666
2667 has_inquiry_part = false;
2668 for (ref = expr->ref; ref; ref = ref->next)
2669 if (ref->type == REF_INQUIRY)
2670 {
2671 has_inquiry_part = true;
2672 optional = false;
2673 break;
2674 }
2675
2676 for (ref = expr->ref; ref; ref = ref->next)
2677 switch (ref->type)
2678 {
2679 case REF_ARRAY:
2680
2681 switch (ref->u.ar.type)
2682 {
2683 case AR_FULL:
2684 dimension = 1;
2685 break;
2686
2687 case AR_SECTION:
2688 allocatable = pointer = 0;
2689 dimension = 1;
2690 optional = false;
2691 break;
2692
2693 case AR_ELEMENT:
2694 /* Handle coarrays. */
2695 if (ref->u.ar.dimen > 0)
2696 allocatable = pointer = optional = false;
2697 break;
2698
2699 case AR_UNKNOWN:
2700 /* For standard conforming code, AR_UNKNOWN should not happen.
2701 For nonconforming code, gfortran can end up here. Treat it
2702 as a no-op. */
2703 break;
2704 }
2705
2706 break;
2707
2708 case REF_COMPONENT:
2709 optional = false;
2710 comp = ref->u.c.component;
2711 attr = comp->attr;
2712 if (ts != NULL && !has_inquiry_part)
2713 {
2714 *ts = comp->ts;
2715 /* Don't set the string length if a substring reference
2716 follows. */
2717 if (ts->type == BT_CHARACTER
2718 && ref->next && ref->next->type == REF_SUBSTRING)
2719 ts->u.cl = NULL;
2720 }
2721
2722 if (comp->ts.type == BT_CLASS)
2723 {
2724 codimension = CLASS_DATA (comp)->attr.codimension;
2725 pointer = CLASS_DATA (comp)->attr.class_pointer;
2726 allocatable = CLASS_DATA (comp)->attr.allocatable;
2727 }
2728 else
2729 {
2730 codimension = comp->attr.codimension;
2731 if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0)
2732 pointer = comp->attr.class_pointer;
2733 else
2734 pointer = comp->attr.pointer;
2735 allocatable = comp->attr.allocatable;
2736 }
2737 if (pointer || attr.proc_pointer)
2738 target = 1;
2739
2740 break;
2741
2742 case REF_INQUIRY:
2743 case REF_SUBSTRING:
2744 allocatable = pointer = optional = false;
2745 break;
2746 }
2747
2748 attr.dimension = dimension;
2749 attr.codimension = codimension;
2750 attr.pointer = pointer;
2751 attr.allocatable = allocatable;
2752 attr.target = target;
2753 attr.save = sym->attr.save;
2754 attr.optional = optional;
2755
2756 return attr;
2757 }
2758
2759
2760 /* Return the attribute from a general expression. */
2761
2762 symbol_attribute
gfc_expr_attr(gfc_expr * e)2763 gfc_expr_attr (gfc_expr *e)
2764 {
2765 symbol_attribute attr;
2766
2767 switch (e->expr_type)
2768 {
2769 case EXPR_VARIABLE:
2770 attr = gfc_variable_attr (e, NULL);
2771 break;
2772
2773 case EXPR_FUNCTION:
2774 gfc_clear_attr (&attr);
2775
2776 if (e->value.function.esym && e->value.function.esym->result)
2777 {
2778 gfc_symbol *sym = e->value.function.esym->result;
2779 attr = sym->attr;
2780 if (sym->ts.type == BT_CLASS)
2781 {
2782 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2783 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2784 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2785 }
2786 }
2787 else if (e->value.function.isym
2788 && e->value.function.isym->transformational
2789 && e->ts.type == BT_CLASS)
2790 attr = CLASS_DATA (e)->attr;
2791 else if (e->symtree)
2792 attr = gfc_variable_attr (e, NULL);
2793
2794 /* TODO: NULL() returns pointers. May have to take care of this
2795 here. */
2796
2797 break;
2798
2799 default:
2800 gfc_clear_attr (&attr);
2801 break;
2802 }
2803
2804 return attr;
2805 }
2806
2807
2808 /* Given an expression, figure out what the ultimate expression
2809 attribute is. This routine is similar to gfc_variable_attr with
2810 parts of gfc_expr_attr, but focuses more on the needs of
2811 coarrays. For coarrays a codimension attribute is kind of
2812 "infectious" being propagated once set and never cleared.
2813 The coarray_comp is only set, when the expression refs a coarray
2814 component. REFS_COMP is set when present to true only, when this EXPR
2815 refs a (non-_data) component. To check whether EXPR refs an allocatable
2816 component in a derived type coarray *refs_comp needs to be set and
2817 coarray_comp has to false. */
2818
2819 static symbol_attribute
caf_variable_attr(gfc_expr * expr,bool in_allocate,bool * refs_comp)2820 caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
2821 {
2822 int dimension, codimension, pointer, allocatable, target, coarray_comp;
2823 symbol_attribute attr;
2824 gfc_ref *ref;
2825 gfc_symbol *sym;
2826 gfc_component *comp;
2827
2828 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2829 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2830
2831 sym = expr->symtree->n.sym;
2832 gfc_clear_attr (&attr);
2833
2834 if (refs_comp)
2835 *refs_comp = false;
2836
2837 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2838 {
2839 dimension = CLASS_DATA (sym)->attr.dimension;
2840 codimension = CLASS_DATA (sym)->attr.codimension;
2841 pointer = CLASS_DATA (sym)->attr.class_pointer;
2842 allocatable = CLASS_DATA (sym)->attr.allocatable;
2843 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
2844 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
2845 }
2846 else
2847 {
2848 dimension = sym->attr.dimension;
2849 codimension = sym->attr.codimension;
2850 pointer = sym->attr.pointer;
2851 allocatable = sym->attr.allocatable;
2852 attr.alloc_comp = sym->ts.type == BT_DERIVED
2853 ? sym->ts.u.derived->attr.alloc_comp : 0;
2854 attr.pointer_comp = sym->ts.type == BT_DERIVED
2855 ? sym->ts.u.derived->attr.pointer_comp : 0;
2856 }
2857
2858 target = coarray_comp = 0;
2859 if (pointer || attr.proc_pointer)
2860 target = 1;
2861
2862 for (ref = expr->ref; ref; ref = ref->next)
2863 switch (ref->type)
2864 {
2865 case REF_ARRAY:
2866
2867 switch (ref->u.ar.type)
2868 {
2869 case AR_FULL:
2870 case AR_SECTION:
2871 dimension = 1;
2872 break;
2873
2874 case AR_ELEMENT:
2875 /* Handle coarrays. */
2876 if (ref->u.ar.dimen > 0 && !in_allocate)
2877 allocatable = pointer = 0;
2878 break;
2879
2880 case AR_UNKNOWN:
2881 /* If any of start, end or stride is not integer, there will
2882 already have been an error issued. */
2883 int errors;
2884 gfc_get_errors (NULL, &errors);
2885 if (errors == 0)
2886 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2887 }
2888
2889 break;
2890
2891 case REF_COMPONENT:
2892 comp = ref->u.c.component;
2893
2894 if (comp->ts.type == BT_CLASS)
2895 {
2896 /* Set coarray_comp only, when this component introduces the
2897 coarray. */
2898 coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
2899 codimension |= CLASS_DATA (comp)->attr.codimension;
2900 pointer = CLASS_DATA (comp)->attr.class_pointer;
2901 allocatable = CLASS_DATA (comp)->attr.allocatable;
2902 }
2903 else
2904 {
2905 /* Set coarray_comp only, when this component introduces the
2906 coarray. */
2907 coarray_comp = !codimension && comp->attr.codimension;
2908 codimension |= comp->attr.codimension;
2909 pointer = comp->attr.pointer;
2910 allocatable = comp->attr.allocatable;
2911 }
2912
2913 if (refs_comp && strcmp (comp->name, "_data") != 0
2914 && (ref->next == NULL
2915 || (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
2916 *refs_comp = true;
2917
2918 if (pointer || attr.proc_pointer)
2919 target = 1;
2920
2921 break;
2922
2923 case REF_SUBSTRING:
2924 case REF_INQUIRY:
2925 allocatable = pointer = 0;
2926 break;
2927 }
2928
2929 attr.dimension = dimension;
2930 attr.codimension = codimension;
2931 attr.pointer = pointer;
2932 attr.allocatable = allocatable;
2933 attr.target = target;
2934 attr.save = sym->attr.save;
2935 attr.coarray_comp = coarray_comp;
2936
2937 return attr;
2938 }
2939
2940
2941 symbol_attribute
gfc_caf_attr(gfc_expr * e,bool in_allocate,bool * refs_comp)2942 gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
2943 {
2944 symbol_attribute attr;
2945
2946 switch (e->expr_type)
2947 {
2948 case EXPR_VARIABLE:
2949 attr = caf_variable_attr (e, in_allocate, refs_comp);
2950 break;
2951
2952 case EXPR_FUNCTION:
2953 gfc_clear_attr (&attr);
2954
2955 if (e->value.function.esym && e->value.function.esym->result)
2956 {
2957 gfc_symbol *sym = e->value.function.esym->result;
2958 attr = sym->attr;
2959 if (sym->ts.type == BT_CLASS)
2960 {
2961 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2962 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2963 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2964 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
2965 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
2966 ->attr.pointer_comp;
2967 }
2968 }
2969 else if (e->symtree)
2970 attr = caf_variable_attr (e, in_allocate, refs_comp);
2971 else
2972 gfc_clear_attr (&attr);
2973 break;
2974
2975 default:
2976 gfc_clear_attr (&attr);
2977 break;
2978 }
2979
2980 return attr;
2981 }
2982
2983
2984 /* Match a structure constructor. The initial symbol has already been
2985 seen. */
2986
2987 typedef struct gfc_structure_ctor_component
2988 {
2989 char* name;
2990 gfc_expr* val;
2991 locus where;
2992 struct gfc_structure_ctor_component* next;
2993 }
2994 gfc_structure_ctor_component;
2995
2996 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2997
2998 static void
gfc_free_structure_ctor_component(gfc_structure_ctor_component * comp)2999 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
3000 {
3001 free (comp->name);
3002 gfc_free_expr (comp->val);
3003 free (comp);
3004 }
3005
3006
3007 /* Translate the component list into the actual constructor by sorting it in
3008 the order required; this also checks along the way that each and every
3009 component actually has an initializer and handles default initializers
3010 for components without explicit value given. */
3011 static bool
build_actual_constructor(gfc_structure_ctor_component ** comp_head,gfc_constructor_base * ctor_head,gfc_symbol * sym)3012 build_actual_constructor (gfc_structure_ctor_component **comp_head,
3013 gfc_constructor_base *ctor_head, gfc_symbol *sym)
3014 {
3015 gfc_structure_ctor_component *comp_iter;
3016 gfc_component *comp;
3017
3018 for (comp = sym->components; comp; comp = comp->next)
3019 {
3020 gfc_structure_ctor_component **next_ptr;
3021 gfc_expr *value = NULL;
3022
3023 /* Try to find the initializer for the current component by name. */
3024 next_ptr = comp_head;
3025 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
3026 {
3027 if (!strcmp (comp_iter->name, comp->name))
3028 break;
3029 next_ptr = &comp_iter->next;
3030 }
3031
3032 /* If an extension, try building the parent derived type by building
3033 a value expression for the parent derived type and calling self. */
3034 if (!comp_iter && comp == sym->components && sym->attr.extension)
3035 {
3036 value = gfc_get_structure_constructor_expr (comp->ts.type,
3037 comp->ts.kind,
3038 &gfc_current_locus);
3039 value->ts = comp->ts;
3040
3041 if (!build_actual_constructor (comp_head,
3042 &value->value.constructor,
3043 comp->ts.u.derived))
3044 {
3045 gfc_free_expr (value);
3046 return false;
3047 }
3048
3049 gfc_constructor_append_expr (ctor_head, value, NULL);
3050 continue;
3051 }
3052
3053 /* If it was not found, apply NULL expression to set the component as
3054 unallocated. Then try the default initializer if there's any;
3055 otherwise, it's an error unless this is a deferred parameter. */
3056 if (!comp_iter)
3057 {
3058 /* F2018 7.5.10: If an allocatable component has no corresponding
3059 component-data-source, then that component has an allocation
3060 status of unallocated.... */
3061 if (comp->attr.allocatable
3062 || (comp->ts.type == BT_CLASS
3063 && CLASS_DATA (comp)->attr.allocatable))
3064 {
3065 if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
3066 "allocatable component %qs given in the "
3067 "structure constructor at %C", comp->name))
3068 return false;
3069 value = gfc_get_null_expr (&gfc_current_locus);
3070 }
3071 /* ....(Preceeding sentence) If a component with default
3072 initialization has no corresponding component-data-source, then
3073 the default initialization is applied to that component. */
3074 else if (comp->initializer)
3075 {
3076 if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
3077 "with missing optional arguments at %C"))
3078 return false;
3079 value = gfc_copy_expr (comp->initializer);
3080 }
3081 /* Do not trap components such as the string length for deferred
3082 length character components. */
3083 else if (!comp->attr.artificial)
3084 {
3085 gfc_error ("No initializer for component %qs given in the"
3086 " structure constructor at %C", comp->name);
3087 return false;
3088 }
3089 }
3090 else
3091 value = comp_iter->val;
3092
3093 /* Add the value to the constructor chain built. */
3094 gfc_constructor_append_expr (ctor_head, value, NULL);
3095
3096 /* Remove the entry from the component list. We don't want the expression
3097 value to be free'd, so set it to NULL. */
3098 if (comp_iter)
3099 {
3100 *next_ptr = comp_iter->next;
3101 comp_iter->val = NULL;
3102 gfc_free_structure_ctor_component (comp_iter);
3103 }
3104 }
3105 return true;
3106 }
3107
3108
3109 bool
gfc_convert_to_structure_constructor(gfc_expr * e,gfc_symbol * sym,gfc_expr ** cexpr,gfc_actual_arglist ** arglist,bool parent)3110 gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
3111 gfc_actual_arglist **arglist,
3112 bool parent)
3113 {
3114 gfc_actual_arglist *actual;
3115 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
3116 gfc_constructor_base ctor_head = NULL;
3117 gfc_component *comp; /* Is set NULL when named component is first seen */
3118 const char* last_name = NULL;
3119 locus old_locus;
3120 gfc_expr *expr;
3121
3122 expr = parent ? *cexpr : e;
3123 old_locus = gfc_current_locus;
3124 if (parent)
3125 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3126 else
3127 gfc_current_locus = expr->where;
3128
3129 comp_tail = comp_head = NULL;
3130
3131 if (!parent && sym->attr.abstract)
3132 {
3133 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3134 sym->name, &expr->where);
3135 goto cleanup;
3136 }
3137
3138 comp = sym->components;
3139 actual = parent ? *arglist : expr->value.function.actual;
3140 for ( ; actual; )
3141 {
3142 gfc_component *this_comp = NULL;
3143
3144 if (!comp_head)
3145 comp_tail = comp_head = gfc_get_structure_ctor_component ();
3146 else
3147 {
3148 comp_tail->next = gfc_get_structure_ctor_component ();
3149 comp_tail = comp_tail->next;
3150 }
3151 if (actual->name)
3152 {
3153 if (!gfc_notify_std (GFC_STD_F2003, "Structure"
3154 " constructor with named arguments at %C"))
3155 goto cleanup;
3156
3157 comp_tail->name = xstrdup (actual->name);
3158 last_name = comp_tail->name;
3159 comp = NULL;
3160 }
3161 else
3162 {
3163 /* Components without name are not allowed after the first named
3164 component initializer! */
3165 if (!comp || comp->attr.artificial)
3166 {
3167 if (last_name)
3168 gfc_error ("Component initializer without name after component"
3169 " named %s at %L", last_name,
3170 actual->expr ? &actual->expr->where
3171 : &gfc_current_locus);
3172 else
3173 gfc_error ("Too many components in structure constructor at "
3174 "%L", actual->expr ? &actual->expr->where
3175 : &gfc_current_locus);
3176 goto cleanup;
3177 }
3178
3179 comp_tail->name = xstrdup (comp->name);
3180 }
3181
3182 /* Find the current component in the structure definition and check
3183 its access is not private. */
3184 if (comp)
3185 this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
3186 else
3187 {
3188 this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
3189 false, false, NULL);
3190 comp = NULL; /* Reset needed! */
3191 }
3192
3193 /* Here we can check if a component name is given which does not
3194 correspond to any component of the defined structure. */
3195 if (!this_comp)
3196 goto cleanup;
3197
3198 /* For a constant string constructor, make sure the length is
3199 correct; truncate of fill with blanks if needed. */
3200 if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
3201 && this_comp->ts.u.cl && this_comp->ts.u.cl->length
3202 && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
3203 && actual->expr->ts.type == BT_CHARACTER
3204 && actual->expr->expr_type == EXPR_CONSTANT)
3205 {
3206 ptrdiff_t c, e1;
3207 c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
3208 e1 = actual->expr->value.character.length;
3209
3210 if (c != e1)
3211 {
3212 ptrdiff_t i, to;
3213 gfc_char_t *dest;
3214 dest = gfc_get_wide_string (c + 1);
3215
3216 to = e1 < c ? e1 : c;
3217 for (i = 0; i < to; i++)
3218 dest[i] = actual->expr->value.character.string[i];
3219
3220 for (i = e1; i < c; i++)
3221 dest[i] = ' ';
3222
3223 dest[c] = '\0';
3224 free (actual->expr->value.character.string);
3225
3226 actual->expr->value.character.length = c;
3227 actual->expr->value.character.string = dest;
3228
3229 if (warn_line_truncation && c < e1)
3230 gfc_warning_now (OPT_Wcharacter_truncation,
3231 "CHARACTER expression will be truncated "
3232 "in constructor (%ld/%ld) at %L", (long int) c,
3233 (long int) e1, &actual->expr->where);
3234 }
3235 }
3236
3237 comp_tail->val = actual->expr;
3238 if (actual->expr != NULL)
3239 comp_tail->where = actual->expr->where;
3240 actual->expr = NULL;
3241
3242 /* Check if this component is already given a value. */
3243 for (comp_iter = comp_head; comp_iter != comp_tail;
3244 comp_iter = comp_iter->next)
3245 {
3246 gcc_assert (comp_iter);
3247 if (!strcmp (comp_iter->name, comp_tail->name))
3248 {
3249 gfc_error ("Component %qs is initialized twice in the structure"
3250 " constructor at %L", comp_tail->name,
3251 comp_tail->val ? &comp_tail->where
3252 : &gfc_current_locus);
3253 goto cleanup;
3254 }
3255 }
3256
3257 /* F2008, R457/C725, for PURE C1283. */
3258 if (this_comp->attr.pointer && comp_tail->val
3259 && gfc_is_coindexed (comp_tail->val))
3260 {
3261 gfc_error ("Coindexed expression to pointer component %qs in "
3262 "structure constructor at %L", comp_tail->name,
3263 &comp_tail->where);
3264 goto cleanup;
3265 }
3266
3267 /* If not explicitly a parent constructor, gather up the components
3268 and build one. */
3269 if (comp && comp == sym->components
3270 && sym->attr.extension
3271 && comp_tail->val
3272 && (!gfc_bt_struct (comp_tail->val->ts.type)
3273 ||
3274 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
3275 {
3276 bool m;
3277 gfc_actual_arglist *arg_null = NULL;
3278
3279 actual->expr = comp_tail->val;
3280 comp_tail->val = NULL;
3281
3282 m = gfc_convert_to_structure_constructor (NULL,
3283 comp->ts.u.derived, &comp_tail->val,
3284 comp->ts.u.derived->attr.zero_comp
3285 ? &arg_null : &actual, true);
3286 if (!m)
3287 goto cleanup;
3288
3289 if (comp->ts.u.derived->attr.zero_comp)
3290 {
3291 comp = comp->next;
3292 continue;
3293 }
3294 }
3295
3296 if (comp)
3297 comp = comp->next;
3298 if (parent && !comp)
3299 break;
3300
3301 if (actual)
3302 actual = actual->next;
3303 }
3304
3305 if (!build_actual_constructor (&comp_head, &ctor_head, sym))
3306 goto cleanup;
3307
3308 /* No component should be left, as this should have caused an error in the
3309 loop constructing the component-list (name that does not correspond to any
3310 component in the structure definition). */
3311 if (comp_head && sym->attr.extension)
3312 {
3313 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
3314 {
3315 gfc_error ("component %qs at %L has already been set by a "
3316 "parent derived type constructor", comp_iter->name,
3317 &comp_iter->where);
3318 }
3319 goto cleanup;
3320 }
3321 else
3322 gcc_assert (!comp_head);
3323
3324 if (parent)
3325 {
3326 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
3327 expr->ts.u.derived = sym;
3328 expr->value.constructor = ctor_head;
3329 *cexpr = expr;
3330 }
3331 else
3332 {
3333 expr->ts.u.derived = sym;
3334 expr->ts.kind = 0;
3335 expr->ts.type = BT_DERIVED;
3336 expr->value.constructor = ctor_head;
3337 expr->expr_type = EXPR_STRUCTURE;
3338 }
3339
3340 gfc_current_locus = old_locus;
3341 if (parent)
3342 *arglist = actual;
3343 return true;
3344
3345 cleanup:
3346 gfc_current_locus = old_locus;
3347
3348 for (comp_iter = comp_head; comp_iter; )
3349 {
3350 gfc_structure_ctor_component *next = comp_iter->next;
3351 gfc_free_structure_ctor_component (comp_iter);
3352 comp_iter = next;
3353 }
3354 gfc_constructor_free (ctor_head);
3355
3356 return false;
3357 }
3358
3359
3360 match
gfc_match_structure_constructor(gfc_symbol * sym,gfc_expr ** result)3361 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
3362 {
3363 match m;
3364 gfc_expr *e;
3365 gfc_symtree *symtree;
3366
3367 gfc_get_ha_sym_tree (sym->name, &symtree);
3368
3369 e = gfc_get_expr ();
3370 e->symtree = symtree;
3371 e->expr_type = EXPR_FUNCTION;
3372 e->where = gfc_current_locus;
3373
3374 gcc_assert (gfc_fl_struct (sym->attr.flavor)
3375 && symtree->n.sym->attr.flavor == FL_PROCEDURE);
3376 e->value.function.esym = sym;
3377 e->symtree->n.sym->attr.generic = 1;
3378
3379 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3380 if (m != MATCH_YES)
3381 {
3382 gfc_free_expr (e);
3383 return m;
3384 }
3385
3386 if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
3387 {
3388 gfc_free_expr (e);
3389 return MATCH_ERROR;
3390 }
3391
3392 /* If a structure constructor is in a DATA statement, then each entity
3393 in the structure constructor must be a constant. Try to reduce the
3394 expression here. */
3395 if (gfc_in_match_data ())
3396 gfc_reduce_init_expr (e);
3397
3398 *result = e;
3399 return MATCH_YES;
3400 }
3401
3402
3403 /* If the symbol is an implicit do loop index and implicitly typed,
3404 it should not be host associated. Provide a symtree from the
3405 current namespace. */
3406 static match
check_for_implicit_index(gfc_symtree ** st,gfc_symbol ** sym)3407 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
3408 {
3409 if ((*sym)->attr.flavor == FL_VARIABLE
3410 && (*sym)->ns != gfc_current_ns
3411 && (*sym)->attr.implied_index
3412 && (*sym)->attr.implicit_type
3413 && !(*sym)->attr.use_assoc)
3414 {
3415 int i;
3416 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
3417 if (i)
3418 return MATCH_ERROR;
3419 *sym = (*st)->n.sym;
3420 }
3421 return MATCH_YES;
3422 }
3423
3424
3425 /* Procedure pointer as function result: Replace the function symbol by the
3426 auto-generated hidden result variable named "ppr@". */
3427
3428 static bool
replace_hidden_procptr_result(gfc_symbol ** sym,gfc_symtree ** st)3429 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
3430 {
3431 /* Check for procedure pointer result variable. */
3432 if ((*sym)->attr.function && !(*sym)->attr.external
3433 && (*sym)->result && (*sym)->result != *sym
3434 && (*sym)->result->attr.proc_pointer
3435 && (*sym) == gfc_current_ns->proc_name
3436 && (*sym) == (*sym)->result->ns->proc_name
3437 && strcmp ("ppr@", (*sym)->result->name) == 0)
3438 {
3439 /* Automatic replacement with "hidden" result variable. */
3440 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
3441 *sym = (*sym)->result;
3442 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
3443 return true;
3444 }
3445 return false;
3446 }
3447
3448
3449 /* Matches a variable name followed by anything that might follow it--
3450 array reference, argument list of a function, etc. */
3451
3452 match
gfc_match_rvalue(gfc_expr ** result)3453 gfc_match_rvalue (gfc_expr **result)
3454 {
3455 gfc_actual_arglist *actual_arglist;
3456 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
3457 gfc_state_data *st;
3458 gfc_symbol *sym;
3459 gfc_symtree *symtree;
3460 locus where, old_loc;
3461 gfc_expr *e;
3462 match m, m2;
3463 int i;
3464 gfc_typespec *ts;
3465 bool implicit_char;
3466 gfc_ref *ref;
3467
3468 m = gfc_match ("%%loc");
3469 if (m == MATCH_YES)
3470 {
3471 if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
3472 return MATCH_ERROR;
3473 strncpy (name, "loc", 4);
3474 }
3475
3476 else
3477 {
3478 m = gfc_match_name (name);
3479 if (m != MATCH_YES)
3480 return m;
3481 }
3482
3483 /* Check if the symbol exists. */
3484 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
3485 return MATCH_ERROR;
3486
3487 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3488 type. For derived types we create a generic symbol which links to the
3489 derived type symbol; STRUCTUREs are simpler and must not conflict with
3490 variables. */
3491 if (!symtree)
3492 if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
3493 return MATCH_ERROR;
3494 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
3495 {
3496 if (gfc_find_state (COMP_INTERFACE)
3497 && !gfc_current_ns->has_import_set)
3498 i = gfc_get_sym_tree (name, NULL, &symtree, false);
3499 else
3500 i = gfc_get_ha_sym_tree (name, &symtree);
3501 if (i)
3502 return MATCH_ERROR;
3503 }
3504
3505
3506 sym = symtree->n.sym;
3507 e = NULL;
3508 where = gfc_current_locus;
3509
3510 replace_hidden_procptr_result (&sym, &symtree);
3511
3512 /* If this is an implicit do loop index and implicitly typed,
3513 it should not be host associated. */
3514 m = check_for_implicit_index (&symtree, &sym);
3515 if (m != MATCH_YES)
3516 return m;
3517
3518 gfc_set_sym_referenced (sym);
3519 sym->attr.implied_index = 0;
3520
3521 if (sym->attr.function && sym->result == sym)
3522 {
3523 /* See if this is a directly recursive function call. */
3524 gfc_gobble_whitespace ();
3525 if (sym->attr.recursive
3526 && gfc_peek_ascii_char () == '('
3527 && gfc_current_ns->proc_name == sym
3528 && !sym->attr.dimension)
3529 {
3530 gfc_error ("%qs at %C is the name of a recursive function "
3531 "and so refers to the result variable. Use an "
3532 "explicit RESULT variable for direct recursion "
3533 "(12.5.2.1)", sym->name);
3534 return MATCH_ERROR;
3535 }
3536
3537 if (gfc_is_function_return_value (sym, gfc_current_ns))
3538 goto variable;
3539
3540 if (sym->attr.entry
3541 && (sym->ns == gfc_current_ns
3542 || sym->ns == gfc_current_ns->parent))
3543 {
3544 gfc_entry_list *el = NULL;
3545
3546 for (el = sym->ns->entries; el; el = el->next)
3547 if (sym == el->sym)
3548 goto variable;
3549 }
3550 }
3551
3552 if (gfc_matching_procptr_assignment)
3553 {
3554 /* It can be a procedure or a derived-type procedure or a not-yet-known
3555 type. */
3556 if (sym->attr.flavor != FL_UNKNOWN
3557 && sym->attr.flavor != FL_PROCEDURE
3558 && sym->attr.flavor != FL_PARAMETER
3559 && sym->attr.flavor != FL_VARIABLE)
3560 {
3561 gfc_error ("Symbol at %C is not appropriate for an expression");
3562 return MATCH_ERROR;
3563 }
3564 goto procptr0;
3565 }
3566
3567 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
3568 goto function0;
3569
3570 if (sym->attr.generic)
3571 goto generic_function;
3572
3573 switch (sym->attr.flavor)
3574 {
3575 case FL_VARIABLE:
3576 variable:
3577 e = gfc_get_expr ();
3578
3579 e->expr_type = EXPR_VARIABLE;
3580 e->symtree = symtree;
3581
3582 m = gfc_match_varspec (e, 0, false, true);
3583 break;
3584
3585 case FL_PARAMETER:
3586 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3587 end up here. Unfortunately, sym->value->expr_type is set to
3588 EXPR_CONSTANT, and so the if () branch would be followed without
3589 the !sym->as check. */
3590 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
3591 e = gfc_copy_expr (sym->value);
3592 else
3593 {
3594 e = gfc_get_expr ();
3595 e->expr_type = EXPR_VARIABLE;
3596 }
3597
3598 e->symtree = symtree;
3599 m = gfc_match_varspec (e, 0, false, true);
3600
3601 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
3602 break;
3603
3604 /* Variable array references to derived type parameters cause
3605 all sorts of headaches in simplification. Treating such
3606 expressions as variable works just fine for all array
3607 references. */
3608 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
3609 {
3610 for (ref = e->ref; ref; ref = ref->next)
3611 if (ref->type == REF_ARRAY)
3612 break;
3613
3614 if (ref == NULL || ref->u.ar.type == AR_FULL)
3615 break;
3616
3617 ref = e->ref;
3618 e->ref = NULL;
3619 gfc_free_expr (e);
3620 e = gfc_get_expr ();
3621 e->expr_type = EXPR_VARIABLE;
3622 e->symtree = symtree;
3623 e->ref = ref;
3624 }
3625
3626 break;
3627
3628 case FL_STRUCT:
3629 case FL_DERIVED:
3630 sym = gfc_use_derived (sym);
3631 if (sym == NULL)
3632 m = MATCH_ERROR;
3633 else
3634 goto generic_function;
3635 break;
3636
3637 /* If we're here, then the name is known to be the name of a
3638 procedure, yet it is not sure to be the name of a function. */
3639 case FL_PROCEDURE:
3640
3641 /* Procedure Pointer Assignments. */
3642 procptr0:
3643 if (gfc_matching_procptr_assignment)
3644 {
3645 gfc_gobble_whitespace ();
3646 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
3647 /* Parse functions returning a procptr. */
3648 goto function0;
3649
3650 e = gfc_get_expr ();
3651 e->expr_type = EXPR_VARIABLE;
3652 e->symtree = symtree;
3653 m = gfc_match_varspec (e, 0, false, true);
3654 if (!e->ref && sym->attr.flavor == FL_UNKNOWN
3655 && sym->ts.type == BT_UNKNOWN
3656 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
3657 {
3658 m = MATCH_ERROR;
3659 break;
3660 }
3661 break;
3662 }
3663
3664 if (sym->attr.subroutine)
3665 {
3666 gfc_error ("Unexpected use of subroutine name %qs at %C",
3667 sym->name);
3668 m = MATCH_ERROR;
3669 break;
3670 }
3671
3672 /* At this point, the name has to be a non-statement function.
3673 If the name is the same as the current function being
3674 compiled, then we have a variable reference (to the function
3675 result) if the name is non-recursive. */
3676
3677 st = gfc_enclosing_unit (NULL);
3678
3679 if (st != NULL
3680 && st->state == COMP_FUNCTION
3681 && st->sym == sym
3682 && !sym->attr.recursive)
3683 {
3684 e = gfc_get_expr ();
3685 e->symtree = symtree;
3686 e->expr_type = EXPR_VARIABLE;
3687
3688 m = gfc_match_varspec (e, 0, false, true);
3689 break;
3690 }
3691
3692 /* Match a function reference. */
3693 function0:
3694 m = gfc_match_actual_arglist (0, &actual_arglist);
3695 if (m == MATCH_NO)
3696 {
3697 if (sym->attr.proc == PROC_ST_FUNCTION)
3698 gfc_error ("Statement function %qs requires argument list at %C",
3699 sym->name);
3700 else
3701 gfc_error ("Function %qs requires an argument list at %C",
3702 sym->name);
3703
3704 m = MATCH_ERROR;
3705 break;
3706 }
3707
3708 if (m != MATCH_YES)
3709 {
3710 m = MATCH_ERROR;
3711 break;
3712 }
3713
3714 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
3715 sym = symtree->n.sym;
3716
3717 replace_hidden_procptr_result (&sym, &symtree);
3718
3719 e = gfc_get_expr ();
3720 e->symtree = symtree;
3721 e->expr_type = EXPR_FUNCTION;
3722 e->value.function.actual = actual_arglist;
3723 e->where = gfc_current_locus;
3724
3725 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3726 && CLASS_DATA (sym)->as)
3727 e->rank = CLASS_DATA (sym)->as->rank;
3728 else if (sym->as != NULL)
3729 e->rank = sym->as->rank;
3730
3731 if (!sym->attr.function
3732 && !gfc_add_function (&sym->attr, sym->name, NULL))
3733 {
3734 m = MATCH_ERROR;
3735 break;
3736 }
3737
3738 /* Check here for the existence of at least one argument for the
3739 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3740 argument(s) given will be checked in gfc_iso_c_func_interface,
3741 during resolution of the function call. */
3742 if (sym->attr.is_iso_c == 1
3743 && (sym->from_intmod == INTMOD_ISO_C_BINDING
3744 && (sym->intmod_sym_id == ISOCBINDING_LOC
3745 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
3746 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
3747 {
3748 /* make sure we were given a param */
3749 if (actual_arglist == NULL)
3750 {
3751 gfc_error ("Missing argument to %qs at %C", sym->name);
3752 m = MATCH_ERROR;
3753 break;
3754 }
3755 }
3756
3757 if (sym->result == NULL)
3758 sym->result = sym;
3759
3760 gfc_gobble_whitespace ();
3761 /* F08:C612. */
3762 if (gfc_peek_ascii_char() == '%')
3763 {
3764 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3765 "function reference at %C");
3766 m = MATCH_ERROR;
3767 break;
3768 }
3769
3770 m = MATCH_YES;
3771 break;
3772
3773 case FL_UNKNOWN:
3774
3775 /* Special case for derived type variables that get their types
3776 via an IMPLICIT statement. This can't wait for the
3777 resolution phase. */
3778
3779 old_loc = gfc_current_locus;
3780 if (gfc_match_member_sep (sym) == MATCH_YES
3781 && sym->ts.type == BT_UNKNOWN
3782 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
3783 gfc_set_default_type (sym, 0, sym->ns);
3784 gfc_current_locus = old_loc;
3785
3786 /* If the symbol has a (co)dimension attribute, the expression is a
3787 variable. */
3788
3789 if (sym->attr.dimension || sym->attr.codimension)
3790 {
3791 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3792 {
3793 m = MATCH_ERROR;
3794 break;
3795 }
3796
3797 e = gfc_get_expr ();
3798 e->symtree = symtree;
3799 e->expr_type = EXPR_VARIABLE;
3800 m = gfc_match_varspec (e, 0, false, true);
3801 break;
3802 }
3803
3804 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3805 && (CLASS_DATA (sym)->attr.dimension
3806 || CLASS_DATA (sym)->attr.codimension))
3807 {
3808 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3809 {
3810 m = MATCH_ERROR;
3811 break;
3812 }
3813
3814 e = gfc_get_expr ();
3815 e->symtree = symtree;
3816 e->expr_type = EXPR_VARIABLE;
3817 m = gfc_match_varspec (e, 0, false, true);
3818 break;
3819 }
3820
3821 /* Name is not an array, so we peek to see if a '(' implies a
3822 function call or a substring reference. Otherwise the
3823 variable is just a scalar. */
3824
3825 gfc_gobble_whitespace ();
3826 if (gfc_peek_ascii_char () != '(')
3827 {
3828 /* Assume a scalar variable */
3829 e = gfc_get_expr ();
3830 e->symtree = symtree;
3831 e->expr_type = EXPR_VARIABLE;
3832
3833 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3834 {
3835 m = MATCH_ERROR;
3836 break;
3837 }
3838
3839 /*FIXME:??? gfc_match_varspec does set this for us: */
3840 e->ts = sym->ts;
3841 m = gfc_match_varspec (e, 0, false, true);
3842 break;
3843 }
3844
3845 /* See if this is a function reference with a keyword argument
3846 as first argument. We do this because otherwise a spurious
3847 symbol would end up in the symbol table. */
3848
3849 old_loc = gfc_current_locus;
3850 m2 = gfc_match (" ( %n =", argname);
3851 gfc_current_locus = old_loc;
3852
3853 e = gfc_get_expr ();
3854 e->symtree = symtree;
3855
3856 if (m2 != MATCH_YES)
3857 {
3858 /* Try to figure out whether we're dealing with a character type.
3859 We're peeking ahead here, because we don't want to call
3860 match_substring if we're dealing with an implicitly typed
3861 non-character variable. */
3862 implicit_char = false;
3863 if (sym->ts.type == BT_UNKNOWN)
3864 {
3865 ts = gfc_get_default_type (sym->name, NULL);
3866 if (ts->type == BT_CHARACTER)
3867 implicit_char = true;
3868 }
3869
3870 /* See if this could possibly be a substring reference of a name
3871 that we're not sure is a variable yet. */
3872
3873 if ((implicit_char || sym->ts.type == BT_CHARACTER)
3874 && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
3875 {
3876
3877 e->expr_type = EXPR_VARIABLE;
3878
3879 if (sym->attr.flavor != FL_VARIABLE
3880 && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
3881 sym->name, NULL))
3882 {
3883 m = MATCH_ERROR;
3884 break;
3885 }
3886
3887 if (sym->ts.type == BT_UNKNOWN
3888 && !gfc_set_default_type (sym, 1, NULL))
3889 {
3890 m = MATCH_ERROR;
3891 break;
3892 }
3893
3894 e->ts = sym->ts;
3895 if (e->ref)
3896 e->ts.u.cl = NULL;
3897 m = MATCH_YES;
3898 break;
3899 }
3900 }
3901
3902 /* Give up, assume we have a function. */
3903
3904 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3905 sym = symtree->n.sym;
3906 e->expr_type = EXPR_FUNCTION;
3907
3908 if (!sym->attr.function
3909 && !gfc_add_function (&sym->attr, sym->name, NULL))
3910 {
3911 m = MATCH_ERROR;
3912 break;
3913 }
3914
3915 sym->result = sym;
3916
3917 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3918 if (m == MATCH_NO)
3919 gfc_error ("Missing argument list in function %qs at %C", sym->name);
3920
3921 if (m != MATCH_YES)
3922 {
3923 m = MATCH_ERROR;
3924 break;
3925 }
3926
3927 /* If our new function returns a character, array or structure
3928 type, it might have subsequent references. */
3929
3930 m = gfc_match_varspec (e, 0, false, true);
3931 if (m == MATCH_NO)
3932 m = MATCH_YES;
3933
3934 break;
3935
3936 generic_function:
3937 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3938 specially. Creates a generic symbol for derived types. */
3939 gfc_find_sym_tree (name, NULL, 1, &symtree);
3940 if (!symtree)
3941 gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
3942 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
3943 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3944
3945 e = gfc_get_expr ();
3946 e->symtree = symtree;
3947 e->expr_type = EXPR_FUNCTION;
3948
3949 if (gfc_fl_struct (sym->attr.flavor))
3950 {
3951 e->value.function.esym = sym;
3952 e->symtree->n.sym->attr.generic = 1;
3953 }
3954
3955 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3956 break;
3957
3958 case FL_NAMELIST:
3959 m = MATCH_ERROR;
3960 break;
3961
3962 default:
3963 gfc_error ("Symbol at %C is not appropriate for an expression");
3964 return MATCH_ERROR;
3965 }
3966
3967 if (m == MATCH_YES)
3968 {
3969 e->where = where;
3970 *result = e;
3971 }
3972 else
3973 gfc_free_expr (e);
3974
3975 return m;
3976 }
3977
3978
3979 /* Match a variable, i.e. something that can be assigned to. This
3980 starts as a symbol, can be a structure component or an array
3981 reference. It can be a function if the function doesn't have a
3982 separate RESULT variable. If the symbol has not been previously
3983 seen, we assume it is a variable.
3984
3985 This function is called by two interface functions:
3986 gfc_match_variable, which has host_flag = 1, and
3987 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3988 match of the symbol to the local scope. */
3989
3990 static match
match_variable(gfc_expr ** result,int equiv_flag,int host_flag)3991 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
3992 {
3993 gfc_symbol *sym, *dt_sym;
3994 gfc_symtree *st;
3995 gfc_expr *expr;
3996 locus where, old_loc;
3997 match m;
3998
3999 /* Since nothing has any business being an lvalue in a module
4000 specification block, an interface block or a contains section,
4001 we force the changed_symbols mechanism to work by setting
4002 host_flag to 0. This prevents valid symbols that have the name
4003 of keywords, such as 'end', being turned into variables by
4004 failed matching to assignments for, e.g., END INTERFACE. */
4005 if (gfc_current_state () == COMP_MODULE
4006 || gfc_current_state () == COMP_SUBMODULE
4007 || gfc_current_state () == COMP_INTERFACE
4008 || gfc_current_state () == COMP_CONTAINS)
4009 host_flag = 0;
4010
4011 where = gfc_current_locus;
4012 m = gfc_match_sym_tree (&st, host_flag);
4013 if (m != MATCH_YES)
4014 return m;
4015
4016 sym = st->n.sym;
4017
4018 /* If this is an implicit do loop index and implicitly typed,
4019 it should not be host associated. */
4020 m = check_for_implicit_index (&st, &sym);
4021 if (m != MATCH_YES)
4022 return m;
4023
4024 sym->attr.implied_index = 0;
4025
4026 gfc_set_sym_referenced (sym);
4027
4028 /* STRUCTUREs may share names with variables, but derived types may not. */
4029 if (sym->attr.flavor == FL_PROCEDURE && sym->generic
4030 && (dt_sym = gfc_find_dt_in_generic (sym)))
4031 {
4032 if (dt_sym->attr.flavor == FL_DERIVED)
4033 gfc_error ("Derived type %qs cannot be used as a variable at %C",
4034 sym->name);
4035 return MATCH_ERROR;
4036 }
4037
4038 switch (sym->attr.flavor)
4039 {
4040 case FL_VARIABLE:
4041 /* Everything is alright. */
4042 break;
4043
4044 case FL_UNKNOWN:
4045 {
4046 sym_flavor flavor = FL_UNKNOWN;
4047
4048 gfc_gobble_whitespace ();
4049
4050 if (sym->attr.external || sym->attr.procedure
4051 || sym->attr.function || sym->attr.subroutine)
4052 flavor = FL_PROCEDURE;
4053
4054 /* If it is not a procedure, is not typed and is host associated,
4055 we cannot give it a flavor yet. */
4056 else if (sym->ns == gfc_current_ns->parent
4057 && sym->ts.type == BT_UNKNOWN)
4058 break;
4059
4060 /* These are definitive indicators that this is a variable. */
4061 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
4062 || sym->attr.pointer || sym->as != NULL)
4063 flavor = FL_VARIABLE;
4064
4065 if (flavor != FL_UNKNOWN
4066 && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
4067 return MATCH_ERROR;
4068 }
4069 break;
4070
4071 case FL_PARAMETER:
4072 if (equiv_flag)
4073 {
4074 gfc_error ("Named constant at %C in an EQUIVALENCE");
4075 return MATCH_ERROR;
4076 }
4077 /* Otherwise this is checked for and an error given in the
4078 variable definition context checks. */
4079 break;
4080
4081 case FL_PROCEDURE:
4082 /* Check for a nonrecursive function result variable. */
4083 if (sym->attr.function
4084 && !sym->attr.external
4085 && sym->result == sym
4086 && (gfc_is_function_return_value (sym, gfc_current_ns)
4087 || (sym->attr.entry
4088 && sym->ns == gfc_current_ns)
4089 || (sym->attr.entry
4090 && sym->ns == gfc_current_ns->parent)))
4091 {
4092 /* If a function result is a derived type, then the derived
4093 type may still have to be resolved. */
4094
4095 if (sym->ts.type == BT_DERIVED
4096 && gfc_use_derived (sym->ts.u.derived) == NULL)
4097 return MATCH_ERROR;
4098 break;
4099 }
4100
4101 if (sym->attr.proc_pointer
4102 || replace_hidden_procptr_result (&sym, &st))
4103 break;
4104
4105 /* Fall through to error */
4106 gcc_fallthrough ();
4107
4108 default:
4109 gfc_error ("%qs at %C is not a variable", sym->name);
4110 return MATCH_ERROR;
4111 }
4112
4113 /* Special case for derived type variables that get their types
4114 via an IMPLICIT statement. This can't wait for the
4115 resolution phase. */
4116
4117 {
4118 gfc_namespace * implicit_ns;
4119
4120 if (gfc_current_ns->proc_name == sym)
4121 implicit_ns = gfc_current_ns;
4122 else
4123 implicit_ns = sym->ns;
4124
4125 old_loc = gfc_current_locus;
4126 if (gfc_match_member_sep (sym) == MATCH_YES
4127 && sym->ts.type == BT_UNKNOWN
4128 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
4129 gfc_set_default_type (sym, 0, implicit_ns);
4130 gfc_current_locus = old_loc;
4131 }
4132
4133 expr = gfc_get_expr ();
4134
4135 expr->expr_type = EXPR_VARIABLE;
4136 expr->symtree = st;
4137 expr->ts = sym->ts;
4138 expr->where = where;
4139
4140 /* Now see if we have to do more. */
4141 m = gfc_match_varspec (expr, equiv_flag, false, false);
4142 if (m != MATCH_YES)
4143 {
4144 gfc_free_expr (expr);
4145 return m;
4146 }
4147
4148 *result = expr;
4149 return MATCH_YES;
4150 }
4151
4152
4153 match
gfc_match_variable(gfc_expr ** result,int equiv_flag)4154 gfc_match_variable (gfc_expr **result, int equiv_flag)
4155 {
4156 return match_variable (result, equiv_flag, 1);
4157 }
4158
4159
4160 match
gfc_match_equiv_variable(gfc_expr ** result)4161 gfc_match_equiv_variable (gfc_expr **result)
4162 {
4163 return match_variable (result, 1, 0);
4164 }
4165
4166