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