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