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 (gfc_str_startswith (name, "loc"))
1790 {
1791 result->name = "%LOC";
1792 break;
1793 }
1794 /* FALLTHRU */
1795 case 'r':
1796 if (gfc_str_startswith (name, "ref"))
1797 {
1798 result->name = "%REF";
1799 break;
1800 }
1801 /* FALLTHRU */
1802 case 'v':
1803 if (gfc_str_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;
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 if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
2644 {
2645 dimension = CLASS_DATA (sym)->attr.dimension;
2646 codimension = CLASS_DATA (sym)->attr.codimension;
2647 pointer = CLASS_DATA (sym)->attr.class_pointer;
2648 allocatable = CLASS_DATA (sym)->attr.allocatable;
2649 }
2650 else
2651 {
2652 dimension = attr.dimension;
2653 codimension = attr.codimension;
2654 pointer = attr.pointer;
2655 allocatable = attr.allocatable;
2656 }
2657
2658 target = attr.target;
2659 if (pointer || attr.proc_pointer)
2660 target = 1;
2661
2662 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2663 *ts = sym->ts;
2664
2665 has_inquiry_part = false;
2666 for (ref = expr->ref; ref; ref = ref->next)
2667 if (ref->type == REF_INQUIRY)
2668 {
2669 has_inquiry_part = true;
2670 break;
2671 }
2672
2673 for (ref = expr->ref; ref; ref = ref->next)
2674 switch (ref->type)
2675 {
2676 case REF_ARRAY:
2677
2678 switch (ref->u.ar.type)
2679 {
2680 case AR_FULL:
2681 dimension = 1;
2682 break;
2683
2684 case AR_SECTION:
2685 allocatable = pointer = 0;
2686 dimension = 1;
2687 break;
2688
2689 case AR_ELEMENT:
2690 /* Handle coarrays. */
2691 if (ref->u.ar.dimen > 0)
2692 allocatable = pointer = 0;
2693 break;
2694
2695 case AR_UNKNOWN:
2696 /* For standard conforming code, AR_UNKNOWN should not happen.
2697 For nonconforming code, gfortran can end up here. Treat it
2698 as a no-op. */
2699 break;
2700 }
2701
2702 break;
2703
2704 case REF_COMPONENT:
2705 comp = ref->u.c.component;
2706 attr = comp->attr;
2707 if (ts != NULL && !has_inquiry_part)
2708 {
2709 *ts = comp->ts;
2710 /* Don't set the string length if a substring reference
2711 follows. */
2712 if (ts->type == BT_CHARACTER
2713 && ref->next && ref->next->type == REF_SUBSTRING)
2714 ts->u.cl = NULL;
2715 }
2716
2717 if (comp->ts.type == BT_CLASS)
2718 {
2719 codimension = CLASS_DATA (comp)->attr.codimension;
2720 pointer = CLASS_DATA (comp)->attr.class_pointer;
2721 allocatable = CLASS_DATA (comp)->attr.allocatable;
2722 }
2723 else
2724 {
2725 codimension = comp->attr.codimension;
2726 pointer = comp->attr.pointer;
2727 allocatable = comp->attr.allocatable;
2728 }
2729 if (pointer || attr.proc_pointer)
2730 target = 1;
2731
2732 break;
2733
2734 case REF_INQUIRY:
2735 case REF_SUBSTRING:
2736 allocatable = pointer = 0;
2737 break;
2738 }
2739
2740 attr.dimension = dimension;
2741 attr.codimension = codimension;
2742 attr.pointer = pointer;
2743 attr.allocatable = allocatable;
2744 attr.target = target;
2745 attr.save = sym->attr.save;
2746
2747 return attr;
2748 }
2749
2750
2751 /* Return the attribute from a general expression. */
2752
2753 symbol_attribute
gfc_expr_attr(gfc_expr * e)2754 gfc_expr_attr (gfc_expr *e)
2755 {
2756 symbol_attribute attr;
2757
2758 switch (e->expr_type)
2759 {
2760 case EXPR_VARIABLE:
2761 attr = gfc_variable_attr (e, NULL);
2762 break;
2763
2764 case EXPR_FUNCTION:
2765 gfc_clear_attr (&attr);
2766
2767 if (e->value.function.esym && e->value.function.esym->result)
2768 {
2769 gfc_symbol *sym = e->value.function.esym->result;
2770 attr = sym->attr;
2771 if (sym->ts.type == BT_CLASS)
2772 {
2773 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2774 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2775 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2776 }
2777 }
2778 else if (e->value.function.isym
2779 && e->value.function.isym->transformational
2780 && e->ts.type == BT_CLASS)
2781 attr = CLASS_DATA (e)->attr;
2782 else
2783 attr = gfc_variable_attr (e, NULL);
2784
2785 /* TODO: NULL() returns pointers. May have to take care of this
2786 here. */
2787
2788 break;
2789
2790 default:
2791 gfc_clear_attr (&attr);
2792 break;
2793 }
2794
2795 return attr;
2796 }
2797
2798
2799 /* Given an expression, figure out what the ultimate expression
2800 attribute is. This routine is similar to gfc_variable_attr with
2801 parts of gfc_expr_attr, but focuses more on the needs of
2802 coarrays. For coarrays a codimension attribute is kind of
2803 "infectious" being propagated once set and never cleared.
2804 The coarray_comp is only set, when the expression refs a coarray
2805 component. REFS_COMP is set when present to true only, when this EXPR
2806 refs a (non-_data) component. To check whether EXPR refs an allocatable
2807 component in a derived type coarray *refs_comp needs to be set and
2808 coarray_comp has to false. */
2809
2810 static symbol_attribute
caf_variable_attr(gfc_expr * expr,bool in_allocate,bool * refs_comp)2811 caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
2812 {
2813 int dimension, codimension, pointer, allocatable, target, coarray_comp;
2814 symbol_attribute attr;
2815 gfc_ref *ref;
2816 gfc_symbol *sym;
2817 gfc_component *comp;
2818
2819 if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2820 gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2821
2822 sym = expr->symtree->n.sym;
2823 gfc_clear_attr (&attr);
2824
2825 if (refs_comp)
2826 *refs_comp = false;
2827
2828 if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2829 {
2830 dimension = CLASS_DATA (sym)->attr.dimension;
2831 codimension = CLASS_DATA (sym)->attr.codimension;
2832 pointer = CLASS_DATA (sym)->attr.class_pointer;
2833 allocatable = CLASS_DATA (sym)->attr.allocatable;
2834 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
2835 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
2836 }
2837 else
2838 {
2839 dimension = sym->attr.dimension;
2840 codimension = sym->attr.codimension;
2841 pointer = sym->attr.pointer;
2842 allocatable = sym->attr.allocatable;
2843 attr.alloc_comp = sym->ts.type == BT_DERIVED
2844 ? sym->ts.u.derived->attr.alloc_comp : 0;
2845 attr.pointer_comp = sym->ts.type == BT_DERIVED
2846 ? sym->ts.u.derived->attr.pointer_comp : 0;
2847 }
2848
2849 target = coarray_comp = 0;
2850 if (pointer || attr.proc_pointer)
2851 target = 1;
2852
2853 for (ref = expr->ref; ref; ref = ref->next)
2854 switch (ref->type)
2855 {
2856 case REF_ARRAY:
2857
2858 switch (ref->u.ar.type)
2859 {
2860 case AR_FULL:
2861 case AR_SECTION:
2862 dimension = 1;
2863 break;
2864
2865 case AR_ELEMENT:
2866 /* Handle coarrays. */
2867 if (ref->u.ar.dimen > 0 && !in_allocate)
2868 allocatable = pointer = 0;
2869 break;
2870
2871 case AR_UNKNOWN:
2872 /* If any of start, end or stride is not integer, there will
2873 already have been an error issued. */
2874 int errors;
2875 gfc_get_errors (NULL, &errors);
2876 if (errors == 0)
2877 gfc_internal_error ("gfc_caf_attr(): Bad array reference");
2878 }
2879
2880 break;
2881
2882 case REF_COMPONENT:
2883 comp = ref->u.c.component;
2884
2885 if (comp->ts.type == BT_CLASS)
2886 {
2887 /* Set coarray_comp only, when this component introduces the
2888 coarray. */
2889 coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
2890 codimension |= CLASS_DATA (comp)->attr.codimension;
2891 pointer = CLASS_DATA (comp)->attr.class_pointer;
2892 allocatable = CLASS_DATA (comp)->attr.allocatable;
2893 }
2894 else
2895 {
2896 /* Set coarray_comp only, when this component introduces the
2897 coarray. */
2898 coarray_comp = !codimension && comp->attr.codimension;
2899 codimension |= comp->attr.codimension;
2900 pointer = comp->attr.pointer;
2901 allocatable = comp->attr.allocatable;
2902 }
2903
2904 if (refs_comp && strcmp (comp->name, "_data") != 0
2905 && (ref->next == NULL
2906 || (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
2907 *refs_comp = true;
2908
2909 if (pointer || attr.proc_pointer)
2910 target = 1;
2911
2912 break;
2913
2914 case REF_SUBSTRING:
2915 case REF_INQUIRY:
2916 allocatable = pointer = 0;
2917 break;
2918 }
2919
2920 attr.dimension = dimension;
2921 attr.codimension = codimension;
2922 attr.pointer = pointer;
2923 attr.allocatable = allocatable;
2924 attr.target = target;
2925 attr.save = sym->attr.save;
2926 attr.coarray_comp = coarray_comp;
2927
2928 return attr;
2929 }
2930
2931
2932 symbol_attribute
gfc_caf_attr(gfc_expr * e,bool in_allocate,bool * refs_comp)2933 gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
2934 {
2935 symbol_attribute attr;
2936
2937 switch (e->expr_type)
2938 {
2939 case EXPR_VARIABLE:
2940 attr = caf_variable_attr (e, in_allocate, refs_comp);
2941 break;
2942
2943 case EXPR_FUNCTION:
2944 gfc_clear_attr (&attr);
2945
2946 if (e->value.function.esym && e->value.function.esym->result)
2947 {
2948 gfc_symbol *sym = e->value.function.esym->result;
2949 attr = sym->attr;
2950 if (sym->ts.type == BT_CLASS)
2951 {
2952 attr.dimension = CLASS_DATA (sym)->attr.dimension;
2953 attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2954 attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2955 attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
2956 attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
2957 ->attr.pointer_comp;
2958 }
2959 }
2960 else if (e->symtree)
2961 attr = caf_variable_attr (e, in_allocate, refs_comp);
2962 else
2963 gfc_clear_attr (&attr);
2964 break;
2965
2966 default:
2967 gfc_clear_attr (&attr);
2968 break;
2969 }
2970
2971 return attr;
2972 }
2973
2974
2975 /* Match a structure constructor. The initial symbol has already been
2976 seen. */
2977
2978 typedef struct gfc_structure_ctor_component
2979 {
2980 char* name;
2981 gfc_expr* val;
2982 locus where;
2983 struct gfc_structure_ctor_component* next;
2984 }
2985 gfc_structure_ctor_component;
2986
2987 #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2988
2989 static void
gfc_free_structure_ctor_component(gfc_structure_ctor_component * comp)2990 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2991 {
2992 free (comp->name);
2993 gfc_free_expr (comp->val);
2994 free (comp);
2995 }
2996
2997
2998 /* Translate the component list into the actual constructor by sorting it in
2999 the order required; this also checks along the way that each and every
3000 component actually has an initializer and handles default initializers
3001 for components without explicit value given. */
3002 static bool
build_actual_constructor(gfc_structure_ctor_component ** comp_head,gfc_constructor_base * ctor_head,gfc_symbol * sym)3003 build_actual_constructor (gfc_structure_ctor_component **comp_head,
3004 gfc_constructor_base *ctor_head, gfc_symbol *sym)
3005 {
3006 gfc_structure_ctor_component *comp_iter;
3007 gfc_component *comp;
3008
3009 for (comp = sym->components; comp; comp = comp->next)
3010 {
3011 gfc_structure_ctor_component **next_ptr;
3012 gfc_expr *value = NULL;
3013
3014 /* Try to find the initializer for the current component by name. */
3015 next_ptr = comp_head;
3016 for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
3017 {
3018 if (!strcmp (comp_iter->name, comp->name))
3019 break;
3020 next_ptr = &comp_iter->next;
3021 }
3022
3023 /* If an extension, try building the parent derived type by building
3024 a value expression for the parent derived type and calling self. */
3025 if (!comp_iter && comp == sym->components && sym->attr.extension)
3026 {
3027 value = gfc_get_structure_constructor_expr (comp->ts.type,
3028 comp->ts.kind,
3029 &gfc_current_locus);
3030 value->ts = comp->ts;
3031
3032 if (!build_actual_constructor (comp_head,
3033 &value->value.constructor,
3034 comp->ts.u.derived))
3035 {
3036 gfc_free_expr (value);
3037 return false;
3038 }
3039
3040 gfc_constructor_append_expr (ctor_head, value, NULL);
3041 continue;
3042 }
3043
3044 /* If it was not found, apply NULL expression to set the component as
3045 unallocated. Then try the default initializer if there's any;
3046 otherwise, it's an error unless this is a deferred parameter. */
3047 if (!comp_iter)
3048 {
3049 /* F2018 7.5.10: If an allocatable component has no corresponding
3050 component-data-source, then that component has an allocation
3051 status of unallocated.... */
3052 if (comp->attr.allocatable
3053 || (comp->ts.type == BT_CLASS
3054 && CLASS_DATA (comp)->attr.allocatable))
3055 {
3056 if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
3057 "allocatable component %qs given in the "
3058 "structure constructor at %C", comp->name))
3059 return false;
3060 value = gfc_get_null_expr (&gfc_current_locus);
3061 }
3062 /* ....(Preceeding sentence) If a component with default
3063 initialization has no corresponding component-data-source, then
3064 the default initialization is applied to that component. */
3065 else if (comp->initializer)
3066 {
3067 if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
3068 "with missing optional arguments at %C"))
3069 return false;
3070 value = gfc_copy_expr (comp->initializer);
3071 }
3072 /* Do not trap components such as the string length for deferred
3073 length character components. */
3074 else if (!comp->attr.artificial)
3075 {
3076 gfc_error ("No initializer for component %qs given in the"
3077 " structure constructor at %C", comp->name);
3078 return false;
3079 }
3080 }
3081 else
3082 value = comp_iter->val;
3083
3084 /* Add the value to the constructor chain built. */
3085 gfc_constructor_append_expr (ctor_head, value, NULL);
3086
3087 /* Remove the entry from the component list. We don't want the expression
3088 value to be free'd, so set it to NULL. */
3089 if (comp_iter)
3090 {
3091 *next_ptr = comp_iter->next;
3092 comp_iter->val = NULL;
3093 gfc_free_structure_ctor_component (comp_iter);
3094 }
3095 }
3096 return true;
3097 }
3098
3099
3100 bool
gfc_convert_to_structure_constructor(gfc_expr * e,gfc_symbol * sym,gfc_expr ** cexpr,gfc_actual_arglist ** arglist,bool parent)3101 gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
3102 gfc_actual_arglist **arglist,
3103 bool parent)
3104 {
3105 gfc_actual_arglist *actual;
3106 gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
3107 gfc_constructor_base ctor_head = NULL;
3108 gfc_component *comp; /* Is set NULL when named component is first seen */
3109 const char* last_name = NULL;
3110 locus old_locus;
3111 gfc_expr *expr;
3112
3113 expr = parent ? *cexpr : e;
3114 old_locus = gfc_current_locus;
3115 if (parent)
3116 ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3117 else
3118 gfc_current_locus = expr->where;
3119
3120 comp_tail = comp_head = NULL;
3121
3122 if (!parent && sym->attr.abstract)
3123 {
3124 gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3125 sym->name, &expr->where);
3126 goto cleanup;
3127 }
3128
3129 comp = sym->components;
3130 actual = parent ? *arglist : expr->value.function.actual;
3131 for ( ; actual; )
3132 {
3133 gfc_component *this_comp = NULL;
3134
3135 if (!comp_head)
3136 comp_tail = comp_head = gfc_get_structure_ctor_component ();
3137 else
3138 {
3139 comp_tail->next = gfc_get_structure_ctor_component ();
3140 comp_tail = comp_tail->next;
3141 }
3142 if (actual->name)
3143 {
3144 if (!gfc_notify_std (GFC_STD_F2003, "Structure"
3145 " constructor with named arguments at %C"))
3146 goto cleanup;
3147
3148 comp_tail->name = xstrdup (actual->name);
3149 last_name = comp_tail->name;
3150 comp = NULL;
3151 }
3152 else
3153 {
3154 /* Components without name are not allowed after the first named
3155 component initializer! */
3156 if (!comp || comp->attr.artificial)
3157 {
3158 if (last_name)
3159 gfc_error ("Component initializer without name after component"
3160 " named %s at %L", last_name,
3161 actual->expr ? &actual->expr->where
3162 : &gfc_current_locus);
3163 else
3164 gfc_error ("Too many components in structure constructor at "
3165 "%L", actual->expr ? &actual->expr->where
3166 : &gfc_current_locus);
3167 goto cleanup;
3168 }
3169
3170 comp_tail->name = xstrdup (comp->name);
3171 }
3172
3173 /* Find the current component in the structure definition and check
3174 its access is not private. */
3175 if (comp)
3176 this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
3177 else
3178 {
3179 this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
3180 false, false, NULL);
3181 comp = NULL; /* Reset needed! */
3182 }
3183
3184 /* Here we can check if a component name is given which does not
3185 correspond to any component of the defined structure. */
3186 if (!this_comp)
3187 goto cleanup;
3188
3189 /* For a constant string constructor, make sure the length is
3190 correct; truncate of fill with blanks if needed. */
3191 if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
3192 && this_comp->ts.u.cl && this_comp->ts.u.cl->length
3193 && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
3194 && actual->expr->ts.type == BT_CHARACTER
3195 && actual->expr->expr_type == EXPR_CONSTANT)
3196 {
3197 ptrdiff_t c, e1;
3198 c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
3199 e1 = actual->expr->value.character.length;
3200
3201 if (c != e1)
3202 {
3203 ptrdiff_t i, to;
3204 gfc_char_t *dest;
3205 dest = gfc_get_wide_string (c + 1);
3206
3207 to = e1 < c ? e1 : c;
3208 for (i = 0; i < to; i++)
3209 dest[i] = actual->expr->value.character.string[i];
3210
3211 for (i = e1; i < c; i++)
3212 dest[i] = ' ';
3213
3214 dest[c] = '\0';
3215 free (actual->expr->value.character.string);
3216
3217 actual->expr->value.character.length = c;
3218 actual->expr->value.character.string = dest;
3219
3220 if (warn_line_truncation && c < e1)
3221 gfc_warning_now (OPT_Wcharacter_truncation,
3222 "CHARACTER expression will be truncated "
3223 "in constructor (%ld/%ld) at %L", (long int) c,
3224 (long int) e1, &actual->expr->where);
3225 }
3226 }
3227
3228 comp_tail->val = actual->expr;
3229 if (actual->expr != NULL)
3230 comp_tail->where = actual->expr->where;
3231 actual->expr = NULL;
3232
3233 /* Check if this component is already given a value. */
3234 for (comp_iter = comp_head; comp_iter != comp_tail;
3235 comp_iter = comp_iter->next)
3236 {
3237 gcc_assert (comp_iter);
3238 if (!strcmp (comp_iter->name, comp_tail->name))
3239 {
3240 gfc_error ("Component %qs is initialized twice in the structure"
3241 " constructor at %L", comp_tail->name,
3242 comp_tail->val ? &comp_tail->where
3243 : &gfc_current_locus);
3244 goto cleanup;
3245 }
3246 }
3247
3248 /* F2008, R457/C725, for PURE C1283. */
3249 if (this_comp->attr.pointer && comp_tail->val
3250 && gfc_is_coindexed (comp_tail->val))
3251 {
3252 gfc_error ("Coindexed expression to pointer component %qs in "
3253 "structure constructor at %L", comp_tail->name,
3254 &comp_tail->where);
3255 goto cleanup;
3256 }
3257
3258 /* If not explicitly a parent constructor, gather up the components
3259 and build one. */
3260 if (comp && comp == sym->components
3261 && sym->attr.extension
3262 && comp_tail->val
3263 && (!gfc_bt_struct (comp_tail->val->ts.type)
3264 ||
3265 comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
3266 {
3267 bool m;
3268 gfc_actual_arglist *arg_null = NULL;
3269
3270 actual->expr = comp_tail->val;
3271 comp_tail->val = NULL;
3272
3273 m = gfc_convert_to_structure_constructor (NULL,
3274 comp->ts.u.derived, &comp_tail->val,
3275 comp->ts.u.derived->attr.zero_comp
3276 ? &arg_null : &actual, true);
3277 if (!m)
3278 goto cleanup;
3279
3280 if (comp->ts.u.derived->attr.zero_comp)
3281 {
3282 comp = comp->next;
3283 continue;
3284 }
3285 }
3286
3287 if (comp)
3288 comp = comp->next;
3289 if (parent && !comp)
3290 break;
3291
3292 if (actual)
3293 actual = actual->next;
3294 }
3295
3296 if (!build_actual_constructor (&comp_head, &ctor_head, sym))
3297 goto cleanup;
3298
3299 /* No component should be left, as this should have caused an error in the
3300 loop constructing the component-list (name that does not correspond to any
3301 component in the structure definition). */
3302 if (comp_head && sym->attr.extension)
3303 {
3304 for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
3305 {
3306 gfc_error ("component %qs at %L has already been set by a "
3307 "parent derived type constructor", comp_iter->name,
3308 &comp_iter->where);
3309 }
3310 goto cleanup;
3311 }
3312 else
3313 gcc_assert (!comp_head);
3314
3315 if (parent)
3316 {
3317 expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
3318 expr->ts.u.derived = sym;
3319 expr->value.constructor = ctor_head;
3320 *cexpr = expr;
3321 }
3322 else
3323 {
3324 expr->ts.u.derived = sym;
3325 expr->ts.kind = 0;
3326 expr->ts.type = BT_DERIVED;
3327 expr->value.constructor = ctor_head;
3328 expr->expr_type = EXPR_STRUCTURE;
3329 }
3330
3331 gfc_current_locus = old_locus;
3332 if (parent)
3333 *arglist = actual;
3334 return true;
3335
3336 cleanup:
3337 gfc_current_locus = old_locus;
3338
3339 for (comp_iter = comp_head; comp_iter; )
3340 {
3341 gfc_structure_ctor_component *next = comp_iter->next;
3342 gfc_free_structure_ctor_component (comp_iter);
3343 comp_iter = next;
3344 }
3345 gfc_constructor_free (ctor_head);
3346
3347 return false;
3348 }
3349
3350
3351 match
gfc_match_structure_constructor(gfc_symbol * sym,gfc_expr ** result)3352 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
3353 {
3354 match m;
3355 gfc_expr *e;
3356 gfc_symtree *symtree;
3357
3358 gfc_get_ha_sym_tree (sym->name, &symtree);
3359
3360 e = gfc_get_expr ();
3361 e->symtree = symtree;
3362 e->expr_type = EXPR_FUNCTION;
3363 e->where = gfc_current_locus;
3364
3365 gcc_assert (gfc_fl_struct (sym->attr.flavor)
3366 && symtree->n.sym->attr.flavor == FL_PROCEDURE);
3367 e->value.function.esym = sym;
3368 e->symtree->n.sym->attr.generic = 1;
3369
3370 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3371 if (m != MATCH_YES)
3372 {
3373 gfc_free_expr (e);
3374 return m;
3375 }
3376
3377 if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
3378 {
3379 gfc_free_expr (e);
3380 return MATCH_ERROR;
3381 }
3382
3383 /* If a structure constructor is in a DATA statement, then each entity
3384 in the structure constructor must be a constant. Try to reduce the
3385 expression here. */
3386 if (gfc_in_match_data ())
3387 gfc_reduce_init_expr (e);
3388
3389 *result = e;
3390 return MATCH_YES;
3391 }
3392
3393
3394 /* If the symbol is an implicit do loop index and implicitly typed,
3395 it should not be host associated. Provide a symtree from the
3396 current namespace. */
3397 static match
check_for_implicit_index(gfc_symtree ** st,gfc_symbol ** sym)3398 check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
3399 {
3400 if ((*sym)->attr.flavor == FL_VARIABLE
3401 && (*sym)->ns != gfc_current_ns
3402 && (*sym)->attr.implied_index
3403 && (*sym)->attr.implicit_type
3404 && !(*sym)->attr.use_assoc)
3405 {
3406 int i;
3407 i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
3408 if (i)
3409 return MATCH_ERROR;
3410 *sym = (*st)->n.sym;
3411 }
3412 return MATCH_YES;
3413 }
3414
3415
3416 /* Procedure pointer as function result: Replace the function symbol by the
3417 auto-generated hidden result variable named "ppr@". */
3418
3419 static bool
replace_hidden_procptr_result(gfc_symbol ** sym,gfc_symtree ** st)3420 replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
3421 {
3422 /* Check for procedure pointer result variable. */
3423 if ((*sym)->attr.function && !(*sym)->attr.external
3424 && (*sym)->result && (*sym)->result != *sym
3425 && (*sym)->result->attr.proc_pointer
3426 && (*sym) == gfc_current_ns->proc_name
3427 && (*sym) == (*sym)->result->ns->proc_name
3428 && strcmp ("ppr@", (*sym)->result->name) == 0)
3429 {
3430 /* Automatic replacement with "hidden" result variable. */
3431 (*sym)->result->attr.referenced = (*sym)->attr.referenced;
3432 *sym = (*sym)->result;
3433 *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
3434 return true;
3435 }
3436 return false;
3437 }
3438
3439
3440 /* Matches a variable name followed by anything that might follow it--
3441 array reference, argument list of a function, etc. */
3442
3443 match
gfc_match_rvalue(gfc_expr ** result)3444 gfc_match_rvalue (gfc_expr **result)
3445 {
3446 gfc_actual_arglist *actual_arglist;
3447 char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
3448 gfc_state_data *st;
3449 gfc_symbol *sym;
3450 gfc_symtree *symtree;
3451 locus where, old_loc;
3452 gfc_expr *e;
3453 match m, m2;
3454 int i;
3455 gfc_typespec *ts;
3456 bool implicit_char;
3457 gfc_ref *ref;
3458
3459 m = gfc_match ("%%loc");
3460 if (m == MATCH_YES)
3461 {
3462 if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
3463 return MATCH_ERROR;
3464 strncpy (name, "loc", 4);
3465 }
3466
3467 else
3468 {
3469 m = gfc_match_name (name);
3470 if (m != MATCH_YES)
3471 return m;
3472 }
3473
3474 /* Check if the symbol exists. */
3475 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
3476 return MATCH_ERROR;
3477
3478 /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3479 type. For derived types we create a generic symbol which links to the
3480 derived type symbol; STRUCTUREs are simpler and must not conflict with
3481 variables. */
3482 if (!symtree)
3483 if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
3484 return MATCH_ERROR;
3485 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
3486 {
3487 if (gfc_find_state (COMP_INTERFACE)
3488 && !gfc_current_ns->has_import_set)
3489 i = gfc_get_sym_tree (name, NULL, &symtree, false);
3490 else
3491 i = gfc_get_ha_sym_tree (name, &symtree);
3492 if (i)
3493 return MATCH_ERROR;
3494 }
3495
3496
3497 sym = symtree->n.sym;
3498 e = NULL;
3499 where = gfc_current_locus;
3500
3501 replace_hidden_procptr_result (&sym, &symtree);
3502
3503 /* If this is an implicit do loop index and implicitly typed,
3504 it should not be host associated. */
3505 m = check_for_implicit_index (&symtree, &sym);
3506 if (m != MATCH_YES)
3507 return m;
3508
3509 gfc_set_sym_referenced (sym);
3510 sym->attr.implied_index = 0;
3511
3512 if (sym->attr.function && sym->result == sym)
3513 {
3514 /* See if this is a directly recursive function call. */
3515 gfc_gobble_whitespace ();
3516 if (sym->attr.recursive
3517 && gfc_peek_ascii_char () == '('
3518 && gfc_current_ns->proc_name == sym
3519 && !sym->attr.dimension)
3520 {
3521 gfc_error ("%qs at %C is the name of a recursive function "
3522 "and so refers to the result variable. Use an "
3523 "explicit RESULT variable for direct recursion "
3524 "(12.5.2.1)", sym->name);
3525 return MATCH_ERROR;
3526 }
3527
3528 if (gfc_is_function_return_value (sym, gfc_current_ns))
3529 goto variable;
3530
3531 if (sym->attr.entry
3532 && (sym->ns == gfc_current_ns
3533 || sym->ns == gfc_current_ns->parent))
3534 {
3535 gfc_entry_list *el = NULL;
3536
3537 for (el = sym->ns->entries; el; el = el->next)
3538 if (sym == el->sym)
3539 goto variable;
3540 }
3541 }
3542
3543 if (gfc_matching_procptr_assignment)
3544 {
3545 /* It can be a procedure or a derived-type procedure or a not-yet-known
3546 type. */
3547 if (sym->attr.flavor != FL_UNKNOWN
3548 && sym->attr.flavor != FL_PROCEDURE
3549 && sym->attr.flavor != FL_PARAMETER
3550 && sym->attr.flavor != FL_VARIABLE)
3551 {
3552 gfc_error ("Symbol at %C is not appropriate for an expression");
3553 return MATCH_ERROR;
3554 }
3555 goto procptr0;
3556 }
3557
3558 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
3559 goto function0;
3560
3561 if (sym->attr.generic)
3562 goto generic_function;
3563
3564 switch (sym->attr.flavor)
3565 {
3566 case FL_VARIABLE:
3567 variable:
3568 e = gfc_get_expr ();
3569
3570 e->expr_type = EXPR_VARIABLE;
3571 e->symtree = symtree;
3572
3573 m = gfc_match_varspec (e, 0, false, true);
3574 break;
3575
3576 case FL_PARAMETER:
3577 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3578 end up here. Unfortunately, sym->value->expr_type is set to
3579 EXPR_CONSTANT, and so the if () branch would be followed without
3580 the !sym->as check. */
3581 if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
3582 e = gfc_copy_expr (sym->value);
3583 else
3584 {
3585 e = gfc_get_expr ();
3586 e->expr_type = EXPR_VARIABLE;
3587 }
3588
3589 e->symtree = symtree;
3590 m = gfc_match_varspec (e, 0, false, true);
3591
3592 if (sym->ts.is_c_interop || sym->ts.is_iso_c)
3593 break;
3594
3595 /* Variable array references to derived type parameters cause
3596 all sorts of headaches in simplification. Treating such
3597 expressions as variable works just fine for all array
3598 references. */
3599 if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
3600 {
3601 for (ref = e->ref; ref; ref = ref->next)
3602 if (ref->type == REF_ARRAY)
3603 break;
3604
3605 if (ref == NULL || ref->u.ar.type == AR_FULL)
3606 break;
3607
3608 ref = e->ref;
3609 e->ref = NULL;
3610 gfc_free_expr (e);
3611 e = gfc_get_expr ();
3612 e->expr_type = EXPR_VARIABLE;
3613 e->symtree = symtree;
3614 e->ref = ref;
3615 }
3616
3617 break;
3618
3619 case FL_STRUCT:
3620 case FL_DERIVED:
3621 sym = gfc_use_derived (sym);
3622 if (sym == NULL)
3623 m = MATCH_ERROR;
3624 else
3625 goto generic_function;
3626 break;
3627
3628 /* If we're here, then the name is known to be the name of a
3629 procedure, yet it is not sure to be the name of a function. */
3630 case FL_PROCEDURE:
3631
3632 /* Procedure Pointer Assignments. */
3633 procptr0:
3634 if (gfc_matching_procptr_assignment)
3635 {
3636 gfc_gobble_whitespace ();
3637 if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
3638 /* Parse functions returning a procptr. */
3639 goto function0;
3640
3641 e = gfc_get_expr ();
3642 e->expr_type = EXPR_VARIABLE;
3643 e->symtree = symtree;
3644 m = gfc_match_varspec (e, 0, false, true);
3645 if (!e->ref && sym->attr.flavor == FL_UNKNOWN
3646 && sym->ts.type == BT_UNKNOWN
3647 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
3648 {
3649 m = MATCH_ERROR;
3650 break;
3651 }
3652 break;
3653 }
3654
3655 if (sym->attr.subroutine)
3656 {
3657 gfc_error ("Unexpected use of subroutine name %qs at %C",
3658 sym->name);
3659 m = MATCH_ERROR;
3660 break;
3661 }
3662
3663 /* At this point, the name has to be a non-statement function.
3664 If the name is the same as the current function being
3665 compiled, then we have a variable reference (to the function
3666 result) if the name is non-recursive. */
3667
3668 st = gfc_enclosing_unit (NULL);
3669
3670 if (st != NULL
3671 && st->state == COMP_FUNCTION
3672 && st->sym == sym
3673 && !sym->attr.recursive)
3674 {
3675 e = gfc_get_expr ();
3676 e->symtree = symtree;
3677 e->expr_type = EXPR_VARIABLE;
3678
3679 m = gfc_match_varspec (e, 0, false, true);
3680 break;
3681 }
3682
3683 /* Match a function reference. */
3684 function0:
3685 m = gfc_match_actual_arglist (0, &actual_arglist);
3686 if (m == MATCH_NO)
3687 {
3688 if (sym->attr.proc == PROC_ST_FUNCTION)
3689 gfc_error ("Statement function %qs requires argument list at %C",
3690 sym->name);
3691 else
3692 gfc_error ("Function %qs requires an argument list at %C",
3693 sym->name);
3694
3695 m = MATCH_ERROR;
3696 break;
3697 }
3698
3699 if (m != MATCH_YES)
3700 {
3701 m = MATCH_ERROR;
3702 break;
3703 }
3704
3705 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
3706 sym = symtree->n.sym;
3707
3708 replace_hidden_procptr_result (&sym, &symtree);
3709
3710 e = gfc_get_expr ();
3711 e->symtree = symtree;
3712 e->expr_type = EXPR_FUNCTION;
3713 e->value.function.actual = actual_arglist;
3714 e->where = gfc_current_locus;
3715
3716 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3717 && CLASS_DATA (sym)->as)
3718 e->rank = CLASS_DATA (sym)->as->rank;
3719 else if (sym->as != NULL)
3720 e->rank = sym->as->rank;
3721
3722 if (!sym->attr.function
3723 && !gfc_add_function (&sym->attr, sym->name, NULL))
3724 {
3725 m = MATCH_ERROR;
3726 break;
3727 }
3728
3729 /* Check here for the existence of at least one argument for the
3730 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3731 argument(s) given will be checked in gfc_iso_c_func_interface,
3732 during resolution of the function call. */
3733 if (sym->attr.is_iso_c == 1
3734 && (sym->from_intmod == INTMOD_ISO_C_BINDING
3735 && (sym->intmod_sym_id == ISOCBINDING_LOC
3736 || sym->intmod_sym_id == ISOCBINDING_FUNLOC
3737 || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
3738 {
3739 /* make sure we were given a param */
3740 if (actual_arglist == NULL)
3741 {
3742 gfc_error ("Missing argument to %qs at %C", sym->name);
3743 m = MATCH_ERROR;
3744 break;
3745 }
3746 }
3747
3748 if (sym->result == NULL)
3749 sym->result = sym;
3750
3751 gfc_gobble_whitespace ();
3752 /* F08:C612. */
3753 if (gfc_peek_ascii_char() == '%')
3754 {
3755 gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3756 "function reference at %C");
3757 m = MATCH_ERROR;
3758 break;
3759 }
3760
3761 m = MATCH_YES;
3762 break;
3763
3764 case FL_UNKNOWN:
3765
3766 /* Special case for derived type variables that get their types
3767 via an IMPLICIT statement. This can't wait for the
3768 resolution phase. */
3769
3770 old_loc = gfc_current_locus;
3771 if (gfc_match_member_sep (sym) == MATCH_YES
3772 && sym->ts.type == BT_UNKNOWN
3773 && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
3774 gfc_set_default_type (sym, 0, sym->ns);
3775 gfc_current_locus = old_loc;
3776
3777 /* If the symbol has a (co)dimension attribute, the expression is a
3778 variable. */
3779
3780 if (sym->attr.dimension || sym->attr.codimension)
3781 {
3782 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3783 {
3784 m = MATCH_ERROR;
3785 break;
3786 }
3787
3788 e = gfc_get_expr ();
3789 e->symtree = symtree;
3790 e->expr_type = EXPR_VARIABLE;
3791 m = gfc_match_varspec (e, 0, false, true);
3792 break;
3793 }
3794
3795 if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3796 && (CLASS_DATA (sym)->attr.dimension
3797 || CLASS_DATA (sym)->attr.codimension))
3798 {
3799 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3800 {
3801 m = MATCH_ERROR;
3802 break;
3803 }
3804
3805 e = gfc_get_expr ();
3806 e->symtree = symtree;
3807 e->expr_type = EXPR_VARIABLE;
3808 m = gfc_match_varspec (e, 0, false, true);
3809 break;
3810 }
3811
3812 /* Name is not an array, so we peek to see if a '(' implies a
3813 function call or a substring reference. Otherwise the
3814 variable is just a scalar. */
3815
3816 gfc_gobble_whitespace ();
3817 if (gfc_peek_ascii_char () != '(')
3818 {
3819 /* Assume a scalar variable */
3820 e = gfc_get_expr ();
3821 e->symtree = symtree;
3822 e->expr_type = EXPR_VARIABLE;
3823
3824 if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3825 {
3826 m = MATCH_ERROR;
3827 break;
3828 }
3829
3830 /*FIXME:??? gfc_match_varspec does set this for us: */
3831 e->ts = sym->ts;
3832 m = gfc_match_varspec (e, 0, false, true);
3833 break;
3834 }
3835
3836 /* See if this is a function reference with a keyword argument
3837 as first argument. We do this because otherwise a spurious
3838 symbol would end up in the symbol table. */
3839
3840 old_loc = gfc_current_locus;
3841 m2 = gfc_match (" ( %n =", argname);
3842 gfc_current_locus = old_loc;
3843
3844 e = gfc_get_expr ();
3845 e->symtree = symtree;
3846
3847 if (m2 != MATCH_YES)
3848 {
3849 /* Try to figure out whether we're dealing with a character type.
3850 We're peeking ahead here, because we don't want to call
3851 match_substring if we're dealing with an implicitly typed
3852 non-character variable. */
3853 implicit_char = false;
3854 if (sym->ts.type == BT_UNKNOWN)
3855 {
3856 ts = gfc_get_default_type (sym->name, NULL);
3857 if (ts->type == BT_CHARACTER)
3858 implicit_char = true;
3859 }
3860
3861 /* See if this could possibly be a substring reference of a name
3862 that we're not sure is a variable yet. */
3863
3864 if ((implicit_char || sym->ts.type == BT_CHARACTER)
3865 && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
3866 {
3867
3868 e->expr_type = EXPR_VARIABLE;
3869
3870 if (sym->attr.flavor != FL_VARIABLE
3871 && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
3872 sym->name, NULL))
3873 {
3874 m = MATCH_ERROR;
3875 break;
3876 }
3877
3878 if (sym->ts.type == BT_UNKNOWN
3879 && !gfc_set_default_type (sym, 1, NULL))
3880 {
3881 m = MATCH_ERROR;
3882 break;
3883 }
3884
3885 e->ts = sym->ts;
3886 if (e->ref)
3887 e->ts.u.cl = NULL;
3888 m = MATCH_YES;
3889 break;
3890 }
3891 }
3892
3893 /* Give up, assume we have a function. */
3894
3895 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3896 sym = symtree->n.sym;
3897 e->expr_type = EXPR_FUNCTION;
3898
3899 if (!sym->attr.function
3900 && !gfc_add_function (&sym->attr, sym->name, NULL))
3901 {
3902 m = MATCH_ERROR;
3903 break;
3904 }
3905
3906 sym->result = sym;
3907
3908 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3909 if (m == MATCH_NO)
3910 gfc_error ("Missing argument list in function %qs at %C", sym->name);
3911
3912 if (m != MATCH_YES)
3913 {
3914 m = MATCH_ERROR;
3915 break;
3916 }
3917
3918 /* If our new function returns a character, array or structure
3919 type, it might have subsequent references. */
3920
3921 m = gfc_match_varspec (e, 0, false, true);
3922 if (m == MATCH_NO)
3923 m = MATCH_YES;
3924
3925 break;
3926
3927 generic_function:
3928 /* Look for symbol first; if not found, look for STRUCTURE type symbol
3929 specially. Creates a generic symbol for derived types. */
3930 gfc_find_sym_tree (name, NULL, 1, &symtree);
3931 if (!symtree)
3932 gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
3933 if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
3934 gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
3935
3936 e = gfc_get_expr ();
3937 e->symtree = symtree;
3938 e->expr_type = EXPR_FUNCTION;
3939
3940 if (gfc_fl_struct (sym->attr.flavor))
3941 {
3942 e->value.function.esym = sym;
3943 e->symtree->n.sym->attr.generic = 1;
3944 }
3945
3946 m = gfc_match_actual_arglist (0, &e->value.function.actual);
3947 break;
3948
3949 case FL_NAMELIST:
3950 m = MATCH_ERROR;
3951 break;
3952
3953 default:
3954 gfc_error ("Symbol at %C is not appropriate for an expression");
3955 return MATCH_ERROR;
3956 }
3957
3958 if (m == MATCH_YES)
3959 {
3960 e->where = where;
3961 *result = e;
3962 }
3963 else
3964 gfc_free_expr (e);
3965
3966 return m;
3967 }
3968
3969
3970 /* Match a variable, i.e. something that can be assigned to. This
3971 starts as a symbol, can be a structure component or an array
3972 reference. It can be a function if the function doesn't have a
3973 separate RESULT variable. If the symbol has not been previously
3974 seen, we assume it is a variable.
3975
3976 This function is called by two interface functions:
3977 gfc_match_variable, which has host_flag = 1, and
3978 gfc_match_equiv_variable, with host_flag = 0, to restrict the
3979 match of the symbol to the local scope. */
3980
3981 static match
match_variable(gfc_expr ** result,int equiv_flag,int host_flag)3982 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
3983 {
3984 gfc_symbol *sym, *dt_sym;
3985 gfc_symtree *st;
3986 gfc_expr *expr;
3987 locus where, old_loc;
3988 match m;
3989
3990 /* Since nothing has any business being an lvalue in a module
3991 specification block, an interface block or a contains section,
3992 we force the changed_symbols mechanism to work by setting
3993 host_flag to 0. This prevents valid symbols that have the name
3994 of keywords, such as 'end', being turned into variables by
3995 failed matching to assignments for, e.g., END INTERFACE. */
3996 if (gfc_current_state () == COMP_MODULE
3997 || gfc_current_state () == COMP_SUBMODULE
3998 || gfc_current_state () == COMP_INTERFACE
3999 || gfc_current_state () == COMP_CONTAINS)
4000 host_flag = 0;
4001
4002 where = gfc_current_locus;
4003 m = gfc_match_sym_tree (&st, host_flag);
4004 if (m != MATCH_YES)
4005 return m;
4006
4007 sym = st->n.sym;
4008
4009 /* If this is an implicit do loop index and implicitly typed,
4010 it should not be host associated. */
4011 m = check_for_implicit_index (&st, &sym);
4012 if (m != MATCH_YES)
4013 return m;
4014
4015 sym->attr.implied_index = 0;
4016
4017 gfc_set_sym_referenced (sym);
4018
4019 /* STRUCTUREs may share names with variables, but derived types may not. */
4020 if (sym->attr.flavor == FL_PROCEDURE && sym->generic
4021 && (dt_sym = gfc_find_dt_in_generic (sym)))
4022 {
4023 if (dt_sym->attr.flavor == FL_DERIVED)
4024 gfc_error ("Derived type %qs cannot be used as a variable at %C",
4025 sym->name);
4026 return MATCH_ERROR;
4027 }
4028
4029 switch (sym->attr.flavor)
4030 {
4031 case FL_VARIABLE:
4032 /* Everything is alright. */
4033 break;
4034
4035 case FL_UNKNOWN:
4036 {
4037 sym_flavor flavor = FL_UNKNOWN;
4038
4039 gfc_gobble_whitespace ();
4040
4041 if (sym->attr.external || sym->attr.procedure
4042 || sym->attr.function || sym->attr.subroutine)
4043 flavor = FL_PROCEDURE;
4044
4045 /* If it is not a procedure, is not typed and is host associated,
4046 we cannot give it a flavor yet. */
4047 else if (sym->ns == gfc_current_ns->parent
4048 && sym->ts.type == BT_UNKNOWN)
4049 break;
4050
4051 /* These are definitive indicators that this is a variable. */
4052 else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
4053 || sym->attr.pointer || sym->as != NULL)
4054 flavor = FL_VARIABLE;
4055
4056 if (flavor != FL_UNKNOWN
4057 && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
4058 return MATCH_ERROR;
4059 }
4060 break;
4061
4062 case FL_PARAMETER:
4063 if (equiv_flag)
4064 {
4065 gfc_error ("Named constant at %C in an EQUIVALENCE");
4066 return MATCH_ERROR;
4067 }
4068 /* Otherwise this is checked for and an error given in the
4069 variable definition context checks. */
4070 break;
4071
4072 case FL_PROCEDURE:
4073 /* Check for a nonrecursive function result variable. */
4074 if (sym->attr.function
4075 && !sym->attr.external
4076 && sym->result == sym
4077 && (gfc_is_function_return_value (sym, gfc_current_ns)
4078 || (sym->attr.entry
4079 && sym->ns == gfc_current_ns)
4080 || (sym->attr.entry
4081 && sym->ns == gfc_current_ns->parent)))
4082 {
4083 /* If a function result is a derived type, then the derived
4084 type may still have to be resolved. */
4085
4086 if (sym->ts.type == BT_DERIVED
4087 && gfc_use_derived (sym->ts.u.derived) == NULL)
4088 return MATCH_ERROR;
4089 break;
4090 }
4091
4092 if (sym->attr.proc_pointer
4093 || replace_hidden_procptr_result (&sym, &st))
4094 break;
4095
4096 /* Fall through to error */
4097 gcc_fallthrough ();
4098
4099 default:
4100 gfc_error ("%qs at %C is not a variable", sym->name);
4101 return MATCH_ERROR;
4102 }
4103
4104 /* Special case for derived type variables that get their types
4105 via an IMPLICIT statement. This can't wait for the
4106 resolution phase. */
4107
4108 {
4109 gfc_namespace * implicit_ns;
4110
4111 if (gfc_current_ns->proc_name == sym)
4112 implicit_ns = gfc_current_ns;
4113 else
4114 implicit_ns = sym->ns;
4115
4116 old_loc = gfc_current_locus;
4117 if (gfc_match_member_sep (sym) == MATCH_YES
4118 && sym->ts.type == BT_UNKNOWN
4119 && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
4120 gfc_set_default_type (sym, 0, implicit_ns);
4121 gfc_current_locus = old_loc;
4122 }
4123
4124 expr = gfc_get_expr ();
4125
4126 expr->expr_type = EXPR_VARIABLE;
4127 expr->symtree = st;
4128 expr->ts = sym->ts;
4129 expr->where = where;
4130
4131 /* Now see if we have to do more. */
4132 m = gfc_match_varspec (expr, equiv_flag, false, false);
4133 if (m != MATCH_YES)
4134 {
4135 gfc_free_expr (expr);
4136 return m;
4137 }
4138
4139 *result = expr;
4140 return MATCH_YES;
4141 }
4142
4143
4144 match
gfc_match_variable(gfc_expr ** result,int equiv_flag)4145 gfc_match_variable (gfc_expr **result, int equiv_flag)
4146 {
4147 return match_variable (result, equiv_flag, 1);
4148 }
4149
4150
4151 match
gfc_match_equiv_variable(gfc_expr ** result)4152 gfc_match_equiv_variable (gfc_expr **result)
4153 {
4154 return match_variable (result, 1, 0);
4155 }
4156
4157