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