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 : 375384 : match_kind_param (int *kind, int *is_iso_c)
41 : : {
42 : 375384 : char name[GFC_MAX_SYMBOL_LEN + 1];
43 : 375384 : gfc_symbol *sym;
44 : 375384 : match m;
45 : :
46 : 375384 : *is_iso_c = 0;
47 : :
48 : 375384 : m = gfc_match_small_literal_int (kind, NULL, false);
49 : 375384 : if (m != MATCH_NO)
50 : : return m;
51 : :
52 : 92452 : m = gfc_match_name (name, false);
53 : 92452 : if (m != MATCH_YES)
54 : : return m;
55 : :
56 : 90720 : if (gfc_find_symbol (name, NULL, 1, &sym))
57 : : return MATCH_ERROR;
58 : :
59 : 90720 : if (sym == NULL)
60 : : return MATCH_NO;
61 : :
62 : 90719 : *is_iso_c = sym->attr.is_iso_c;
63 : :
64 : 90719 : if (sym->attr.flavor != FL_PARAMETER)
65 : : return MATCH_NO;
66 : :
67 : 90719 : if (sym->value == NULL)
68 : : return MATCH_NO;
69 : :
70 : 90718 : if (gfc_extract_int (sym->value, kind))
71 : : return MATCH_NO;
72 : :
73 : 90718 : gfc_set_sym_referenced (sym);
74 : :
75 : 90718 : 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 : 3832552 : get_kind (int *is_iso_c)
92 : : {
93 : 3832552 : int kind;
94 : 3832552 : match m;
95 : :
96 : 3832552 : *is_iso_c = 0;
97 : :
98 : 3832552 : if (gfc_match_char ('_', false) != MATCH_YES)
99 : : return -2;
100 : :
101 : 375384 : m = match_kind_param (&kind, is_iso_c);
102 : 375384 : if (m == MATCH_NO)
103 : 1734 : gfc_error ("Missing kind-parameter at %C");
104 : :
105 : 375384 : 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 : 24341744 : gfc_check_digit (char c, int radix)
114 : : {
115 : 24341744 : bool r;
116 : :
117 : 24341744 : 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 : 24243965 : case 10:
128 : 24243965 : r = ('0' <= c && c <= '9');
129 : 24243965 : 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 : 24341744 : 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 : 14204840 : match_digits (int signflag, int radix, char *buffer)
150 : : {
151 : 14204840 : locus old_loc;
152 : 14204840 : int length;
153 : 14204840 : char c;
154 : :
155 : 14204840 : length = 0;
156 : 14204840 : c = gfc_next_ascii_char ();
157 : :
158 : 14204840 : if (signflag && (c == '+' || c == '-'))
159 : : {
160 : 4743 : if (buffer != NULL)
161 : 1844 : *buffer++ = c;
162 : 4743 : gfc_gobble_whitespace ();
163 : 4743 : c = gfc_next_ascii_char ();
164 : 4743 : length++;
165 : : }
166 : :
167 : 14204840 : if (!gfc_check_digit (c, radix))
168 : : return -1;
169 : :
170 : 7168785 : length++;
171 : 7168785 : if (buffer != NULL)
172 : 3584392 : *buffer++ = c;
173 : :
174 : 13054559 : for (;;)
175 : : {
176 : 10111672 : old_loc = gfc_current_locus;
177 : 10111672 : c = gfc_next_ascii_char ();
178 : :
179 : 10111672 : if (!gfc_check_digit (c, radix))
180 : : break;
181 : :
182 : 2942887 : if (buffer != NULL)
183 : 1471442 : *buffer++ = c;
184 : 2942887 : length++;
185 : : }
186 : :
187 : 7168785 : gfc_current_locus = old_loc;
188 : :
189 : 7168785 : return length;
190 : : }
191 : :
192 : : /* Convert an integer string to an expression node. */
193 : :
194 : : static gfc_expr *
195 : 3578652 : convert_integer (const char *buffer, int kind, int radix, locus *where)
196 : : {
197 : 3578652 : gfc_expr *e;
198 : 3578652 : const char *t;
199 : :
200 : 3578652 : e = gfc_get_constant_expr (BT_INTEGER, kind, where);
201 : : /* A leading plus is allowed, but not by mpz_set_str. */
202 : 3578652 : if (buffer[0] == '+')
203 : 21 : t = buffer + 1;
204 : : else
205 : : t = buffer;
206 : 3578652 : mpz_set_str (e->value.integer, t, radix);
207 : :
208 : 3578652 : return e;
209 : : }
210 : :
211 : :
212 : : /* Convert a real string to an expression node. */
213 : :
214 : : static gfc_expr *
215 : 213290 : convert_real (const char *buffer, int kind, locus *where)
216 : : {
217 : 213290 : gfc_expr *e;
218 : :
219 : 213290 : e = gfc_get_constant_expr (BT_REAL, kind, where);
220 : 213290 : mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
221 : :
222 : 213290 : 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 : 6497 : convert_complex (gfc_expr *real, gfc_expr *imag, int kind)
231 : : {
232 : 6497 : gfc_expr *e;
233 : :
234 : 6497 : e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
235 : 6497 : mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
236 : : GFC_MPC_RND_MODE);
237 : :
238 : 6497 : 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 : 10616441 : match_integer_constant (gfc_expr **result, int signflag)
247 : : {
248 : 10616441 : int length, kind, is_iso_c;
249 : 10616441 : locus old_loc;
250 : 10616441 : char *buffer;
251 : 10616441 : gfc_expr *e;
252 : :
253 : 10616441 : old_loc = gfc_current_locus;
254 : 10616441 : gfc_gobble_whitespace ();
255 : :
256 : 10616441 : length = match_digits (signflag, 10, NULL);
257 : 10616441 : gfc_current_locus = old_loc;
258 : 10616441 : if (length == -1)
259 : : return MATCH_NO;
260 : :
261 : 3580386 : buffer = (char *) alloca (length + 1);
262 : 3580386 : memset (buffer, '\0', length + 1);
263 : :
264 : 3580386 : gfc_gobble_whitespace ();
265 : :
266 : 3580386 : match_digits (signflag, 10, buffer);
267 : :
268 : 3580386 : kind = get_kind (&is_iso_c);
269 : 3580386 : if (kind == -2)
270 : 3275677 : kind = gfc_default_integer_kind;
271 : 3580386 : if (kind == -1)
272 : : return MATCH_ERROR;
273 : :
274 : 3578656 : if (kind == 4 && flag_integer4_kind == 8)
275 : 0 : kind = 8;
276 : :
277 : 3578656 : 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 : 3578652 : e = convert_integer (buffer, kind, 10, &gfc_current_locus);
284 : 3578652 : e->ts.is_c_interop = is_iso_c;
285 : :
286 : 3578652 : 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 : 3578648 : *result = e;
296 : 3578648 : return MATCH_YES;
297 : : }
298 : :
299 : :
300 : : /* Match a Hollerith constant. */
301 : :
302 : : static match
303 : 5272162 : match_hollerith_constant (gfc_expr **result)
304 : : {
305 : 5272162 : locus old_loc;
306 : 5272162 : gfc_expr *e = NULL;
307 : 5272162 : int num, pad;
308 : 5272162 : int i;
309 : :
310 : 5272162 : old_loc = gfc_current_locus;
311 : 5272162 : gfc_gobble_whitespace ();
312 : :
313 : 5272162 : if (match_integer_constant (&e, 0) == MATCH_YES
314 : 5272162 : && 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 : 5269513 : gfc_free_expr (e);
371 : 5269513 : gfc_current_locus = old_loc;
372 : 5269513 : 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 : 5476147 : match_boz_constant (gfc_expr **result)
388 : : {
389 : 5476147 : int radix, length, x_hex;
390 : 5476147 : locus old_loc, start_loc;
391 : 5476147 : char *buffer, post, delim;
392 : 5476147 : gfc_expr *e;
393 : :
394 : 5476147 : start_loc = old_loc = gfc_current_locus;
395 : 5476147 : gfc_gobble_whitespace ();
396 : :
397 : 5476147 : x_hex = 0;
398 : 5476147 : switch (post = gfc_next_ascii_char ())
399 : : {
400 : : case 'b':
401 : : radix = 2;
402 : : post = 0;
403 : : break;
404 : 42890 : case 'o':
405 : 42890 : radix = 8;
406 : 42890 : post = 0;
407 : 42890 : break;
408 : 55591 : case 'x':
409 : 55591 : 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 : 5251613 : default:
423 : 5251613 : goto backup;
424 : : }
425 : :
426 : : /* No whitespace allowed here. */
427 : :
428 : 224534 : if (post == 0)
429 : 224509 : delim = gfc_next_ascii_char ();
430 : :
431 : 224534 : if (delim != '\'' && delim != '\"')
432 : 220525 : 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 : 5472138 : backup:
506 : 5472138 : gfc_current_locus = start_loc;
507 : 5472138 : 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 : 5560232 : match_real_constant (gfc_expr **result, int signflag)
516 : : {
517 : 5560232 : int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent;
518 : 5560232 : locus old_loc, temp_loc;
519 : 5560232 : char *p, *buffer, c, exp_char;
520 : 5560232 : gfc_expr *e;
521 : 5560232 : bool negate;
522 : :
523 : 5560232 : old_loc = gfc_current_locus;
524 : 5560232 : gfc_gobble_whitespace ();
525 : :
526 : 5560232 : e = NULL;
527 : :
528 : 5560232 : default_exponent = 0;
529 : 5560232 : count = 0;
530 : 5560232 : seen_dp = 0;
531 : 5560232 : seen_digits = 0;
532 : 5560232 : exp_char = ' ';
533 : 5560232 : negate = false;
534 : :
535 : 5560232 : c = gfc_next_ascii_char ();
536 : 5560232 : if (signflag && (c == '+' || c == '-'))
537 : : {
538 : 6139 : if (c == '-')
539 : 6003 : negate = true;
540 : :
541 : 6139 : gfc_gobble_whitespace ();
542 : 6139 : c = gfc_next_ascii_char ();
543 : : }
544 : :
545 : : /* Scan significand. */
546 : 3239751 : for (;; c = gfc_next_ascii_char (), count++)
547 : : {
548 : 8799983 : if (c == '.')
549 : : {
550 : 256066 : if (seen_dp)
551 : 204 : goto done;
552 : :
553 : : /* Check to see if "." goes with a following operator like
554 : : ".eq.". */
555 : 255862 : temp_loc = gfc_current_locus;
556 : 255862 : c = gfc_next_ascii_char ();
557 : :
558 : 255862 : if (c == 'e' || c == 'd' || c == 'q')
559 : : {
560 : 18097 : c = gfc_next_ascii_char ();
561 : 18097 : if (c == '.')
562 : 0 : goto done; /* Operator named .e. or .d. */
563 : : }
564 : :
565 : 255862 : if (ISALPHA (c))
566 : 48992 : goto done; /* Distinguish 1.e9 from 1.eq.2 */
567 : :
568 : 206870 : gfc_current_locus = temp_loc;
569 : 206870 : seen_dp = 1;
570 : 206870 : continue;
571 : : }
572 : :
573 : 8543917 : if (ISDIGIT (c))
574 : : {
575 : 3032881 : seen_digits = 1;
576 : 3032881 : continue;
577 : : }
578 : :
579 : 5511036 : break;
580 : : }
581 : :
582 : 5511036 : if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
583 : 5473274 : goto done;
584 : 37762 : exp_char = c;
585 : :
586 : :
587 : 37762 : 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 : 37762 : c = gfc_next_ascii_char ();
600 : 37762 : count++;
601 : :
602 : 37762 : if (c == '+' || c == '-')
603 : : { /* optional sign */
604 : 6899 : c = gfc_next_ascii_char ();
605 : 6899 : count++;
606 : : }
607 : :
608 : 37762 : if (!ISDIGIT (c))
609 : : {
610 : : /* With -fdec, default exponent to 0 instead of complaining. */
611 : 40 : if (flag_dec)
612 : 37752 : 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 : 78292 : while (ISDIGIT (c))
621 : : {
622 : 40540 : c = gfc_next_ascii_char ();
623 : 40540 : count++;
624 : : }
625 : :
626 : 37752 : done:
627 : : /* Check that we have a numeric constant. */
628 : 5560222 : if (!seen_digits || (!seen_dp && exp_char == ' '))
629 : : {
630 : 5346928 : gfc_current_locus = old_loc;
631 : 5346928 : return MATCH_NO;
632 : : }
633 : :
634 : : /* Convert the number. */
635 : 213294 : gfc_current_locus = old_loc;
636 : 213294 : gfc_gobble_whitespace ();
637 : :
638 : 213294 : buffer = (char *) alloca (count + default_exponent + 1);
639 : 213294 : memset (buffer, '\0', count + default_exponent + 1);
640 : :
641 : 213294 : p = buffer;
642 : 213294 : c = gfc_next_ascii_char ();
643 : 213294 : 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 : 1390570 : for (;;)
651 : : {
652 : 801932 : if (c == 'd' || c == 'q')
653 : 30220 : *p = 'e';
654 : : else
655 : 771712 : *p = c;
656 : 801932 : p++;
657 : 801932 : if (--count == 0)
658 : : break;
659 : :
660 : 588638 : c = gfc_next_ascii_char ();
661 : : }
662 : 213294 : if (default_exponent)
663 : 30 : *p++ = '0';
664 : :
665 : 213294 : kind = get_kind (&is_iso_c);
666 : 213294 : if (kind == -1)
667 : 4 : goto cleanup;
668 : :
669 : 213290 : 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 : 193195 : else if (kind == 8)
679 : : {
680 : 26167 : if (flag_real8_kind == 4)
681 : 192 : kind = 4;
682 : 26167 : if (flag_real8_kind == 10)
683 : 192 : kind = 10;
684 : 26167 : if (flag_real8_kind == 16)
685 : 384 : kind = 16;
686 : : }
687 : :
688 : 213290 : 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 : 183070 : default:
725 : 183070 : if (kind == -2)
726 : 112856 : kind = gfc_default_real_kind;
727 : :
728 : 183070 : 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 : 213290 : e = convert_real (buffer, kind, &gfc_current_locus);
736 : 213290 : if (negate)
737 : 3135 : mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
738 : 213290 : e->ts.is_c_interop = is_iso_c;
739 : :
740 : 213290 : 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 : 213289 : 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 : 213289 : *result = e;
812 : 213289 : 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 : 574361 : match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
824 : : {
825 : 574361 : gfc_expr *start, *end;
826 : 574361 : locus old_loc;
827 : 574361 : gfc_ref *ref;
828 : 574361 : match m;
829 : :
830 : 574361 : start = NULL;
831 : 574361 : end = NULL;
832 : :
833 : 574361 : old_loc = gfc_current_locus;
834 : :
835 : 574361 : m = gfc_match_char ('(');
836 : 574361 : if (m != MATCH_YES)
837 : : return MATCH_NO;
838 : :
839 : 14871 : if (gfc_match_char (':') != MATCH_YES)
840 : : {
841 : 13884 : if (init)
842 : 0 : m = gfc_match_init_expr (&start);
843 : : else
844 : 13884 : m = gfc_match_expr (&start);
845 : :
846 : 13884 : if (m != MATCH_YES)
847 : : {
848 : 154 : m = MATCH_NO;
849 : 154 : goto cleanup;
850 : : }
851 : :
852 : 13730 : m = gfc_match_char (':');
853 : 13730 : if (m != MATCH_YES)
854 : 454 : goto cleanup;
855 : : }
856 : :
857 : 14263 : if (gfc_match_char (')') != MATCH_YES)
858 : : {
859 : 13367 : if (init)
860 : 0 : m = gfc_match_init_expr (&end);
861 : : else
862 : 13367 : m = gfc_match_expr (&end);
863 : :
864 : 13367 : if (m == MATCH_NO)
865 : 2 : goto syntax;
866 : 13365 : if (m == MATCH_ERROR)
867 : 0 : goto cleanup;
868 : :
869 : 13365 : m = gfc_match_char (')');
870 : 13365 : if (m == MATCH_NO)
871 : 3 : goto syntax;
872 : : }
873 : :
874 : : /* Optimize away the (:) reference. */
875 : 14258 : if (start == NULL && end == NULL && !deferred)
876 : : ref = NULL;
877 : : else
878 : : {
879 : 14020 : ref = gfc_get_ref ();
880 : :
881 : 14020 : ref->type = REF_SUBSTRING;
882 : 14020 : if (start == NULL)
883 : 747 : start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
884 : 14020 : ref->u.ss.start = start;
885 : 14020 : if (end == NULL && cl)
886 : 656 : end = gfc_copy_expr (cl->length);
887 : 14020 : ref->u.ss.end = end;
888 : 14020 : ref->u.ss.length = cl;
889 : : }
890 : :
891 : 14258 : *result = ref;
892 : 14258 : 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 : 3975497 : next_string_char (gfc_char_t delimiter, int *ret)
919 : : {
920 : 3975497 : locus old_locus;
921 : 3975497 : gfc_char_t c;
922 : :
923 : 3975497 : c = gfc_next_char_literal (INSTRING_WARN);
924 : 3975497 : *ret = 0;
925 : :
926 : 3975497 : if (c == '\n')
927 : : {
928 : 4 : *ret = -2;
929 : 4 : return 0;
930 : : }
931 : :
932 : 3975493 : 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 : 3975493 : if (c != delimiter)
944 : : return c;
945 : :
946 : 580976 : old_locus = gfc_current_locus;
947 : 580976 : c = gfc_next_char_literal (NONSTRING);
948 : :
949 : 580976 : if (c == delimiter)
950 : : return c;
951 : 580158 : gfc_current_locus = old_locus;
952 : :
953 : 580158 : *ret = -1;
954 : 580158 : 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 : 3493564 : match_charkind_name (char *name)
972 : : {
973 : 3493564 : locus old_loc;
974 : 3493564 : char c, peek;
975 : 3493564 : int len;
976 : :
977 : 3493564 : gfc_gobble_whitespace ();
978 : 3493564 : c = gfc_next_ascii_char ();
979 : 3493564 : if (!ISALPHA (c))
980 : : return MATCH_NO;
981 : :
982 : 3169272 : *name++ = c;
983 : 3169272 : len = 1;
984 : :
985 : 13536088 : for (;;)
986 : : {
987 : 13536088 : old_loc = gfc_current_locus;
988 : 13536088 : c = gfc_next_ascii_char ();
989 : :
990 : 13536088 : if (c == '_')
991 : : {
992 : 450553 : peek = gfc_peek_ascii_char ();
993 : :
994 : 450553 : if (peek == '\'' || peek == '\"')
995 : : {
996 : 794 : gfc_current_locus = old_loc;
997 : 794 : *name = '\0';
998 : 794 : return MATCH_YES;
999 : : }
1000 : : }
1001 : :
1002 : 13535294 : if (!ISALNUM (c)
1003 : 3618237 : && c != '_'
1004 : 3168478 : && (c != '$' || !flag_dollar_ok))
1005 : : break;
1006 : :
1007 : 10366816 : *name++ = c;
1008 : 10366816 : 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 : 5766220 : match_string_constant (gfc_expr **result)
1025 : : {
1026 : 5766220 : char name[GFC_MAX_SYMBOL_LEN + 1], peek;
1027 : 5766220 : size_t length;
1028 : 5766220 : int kind,save_warn_ampersand, ret;
1029 : 5766220 : locus old_locus, start_locus;
1030 : 5766220 : gfc_symbol *sym;
1031 : 5766220 : gfc_expr *e;
1032 : 5766220 : match m;
1033 : 5766220 : gfc_char_t c, delimiter, *p;
1034 : :
1035 : 5766220 : old_locus = gfc_current_locus;
1036 : :
1037 : 5766220 : gfc_gobble_whitespace ();
1038 : :
1039 : 5766220 : c = gfc_next_char ();
1040 : 5766220 : if (c == '\'' || c == '"')
1041 : : {
1042 : 252379 : kind = gfc_default_character_kind;
1043 : 252379 : start_locus = gfc_current_locus;
1044 : 252379 : goto got_delim;
1045 : : }
1046 : :
1047 : 5513841 : if (gfc_wide_is_digit (c))
1048 : : {
1049 : 2020277 : kind = 0;
1050 : :
1051 : 4801313 : while (gfc_wide_is_digit (c))
1052 : : {
1053 : 2784607 : kind = kind * 10 + c - '0';
1054 : 2784607 : if (kind > 9999999)
1055 : 3571 : goto no_match;
1056 : 2781036 : c = gfc_next_char ();
1057 : : }
1058 : :
1059 : : }
1060 : : else
1061 : : {
1062 : 3493564 : gfc_current_locus = old_locus;
1063 : :
1064 : 3493564 : m = match_charkind_name (name);
1065 : 3493564 : if (m != MATCH_YES)
1066 : 3492770 : goto no_match;
1067 : :
1068 : 794 : if (gfc_find_symbol (name, NULL, 1, &sym)
1069 : 794 : || sym == NULL
1070 : 1587 : || sym->attr.flavor != FL_PARAMETER)
1071 : 1 : goto no_match;
1072 : :
1073 : 793 : kind = -1;
1074 : 793 : c = gfc_next_char ();
1075 : : }
1076 : :
1077 : 2017499 : if (c != '_')
1078 : 1832178 : goto no_match;
1079 : :
1080 : 185321 : c = gfc_next_char ();
1081 : 185321 : if (c != '\'' && c != '"')
1082 : 147602 : goto no_match;
1083 : :
1084 : 37719 : start_locus = gfc_current_locus;
1085 : :
1086 : 37719 : if (kind == -1)
1087 : : {
1088 : 793 : if (gfc_extract_int (sym->value, &kind, 1))
1089 : : return MATCH_ERROR;
1090 : 793 : gfc_set_sym_referenced (sym);
1091 : : }
1092 : :
1093 : 37719 : 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 : 37719 : 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 : 290098 : delimiter = c;
1106 : 290098 : length = 0;
1107 : :
1108 : 3685742 : for (;;)
1109 : : {
1110 : 1987920 : c = next_string_char (delimiter, &ret);
1111 : 1987920 : if (ret == -1)
1112 : : break;
1113 : 1697826 : 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 : 1697822 : 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 : 290094 : peek = gfc_peek_ascii_char ();
1126 : 290094 : if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
1127 : 25 : goto no_match;
1128 : :
1129 : 290069 : e = gfc_get_character_expr (kind, &start_locus, NULL, length);
1130 : :
1131 : 290069 : 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 : 290069 : save_warn_ampersand = warn_ampersand;
1136 : 290069 : warn_ampersand = false;
1137 : :
1138 : 290069 : p = e->value.character.string;
1139 : 1987577 : for (size_t i = 0; i < length; i++)
1140 : : {
1141 : 1697513 : c = next_string_char (delimiter, &ret);
1142 : :
1143 : 1697513 : 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 : 1697508 : *p++ = c;
1152 : : }
1153 : :
1154 : 290064 : *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
1155 : 290064 : warn_ampersand = save_warn_ampersand;
1156 : :
1157 : 290064 : next_string_char (delimiter, &ret);
1158 : 290064 : if (ret != -1)
1159 : 0 : gfc_internal_error ("match_string_constant(): Delimiter not found");
1160 : :
1161 : 290064 : if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
1162 : 312 : 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 : 290064 : if (e->expr_type == EXPR_SUBSTRING
1168 : 312 : && e->ref && e->ref->type == REF_SUBSTRING
1169 : 308 : && 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 : 290058 : *result = e;
1220 : :
1221 : 290058 : return MATCH_YES;
1222 : :
1223 : 5476147 : no_match:
1224 : 5476147 : gfc_current_locus = old_locus;
1225 : 5476147 : 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 : 3487470 : match_logical_constant_string (void)
1233 : : {
1234 : 3487470 : locus orig_loc = gfc_current_locus;
1235 : :
1236 : 3487470 : gfc_gobble_whitespace ();
1237 : 3487470 : if (gfc_next_ascii_char () == '.')
1238 : : {
1239 : 38873 : char ch = gfc_next_ascii_char ();
1240 : 38873 : if (ch == 'f')
1241 : : {
1242 : 20607 : if (gfc_next_ascii_char () == 'a'
1243 : 20607 : && gfc_next_ascii_char () == 'l'
1244 : 20607 : && gfc_next_ascii_char () == 's'
1245 : 20607 : && gfc_next_ascii_char () == 'e'
1246 : 41214 : && gfc_next_ascii_char () == '.')
1247 : : /* Matched ".false.". */
1248 : : return 0;
1249 : : }
1250 : 18266 : else if (ch == 't')
1251 : : {
1252 : 18265 : if (gfc_next_ascii_char () == 'r'
1253 : 18265 : && gfc_next_ascii_char () == 'u'
1254 : 18265 : && gfc_next_ascii_char () == 'e'
1255 : 36530 : && gfc_next_ascii_char () == '.')
1256 : : /* Matched ".true.". */
1257 : : return 1;
1258 : : }
1259 : : }
1260 : 3448598 : gfc_current_locus = orig_loc;
1261 : 3448598 : return -1;
1262 : : }
1263 : :
1264 : : /* Match a .true. or .false. */
1265 : :
1266 : : static match
1267 : 3487470 : match_logical_constant (gfc_expr **result)
1268 : : {
1269 : 3487470 : gfc_expr *e;
1270 : 3487470 : int i, kind, is_iso_c;
1271 : :
1272 : 3487470 : i = match_logical_constant_string ();
1273 : 3487470 : if (i == -1)
1274 : : return MATCH_NO;
1275 : :
1276 : 38872 : kind = get_kind (&is_iso_c);
1277 : 38872 : if (kind == -1)
1278 : : return MATCH_ERROR;
1279 : 38872 : if (kind == -2)
1280 : 38415 : kind = gfc_default_logical_kind;
1281 : :
1282 : 38872 : 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 : 38868 : e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
1289 : 38868 : e->ts.is_c_interop = is_iso_c;
1290 : :
1291 : 38868 : *result = e;
1292 : 38868 : 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 : 119285 : match_sym_complex_part (gfc_expr **result)
1301 : : {
1302 : 119285 : char name[GFC_MAX_SYMBOL_LEN + 1];
1303 : 119285 : gfc_symbol *sym;
1304 : 119285 : gfc_expr *e;
1305 : 119285 : match m;
1306 : :
1307 : 119285 : m = gfc_match_name (name);
1308 : 119285 : if (m != MATCH_YES)
1309 : : return m;
1310 : :
1311 : 36348 : if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1312 : : return MATCH_NO;
1313 : :
1314 : 33704 : 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 : 32309 : char c;
1320 : 32309 : gfc_gobble_whitespace ();
1321 : 32309 : c = gfc_peek_ascii_char ();
1322 : 32309 : if (c == '=' || c == ',')
1323 : : {
1324 : : m = MATCH_NO;
1325 : : }
1326 : : else
1327 : : {
1328 : 29796 : gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1329 : 29796 : m = MATCH_ERROR;
1330 : : }
1331 : 32309 : 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 : 119285 : match_complex_part (gfc_expr **result)
1388 : : {
1389 : 119285 : match m;
1390 : :
1391 : 119285 : m = match_sym_complex_part (result);
1392 : 119285 : if (m != MATCH_NO)
1393 : : return m;
1394 : :
1395 : 88094 : m = match_real_constant (result, 1);
1396 : 88094 : if (m != MATCH_NO)
1397 : : return m;
1398 : :
1399 : 74766 : return match_integer_constant (result, 1);
1400 : : }
1401 : :
1402 : :
1403 : : /* Try to match a complex constant. */
1404 : :
1405 : : static match
1406 : 5775877 : match_complex_constant (gfc_expr **result)
1407 : : {
1408 : 5775877 : gfc_expr *e, *real, *imag;
1409 : 5775877 : gfc_error_buffer old_error;
1410 : 5775877 : gfc_typespec target;
1411 : 5775877 : locus old_loc;
1412 : 5775877 : int kind;
1413 : 5775877 : match m;
1414 : :
1415 : 5775877 : old_loc = gfc_current_locus;
1416 : 5775877 : real = imag = e = NULL;
1417 : :
1418 : 5775877 : m = gfc_match_char ('(');
1419 : 5775877 : if (m != MATCH_YES)
1420 : : return m;
1421 : :
1422 : 109632 : gfc_push_error (&old_error);
1423 : :
1424 : 109632 : m = match_complex_part (&real);
1425 : 109632 : if (m == MATCH_NO)
1426 : : {
1427 : 58028 : gfc_free_error (&old_error);
1428 : 58028 : goto cleanup;
1429 : : }
1430 : :
1431 : 51604 : 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 : 41947 : gfc_clear_warning ();
1437 : 41947 : gfc_pop_error (&old_error);
1438 : 41947 : m = MATCH_NO;
1439 : 41947 : 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 : 9657 : if (m == MATCH_ERROR)
1448 : : {
1449 : 4 : gfc_free_error (&old_error);
1450 : 4 : goto cleanup;
1451 : : }
1452 : 9653 : gfc_pop_error (&old_error);
1453 : :
1454 : 9653 : m = match_complex_part (&imag);
1455 : 9653 : if (m == MATCH_NO)
1456 : 3010 : goto syntax;
1457 : 6643 : if (m == MATCH_ERROR)
1458 : 133 : goto cleanup;
1459 : :
1460 : 6510 : m = gfc_match_char (')');
1461 : 6510 : 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 : 6497 : if (m == MATCH_ERROR)
1475 : 0 : goto cleanup;
1476 : :
1477 : : /* Decide on the kind of this complex number. */
1478 : 6497 : if (real->ts.type == BT_REAL)
1479 : : {
1480 : 6084 : if (imag->ts.type == BT_REAL)
1481 : 6059 : 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 : 6497 : gfc_clear_ts (&target);
1493 : 6497 : target.type = BT_REAL;
1494 : 6497 : target.kind = kind;
1495 : :
1496 : 6497 : if (real->ts.type != BT_REAL || kind != real->ts.kind)
1497 : 414 : gfc_convert_type (real, &target, 2);
1498 : 6497 : if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1499 : 469 : gfc_convert_type (imag, &target, 2);
1500 : :
1501 : 6497 : e = convert_complex (real, imag, kind);
1502 : 6497 : e->where = gfc_current_locus;
1503 : :
1504 : 6497 : gfc_free_expr (real);
1505 : 6497 : gfc_free_expr (imag);
1506 : :
1507 : 6497 : *result = e;
1508 : 6497 : 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 : 103135 : cleanup:
1515 : 103135 : gfc_free_expr (e);
1516 : 103135 : gfc_free_expr (real);
1517 : 103135 : gfc_free_expr (imag);
1518 : 103135 : gfc_current_locus = old_loc;
1519 : :
1520 : 103135 : return m;
1521 : 5775877 : }
1522 : :
1523 : :
1524 : : /* Match constants in any of several forms. Returns nonzero for a
1525 : : match, zero for no match. */
1526 : :
1527 : : match
1528 : 5775877 : gfc_match_literal_constant (gfc_expr **result, int signflag)
1529 : : {
1530 : 5775877 : match m;
1531 : :
1532 : 5775877 : m = match_complex_constant (result);
1533 : 5775877 : if (m != MATCH_NO)
1534 : : return m;
1535 : :
1536 : 5766220 : m = match_string_constant (result);
1537 : 5766220 : if (m != MATCH_NO)
1538 : : return m;
1539 : :
1540 : 5476147 : m = match_boz_constant (result);
1541 : 5476147 : if (m != MATCH_NO)
1542 : : return m;
1543 : :
1544 : 5472138 : m = match_real_constant (result, signflag);
1545 : 5472138 : if (m != MATCH_NO)
1546 : : return m;
1547 : :
1548 : 5272162 : m = match_hollerith_constant (result);
1549 : 5272162 : if (m != MATCH_NO)
1550 : : return m;
1551 : :
1552 : 5269513 : m = match_integer_constant (result, signflag);
1553 : 5269513 : if (m != MATCH_NO)
1554 : : return m;
1555 : :
1556 : 3487470 : m = match_logical_constant (result);
1557 : 3487470 : 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 : 680491 : gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1570 : : {
1571 : 680491 : if (!sym->attr.function || (sym->result != sym))
1572 : : return false;
1573 : 1410228 : while (ns)
1574 : : {
1575 : 793702 : if (ns->proc_name == sym)
1576 : : return true;
1577 : 782792 : 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 : 1740505 : match_actual_arg (gfc_expr **result)
1592 : : {
1593 : 1740505 : char name[GFC_MAX_SYMBOL_LEN + 1];
1594 : 1740505 : gfc_symtree *symtree;
1595 : 1740505 : locus where, w;
1596 : 1740505 : gfc_expr *e;
1597 : 1740505 : char c;
1598 : :
1599 : 1740505 : gfc_gobble_whitespace ();
1600 : 1740505 : where = gfc_current_locus;
1601 : :
1602 : 1740505 : switch (gfc_match_name (name))
1603 : : {
1604 : : case MATCH_ERROR:
1605 : : return MATCH_ERROR;
1606 : :
1607 : : case MATCH_NO:
1608 : : break;
1609 : :
1610 : 1120294 : case MATCH_YES:
1611 : 1120294 : w = gfc_current_locus;
1612 : 1120294 : gfc_gobble_whitespace ();
1613 : 1120294 : c = gfc_next_ascii_char ();
1614 : 1120294 : gfc_current_locus = w;
1615 : :
1616 : 1120294 : if (c != ',' && c != ')')
1617 : : break;
1618 : :
1619 : 591988 : 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 : 591988 : if (symtree == NULL)
1626 : : {
1627 : 11759 : gfc_get_sym_tree (name, NULL, &symtree, false);
1628 : 11759 : gfc_set_sym_referenced (symtree->n.sym);
1629 : : }
1630 : : else
1631 : : {
1632 : 580229 : gfc_symbol *sym;
1633 : :
1634 : 580229 : sym = symtree->n.sym;
1635 : 580229 : gfc_set_sym_referenced (sym);
1636 : 580229 : 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 : 579134 : if (sym->attr.flavor != FL_PROCEDURE
1643 : 546219 : && sym->attr.flavor != FL_UNKNOWN)
1644 : : break;
1645 : :
1646 : 170769 : 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 : 170545 : if (sym->attr.function && sym->result == sym)
1657 : : {
1658 : 2963 : if (gfc_is_function_return_value (sym, gfc_current_ns))
1659 : : break;
1660 : :
1661 : 2349 : 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 : 181636 : e = gfc_get_expr (); /* Leave it unknown for now */
1678 : 181636 : e->symtree = symtree;
1679 : 181636 : e->expr_type = EXPR_VARIABLE;
1680 : 181636 : e->ts.type = BT_PROCEDURE;
1681 : 181636 : e->where = where;
1682 : :
1683 : 181636 : *result = e;
1684 : 181636 : return MATCH_YES;
1685 : : }
1686 : :
1687 : 1558869 : gfc_current_locus = where;
1688 : 1558869 : return gfc_match_expr (result);
1689 : : }
1690 : :
1691 : :
1692 : : /* Match a keyword argument or type parameter spec list.. */
1693 : :
1694 : : static match
1695 : 1732483 : match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
1696 : : {
1697 : 1732483 : char name[GFC_MAX_SYMBOL_LEN + 1];
1698 : 1732483 : gfc_actual_arglist *a;
1699 : 1732483 : locus name_locus;
1700 : 1732483 : match m;
1701 : :
1702 : 1732483 : name_locus = gfc_current_locus;
1703 : 1732483 : m = gfc_match_name (name);
1704 : :
1705 : 1732483 : if (m != MATCH_YES)
1706 : 536669 : goto cleanup;
1707 : 1195814 : if (gfc_match_char ('=') != MATCH_YES)
1708 : : {
1709 : 1067507 : m = MATCH_NO;
1710 : 1067507 : goto cleanup;
1711 : : }
1712 : :
1713 : 128307 : 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 : 128275 : m = match_actual_arg (&actual->expr);
1730 : 128275 : if (m != MATCH_YES)
1731 : 10182 : goto cleanup;
1732 : :
1733 : : /* Make sure this name has not appeared yet. */
1734 : 118093 : add_name:
1735 : 118125 : if (name[0] != '\0')
1736 : : {
1737 : 364150 : for (a = base; a; a = a->next)
1738 : 246035 : 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 : 118115 : actual->name = gfc_get_string ("%s", name);
1747 : 118115 : return MATCH_YES;
1748 : :
1749 : 1614358 : cleanup:
1750 : 1614358 : gfc_current_locus = name_locus;
1751 : 1614358 : return m;
1752 : : }
1753 : :
1754 : :
1755 : : /* Match an argument list function, such as %VAL. */
1756 : :
1757 : : static match
1758 : 1703241 : match_arg_list_function (gfc_actual_arglist *result)
1759 : : {
1760 : 1703241 : char name[GFC_MAX_SYMBOL_LEN + 1];
1761 : 1703241 : locus old_locus;
1762 : 1703241 : match m;
1763 : :
1764 : 1703241 : old_locus = gfc_current_locus;
1765 : :
1766 : 1703241 : if (gfc_match_char ('%') != MATCH_YES)
1767 : : {
1768 : 1702996 : m = MATCH_NO;
1769 : 1702996 : 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 : 1702997 : cleanup:
1826 : 1702997 : gfc_current_locus = old_locus;
1827 : 1702997 : 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 : 1815234 : gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
1845 : : {
1846 : 1815234 : gfc_actual_arglist *head, *tail;
1847 : 1815234 : int seen_keyword;
1848 : 1815234 : gfc_st_label *label;
1849 : 1815234 : locus old_loc;
1850 : 1815234 : match m;
1851 : :
1852 : 1815234 : *argp = tail = NULL;
1853 : 1815234 : old_loc = gfc_current_locus;
1854 : :
1855 : 1815234 : seen_keyword = 0;
1856 : :
1857 : 1815234 : if (gfc_match_char ('(') == MATCH_NO)
1858 : 1080918 : return (sub_flag) ? MATCH_YES : MATCH_NO;
1859 : :
1860 : 1260160 : if (gfc_match_char (')') == MATCH_YES)
1861 : : return MATCH_YES;
1862 : :
1863 : 1237251 : head = NULL;
1864 : :
1865 : 1237251 : matching_actual_arglist++;
1866 : :
1867 : 1732647 : for (;;)
1868 : : {
1869 : 1732647 : if (head == NULL)
1870 : 1237251 : head = tail = gfc_get_actual_arglist ();
1871 : : else
1872 : : {
1873 : 495396 : tail->next = gfc_get_actual_arglist ();
1874 : 495396 : tail = tail->next;
1875 : : }
1876 : :
1877 : 1732647 : 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 : 1732409 : 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 : 1732059 : if (seen_keyword)
1921 : : {
1922 : 28818 : m = match_keyword_arg (tail, head, pdt);
1923 : :
1924 : 28818 : if (m == MATCH_ERROR)
1925 : 29 : goto cleanup;
1926 : 28789 : if (m == MATCH_NO)
1927 : : {
1928 : 1185 : gfc_error ("Missing keyword name in actual argument list at %C");
1929 : 1185 : goto cleanup;
1930 : : }
1931 : :
1932 : : }
1933 : : else
1934 : : {
1935 : : /* Try an argument list function, like %VAL. */
1936 : 1703241 : m = match_arg_list_function (tail);
1937 : 1703241 : if (m == MATCH_ERROR)
1938 : 1 : goto cleanup;
1939 : :
1940 : : /* See if we have the first keyword argument. */
1941 : 1703240 : if (m == MATCH_NO)
1942 : : {
1943 : 1702996 : m = match_keyword_arg (tail, head, false);
1944 : 1702996 : if (m == MATCH_YES)
1945 : : seen_keyword = 1;
1946 : 1612682 : if (m == MATCH_ERROR)
1947 : 696 : goto cleanup;
1948 : : }
1949 : :
1950 : 1702300 : if (m == MATCH_NO)
1951 : : {
1952 : : /* Try for a non-keyword argument. */
1953 : 1611986 : m = match_actual_arg (&tail->expr);
1954 : 1611986 : if (m == MATCH_ERROR)
1955 : 1746 : goto cleanup;
1956 : 1610240 : if (m == MATCH_NO)
1957 : 17168 : goto syntax;
1958 : : }
1959 : : }
1960 : :
1961 : :
1962 : 90314 : next:
1963 : 1711822 : if (gfc_match_char (')') == MATCH_YES)
1964 : : break;
1965 : 503134 : if (gfc_match_char (',') != MATCH_YES)
1966 : 7738 : goto syntax;
1967 : : }
1968 : :
1969 : 1208688 : *argp = head;
1970 : 1208688 : matching_actual_arglist--;
1971 : 1208688 : return MATCH_YES;
1972 : :
1973 : 24906 : syntax:
1974 : 24906 : gfc_error ("Syntax error in argument list at %C");
1975 : :
1976 : 28563 : cleanup:
1977 : 28563 : gfc_free_actual_arglist (head);
1978 : 28563 : gfc_current_locus = old_loc;
1979 : 28563 : matching_actual_arglist--;
1980 : 28563 : 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 : 618494 : extend_ref (gfc_expr *primary, gfc_ref *tail)
1989 : : {
1990 : 618494 : if (primary->ref == NULL)
1991 : 567991 : primary->ref = tail = gfc_get_ref ();
1992 : : else
1993 : : {
1994 : 50503 : if (tail == NULL)
1995 : 0 : gfc_internal_error ("extend_ref(): Bad tail");
1996 : 50503 : tail->next = gfc_get_ref ();
1997 : 50503 : tail = tail->next;
1998 : : }
1999 : :
2000 : 618494 : return tail;
2001 : : }
2002 : :
2003 : :
2004 : : /* Used by gfc_match_varspec() to match an inquiry reference. */
2005 : :
2006 : : bool
2007 : 2806 : is_inquiry_ref (const char *name, gfc_ref **ref)
2008 : : {
2009 : 2806 : inquiry_type type;
2010 : :
2011 : 2806 : if (name == NULL)
2012 : : return false;
2013 : :
2014 : 2806 : if (ref) *ref = NULL;
2015 : :
2016 : 2806 : if (strcmp (name, "re") == 0)
2017 : : type = INQUIRY_RE;
2018 : 2074 : else if (strcmp (name, "im") == 0)
2019 : : type = INQUIRY_IM;
2020 : 1437 : else if (strcmp (name, "kind") == 0)
2021 : : type = INQUIRY_KIND;
2022 : 981 : else if (strcmp (name, "len") == 0)
2023 : : type = INQUIRY_LEN;
2024 : : else
2025 : : return false;
2026 : :
2027 : 2251 : if (ref)
2028 : : {
2029 : 2251 : *ref = gfc_get_ref ();
2030 : 2251 : (*ref)->type = REF_INQUIRY;
2031 : 2251 : (*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 : 3984099 : gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
2071 : : bool ppc_arg)
2072 : : {
2073 : 3984099 : char name[GFC_MAX_SYMBOL_LEN + 1];
2074 : 3984099 : gfc_ref *substring, *tail, *tmp;
2075 : 3984099 : gfc_component *component = NULL;
2076 : 3984099 : gfc_component *previous = NULL;
2077 : 3984099 : gfc_symbol *sym = primary->symtree->n.sym;
2078 : 3984099 : gfc_expr *tgt_expr = NULL;
2079 : 3984099 : match m;
2080 : 3984099 : bool unknown;
2081 : 3984099 : bool inquiry;
2082 : 3984099 : bool intrinsic;
2083 : 3984099 : bool inferred_type;
2084 : 3984099 : locus old_loc;
2085 : 3984099 : char sep;
2086 : :
2087 : 3984099 : tail = NULL;
2088 : :
2089 : 3984099 : gfc_gobble_whitespace ();
2090 : :
2091 : 3984099 : if (gfc_peek_ascii_char () == '[')
2092 : : {
2093 : 2655 : if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
2094 : 2655 : || (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 : 2655 : if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
2102 : 2654 : || (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 : 3984098 : if (sym->assoc && sym->assoc->target)
2112 : 3984098 : tgt_expr = sym->assoc->target;
2113 : :
2114 : 3984098 : inferred_type = IS_INFERRED_TYPE (primary);
2115 : :
2116 : : /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
2117 : : selector has not been parsed, can generate errors with array and component
2118 : : refs.. Use 'inferred_type' as a flag to suppress these errors. */
2119 : 3983288 : if (!inferred_type
2120 : 3983288 : && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
2121 : 723390 : && !sym->attr.codimension
2122 : : && sym->attr.select_type_temporary
2123 : 723359 : && !sym->attr.select_rank_temporary)
2124 : : 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 : 3984098 : if (sym->assoc
2133 : 27008 : && gfc_peek_ascii_char () == '('
2134 : 9164 : && sym->ts.type != BT_CLASS
2135 : 3993127 : && !sym->attr.dimension)
2136 : : {
2137 : 346 : gfc_ref *ref = NULL;
2138 : :
2139 : 346 : if (!sym->assoc->dangling && tgt_expr)
2140 : : {
2141 : 298 : if (tgt_expr->expr_type == EXPR_VARIABLE)
2142 : 21 : gfc_resolve_expr (tgt_expr);
2143 : :
2144 : 298 : ref = tgt_expr->ref;
2145 : 312 : 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 : 346 : if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
2153 : 232 : && sym->assoc->st
2154 : 232 : && sym->assoc->st->n.sym
2155 : 232 : && sym->assoc->st->n.sym->attr.dimension == 0))
2156 : : {
2157 : 232 : sym->attr.dimension = 1;
2158 : 232 : if (sym->as == NULL
2159 : 232 : && sym->assoc->st
2160 : 232 : && sym->assoc->st->n.sym
2161 : 232 : && sym->assoc->st->n.sym->as)
2162 : 0 : sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
2163 : : }
2164 : : }
2165 : 3983752 : else if (sym->ts.type == BT_CLASS
2166 : 39402 : && tgt_expr
2167 : 246 : && tgt_expr->expr_type == EXPR_VARIABLE
2168 : 120 : && sym->ts.u.derived != tgt_expr->ts.u.derived)
2169 : : {
2170 : 13 : gfc_resolve_expr (tgt_expr);
2171 : 13 : if (tgt_expr->rank)
2172 : 0 : sym->ts.u.derived = tgt_expr->ts.u.derived;
2173 : : }
2174 : :
2175 : 890 : if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(')
2176 : 3983832 : || (equiv_flag && gfc_peek_ascii_char () == '(')
2177 : 3982251 : || gfc_peek_ascii_char () == '[' || sym->attr.codimension
2178 : 3966141 : || (sym->attr.dimension && sym->ts.type != BT_CLASS
2179 : 535312 : && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
2180 : 535297 : && !(gfc_matching_procptr_assignment
2181 : 32 : && sym->attr.flavor == FL_PROCEDURE))
2182 : 7414962 : || (sym->ts.type == BT_CLASS && sym->attr.class_ok
2183 : 39217 : && sym->ts.u.derived && CLASS_DATA (sym)
2184 : 39213 : && (CLASS_DATA (sym)->attr.dimension
2185 : 39213 : || CLASS_DATA (sym)->attr.codimension)))
2186 : : {
2187 : 567991 : gfc_array_spec *as;
2188 : :
2189 : 567991 : tail = extend_ref (primary, tail);
2190 : 567991 : 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 : 567991 : if (equiv_flag)
2197 : : as = NULL;
2198 : 565976 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
2199 : 14895 : as = CLASS_DATA (sym)->as;
2200 : : else
2201 : 551081 : as = sym->as;
2202 : :
2203 : 567991 : m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
2204 : : as ? as->corank : 0);
2205 : 567991 : if (m != MATCH_YES)
2206 : : return m;
2207 : :
2208 : 567942 : gfc_gobble_whitespace ();
2209 : 567942 : 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 : 3984049 : primary->ts = sym->ts;
2221 : :
2222 : 3984049 : if (equiv_flag)
2223 : : return MATCH_YES;
2224 : :
2225 : : /* With DEC extensions, member separator may be '.' or '%'. */
2226 : 3981077 : sep = gfc_peek_ascii_char ();
2227 : 3981077 : m = gfc_match_member_sep (sym);
2228 : 3981077 : if (m == MATCH_ERROR)
2229 : : return MATCH_ERROR;
2230 : :
2231 : 3981076 : inquiry = false;
2232 : 3981076 : if (m == MATCH_YES && sep == '%'
2233 : 127247 : && primary->ts.type != BT_CLASS
2234 : 111502 : && (primary->ts.type != BT_DERIVED || inferred_type))
2235 : : {
2236 : 1533 : match mm;
2237 : 1533 : old_loc = gfc_current_locus;
2238 : 1533 : mm = gfc_match_name (name);
2239 : : /* This is a usable inquiry reference, if the symbol is already known
2240 : : to have a type or no derived types with a component of this name
2241 : : can be found. If this was an inquiry reference with the same name
2242 : : as a derived component and the associate-name type is not derived
2243 : : or class, this is fixed up in 'gfc_fixup_inferred_type_refs'. */
2244 : 1533 : if (mm == MATCH_YES && is_inquiry_ref (name, &tmp)
2245 : 2726 : && !(sym->ts.type == BT_UNKNOWN
2246 : 210 : && gfc_find_derived_types (sym, gfc_current_ns, name)))
2247 : : inquiry = true;
2248 : 1533 : gfc_current_locus = old_loc;
2249 : : }
2250 : :
2251 : : /* Use the default type if there is one. */
2252 : 2313061 : if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
2253 : 3981534 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2254 : 1 : gfc_set_default_type (sym, 0, sym->ns);
2255 : :
2256 : : /* See if the type can be determined by resolution of the selector expression,
2257 : : if allowable now, or inferred from references. */
2258 : 3981076 : if ((sym->ts.type == BT_UNKNOWN || inferred_type)
2259 : 2313698 : && m == MATCH_YES)
2260 : : {
2261 : 907 : bool sym_present, resolved = false;
2262 : 907 : gfc_symbol *tgt_sym;
2263 : :
2264 : 907 : sym_present = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym;
2265 : 907 : tgt_sym = sym_present ? tgt_expr->symtree->n.sym : NULL;
2266 : :
2267 : : /* These target expressions can be resolved at any time:
2268 : : (i) With a declared symbol or intrinsic function; or
2269 : : (ii) An operator expression,
2270 : : just as long as (iii) all the functions in the expression have been
2271 : : declared or are intrinsic. */
2272 : 907 : if (((sym_present // (i)
2273 : 822 : && (tgt_sym->attr.use_assoc
2274 : 822 : || tgt_sym->attr.host_assoc
2275 : 804 : || tgt_sym->attr.if_source == IFSRC_DECL
2276 : 804 : || tgt_sym->attr.proc == PROC_INTRINSIC
2277 : 804 : || gfc_is_intrinsic (tgt_sym, 0, tgt_expr->where)))
2278 : 877 : || (tgt_expr && tgt_expr->expr_type == EXPR_OP)) // (ii)
2279 : 48 : && !gfc_traverse_expr (tgt_expr, NULL, resolvable_fcns, 0) // (iii)
2280 : 42 : && gfc_resolve_expr (tgt_expr))
2281 : : {
2282 : 42 : sym->ts = tgt_expr->ts;
2283 : 42 : primary->ts = sym->ts;
2284 : 42 : resolved = true;
2285 : : }
2286 : :
2287 : : /* If this hasn't done the trick and the target expression is a function,
2288 : : or an unresolved operator expression, then this must be a derived type
2289 : : if 'name' matches an accessible type both in this namespace and in the
2290 : : as yet unparsed contained function. In principle, the type could have
2291 : : already been inferred to be complex and yet a derived type with a
2292 : : component name 're' or 'im' could be found. */
2293 : 42 : if (tgt_expr
2294 : 840 : && (tgt_expr->expr_type == EXPR_FUNCTION
2295 : 72 : || (!resolved && tgt_expr->expr_type == EXPR_OP))
2296 : 774 : && (sym->ts.type == BT_UNKNOWN
2297 : 372 : || (inferred_type && sym->ts.type != BT_COMPLEX))
2298 : 1567 : && gfc_find_derived_types (sym, gfc_current_ns, name, true))
2299 : : {
2300 : 510 : sym->assoc->inferred_type = 1;
2301 : : /* The first returned type is as good as any at this stage. The final
2302 : : determination is made in 'gfc_fixup_inferred_type_refs'*/
2303 : 510 : gfc_symbol **dts = &sym->assoc->derived_types;
2304 : 510 : tgt_expr->ts.type = BT_DERIVED;
2305 : 510 : tgt_expr->ts.kind = 0;
2306 : 510 : tgt_expr->ts.u.derived = *dts;
2307 : 510 : sym->ts = tgt_expr->ts;
2308 : 510 : primary->ts = sym->ts;
2309 : : /* Delete the dt list even if this process has to be done again for
2310 : : another primary expression. */
2311 : 1062 : while (*dts && (*dts)->dt_next)
2312 : : {
2313 : 552 : gfc_symbol **tmp = &(*dts)->dt_next;
2314 : 552 : *dts = NULL;
2315 : 552 : dts = tmp;
2316 : : }
2317 : : }
2318 : : /* If there is a usable inquiry reference not there are no matching
2319 : : derived types, force the inquiry reference by setting unknown the
2320 : : type of the primary expression. */
2321 : 258 : else if (inquiry && (sym->ts.type == BT_DERIVED && inferred_type)
2322 : 445 : && !gfc_find_derived_types (sym, gfc_current_ns, name))
2323 : 48 : primary->ts.type = BT_UNKNOWN;
2324 : :
2325 : : /* An inquiry reference might determine the type, otherwise we have an
2326 : : error. */
2327 : 907 : if (sym->ts.type == BT_UNKNOWN && !inquiry)
2328 : : {
2329 : 13 : gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
2330 : 13 : return MATCH_ERROR;
2331 : : }
2332 : : }
2333 : 3980169 : else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
2334 : 3780503 : && m == MATCH_YES && !inquiry)
2335 : : {
2336 : 3 : gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
2337 : : sep, sym->name);
2338 : 3 : return MATCH_ERROR;
2339 : : }
2340 : :
2341 : 3981060 : if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry)
2342 : 201213 : || m != MATCH_YES)
2343 : 3851743 : goto check_substring;
2344 : :
2345 : 129317 : if (!inquiry)
2346 : 128406 : sym = sym->ts.u.derived;
2347 : : else
2348 : : sym = NULL;
2349 : :
2350 : 146343 : for (;;)
2351 : : {
2352 : 146343 : bool t;
2353 : 146343 : gfc_symtree *tbp;
2354 : :
2355 : 146343 : m = gfc_match_name (name);
2356 : 146343 : if (m == MATCH_NO)
2357 : 0 : gfc_error ("Expected structure component name at %C");
2358 : 146343 : if (m != MATCH_YES)
2359 : 131 : return MATCH_ERROR;
2360 : :
2361 : 146343 : intrinsic = false;
2362 : 146343 : if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
2363 : : {
2364 : 1261 : inquiry = is_inquiry_ref (name, &tmp);
2365 : 1261 : if (inquiry)
2366 : 1256 : sym = NULL;
2367 : :
2368 : 1261 : if (sep == '%')
2369 : : {
2370 : 1261 : if (tmp)
2371 : : {
2372 : 1256 : gfc_symbol *s;
2373 : 1256 : switch (tmp->u.i)
2374 : : {
2375 : 762 : case INQUIRY_RE:
2376 : 762 : case INQUIRY_IM:
2377 : 762 : if (!gfc_notify_std (GFC_STD_F2008,
2378 : : "RE or IM part_ref at %C"))
2379 : : return MATCH_ERROR;
2380 : : break;
2381 : :
2382 : 248 : case INQUIRY_KIND:
2383 : 248 : if (!gfc_notify_std (GFC_STD_F2003,
2384 : : "KIND part_ref at %C"))
2385 : : return MATCH_ERROR;
2386 : : break;
2387 : :
2388 : 246 : case INQUIRY_LEN:
2389 : 246 : if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
2390 : : return MATCH_ERROR;
2391 : : break;
2392 : : }
2393 : :
2394 : : /* If necessary, infer the type of the primary expression
2395 : : and the associate-name using the the inquiry ref.. */
2396 : 1247 : s = primary->symtree ? primary->symtree->n.sym : NULL;
2397 : 1243 : if (s && s->assoc && s->assoc->target
2398 : 258 : && (s->ts.type == BT_UNKNOWN
2399 : 138 : || (primary->ts.type == BT_UNKNOWN
2400 : 48 : && s->assoc->inferred_type
2401 : 48 : && s->ts.type == BT_DERIVED)))
2402 : : {
2403 : 168 : if (tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
2404 : : {
2405 : 72 : s->ts.type = BT_COMPLEX;
2406 : 72 : s->ts.kind = gfc_default_real_kind;;
2407 : 72 : s->assoc->inferred_type = 1;
2408 : 72 : primary->ts = s->ts;
2409 : : }
2410 : 96 : else if (tmp->u.i == INQUIRY_LEN)
2411 : : {
2412 : 48 : s->ts.type = BT_CHARACTER;
2413 : 48 : s->ts.kind = gfc_default_character_kind;;
2414 : 48 : s->assoc->inferred_type = 1;
2415 : 48 : primary->ts = s->ts;
2416 : : }
2417 : 48 : else if (s->ts.type == BT_UNKNOWN)
2418 : : {
2419 : : /* KIND inquiry gives no clue as to symbol type. */
2420 : 48 : primary->ref = tmp;
2421 : 48 : primary->ts.type = BT_INTEGER;
2422 : 48 : primary->ts.kind = gfc_default_integer_kind;
2423 : 48 : return MATCH_YES;
2424 : : }
2425 : : }
2426 : :
2427 : 1199 : if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM)
2428 : 758 : && primary->ts.type != BT_COMPLEX)
2429 : : {
2430 : 12 : gfc_error ("The RE or IM part_ref at %C must be "
2431 : : "applied to a COMPLEX expression");
2432 : 12 : return MATCH_ERROR;
2433 : : }
2434 : 1187 : else if (tmp->u.i == INQUIRY_LEN
2435 : 244 : && primary->ts.type != BT_CHARACTER)
2436 : : {
2437 : 5 : gfc_error ("The LEN part_ref at %C must be applied "
2438 : : "to a CHARACTER expression");
2439 : 5 : return MATCH_ERROR;
2440 : : }
2441 : : }
2442 : 1187 : if (primary->ts.type != BT_UNKNOWN)
2443 : 146269 : intrinsic = true;
2444 : : }
2445 : : }
2446 : : else
2447 : : inquiry = false;
2448 : :
2449 : 146269 : if (sym && sym->f2k_derived)
2450 : 142445 : tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
2451 : : else
2452 : : tbp = NULL;
2453 : :
2454 : 142445 : if (tbp)
2455 : : {
2456 : 3634 : gfc_symbol* tbp_sym;
2457 : :
2458 : 3634 : if (!t)
2459 : : return MATCH_ERROR;
2460 : :
2461 : 3632 : gcc_assert (!tail || !tail->next);
2462 : :
2463 : 3632 : if (!(primary->expr_type == EXPR_VARIABLE
2464 : : || (primary->expr_type == EXPR_STRUCTURE
2465 : 1 : && primary->symtree && primary->symtree->n.sym
2466 : 1 : && primary->symtree->n.sym->attr.flavor)))
2467 : : return MATCH_ERROR;
2468 : :
2469 : 3630 : if (tbp->n.tb->is_generic)
2470 : : tbp_sym = NULL;
2471 : : else
2472 : 2977 : tbp_sym = tbp->n.tb->u.specific->n.sym;
2473 : :
2474 : 3630 : primary->expr_type = EXPR_COMPCALL;
2475 : 3630 : primary->value.compcall.tbp = tbp->n.tb;
2476 : 3630 : primary->value.compcall.name = tbp->name;
2477 : 3630 : primary->value.compcall.ignore_pass = 0;
2478 : 3630 : primary->value.compcall.assign = 0;
2479 : 3630 : primary->value.compcall.base_object = NULL;
2480 : 3630 : gcc_assert (primary->symtree->n.sym->attr.referenced);
2481 : 3630 : if (tbp_sym)
2482 : 2977 : primary->ts = tbp_sym->ts;
2483 : : else
2484 : 653 : gfc_clear_ts (&primary->ts);
2485 : :
2486 : 3630 : m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
2487 : : &primary->value.compcall.actual);
2488 : 3630 : if (m == MATCH_ERROR)
2489 : : return MATCH_ERROR;
2490 : 3630 : if (m == MATCH_NO)
2491 : : {
2492 : 162 : if (sub_flag)
2493 : 161 : primary->value.compcall.actual = NULL;
2494 : : else
2495 : : {
2496 : 1 : gfc_error ("Expected argument list at %C");
2497 : 1 : return MATCH_ERROR;
2498 : : }
2499 : : }
2500 : :
2501 : 129186 : break;
2502 : : }
2503 : :
2504 : 142635 : previous = component;
2505 : :
2506 : 142635 : if (!inquiry && !intrinsic)
2507 : 141450 : component = gfc_find_component (sym, name, false, false, &tmp);
2508 : : else
2509 : : component = NULL;
2510 : :
2511 : 142635 : if (intrinsic && !inquiry)
2512 : : {
2513 : 3 : if (previous)
2514 : 2 : gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2515 : : "type component %qs", name, previous->name);
2516 : : else
2517 : 1 : gfc_error ("%qs at %C is not an inquiry reference to an intrinsic "
2518 : : "type component", name);
2519 : 3 : return MATCH_ERROR;
2520 : : }
2521 : 142632 : else if (component == NULL && !inquiry)
2522 : : return MATCH_ERROR;
2523 : :
2524 : : /* Extend the reference chain determined by gfc_find_component or
2525 : : is_inquiry_ref. */
2526 : 142585 : if (primary->ref == NULL)
2527 : 88429 : primary->ref = tmp;
2528 : : else
2529 : : {
2530 : : /* Set by the for loop below for the last component ref. */
2531 : 54156 : gcc_assert (tail != NULL);
2532 : 54156 : tail->next = tmp;
2533 : : }
2534 : :
2535 : : /* The reference chain may be longer than one hop for union
2536 : : subcomponents; find the new tail. */
2537 : 144561 : for (tail = tmp; tail->next; tail = tail->next)
2538 : : ;
2539 : :
2540 : 142585 : if (tmp && tmp->type == REF_INQUIRY)
2541 : : {
2542 : 1182 : if (!primary->where.lb || !primary->where.nextc)
2543 : 888 : primary->where = gfc_current_locus;
2544 : 1182 : gfc_simplify_expr (primary, 0);
2545 : :
2546 : 1182 : if (primary->expr_type == EXPR_CONSTANT)
2547 : 309 : goto check_done;
2548 : :
2549 : 873 : switch (tmp->u.i)
2550 : : {
2551 : 662 : case INQUIRY_RE:
2552 : 662 : case INQUIRY_IM:
2553 : 662 : if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C"))
2554 : : return MATCH_ERROR;
2555 : :
2556 : 662 : if (primary->ts.type != BT_COMPLEX)
2557 : : {
2558 : 0 : gfc_error ("The RE or IM part_ref at %C must be "
2559 : : "applied to a COMPLEX expression");
2560 : 0 : return MATCH_ERROR;
2561 : : }
2562 : 662 : primary->ts.type = BT_REAL;
2563 : 662 : break;
2564 : :
2565 : 159 : case INQUIRY_LEN:
2566 : 159 : if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
2567 : : return MATCH_ERROR;
2568 : :
2569 : 159 : if (primary->ts.type != BT_CHARACTER)
2570 : : {
2571 : 0 : gfc_error ("The LEN part_ref at %C must be applied "
2572 : : "to a CHARACTER expression");
2573 : 0 : return MATCH_ERROR;
2574 : : }
2575 : 159 : primary->ts.u.cl = NULL;
2576 : 159 : primary->ts.type = BT_INTEGER;
2577 : 159 : primary->ts.kind = gfc_default_integer_kind;
2578 : 159 : break;
2579 : :
2580 : 52 : case INQUIRY_KIND:
2581 : 52 : if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
2582 : : return MATCH_ERROR;
2583 : :
2584 : 52 : if (primary->ts.type == BT_CLASS
2585 : 52 : || primary->ts.type == BT_DERIVED)
2586 : : {
2587 : 0 : gfc_error ("The KIND part_ref at %C must be applied "
2588 : : "to an expression of intrinsic type");
2589 : 0 : return MATCH_ERROR;
2590 : : }
2591 : 52 : primary->ts.type = BT_INTEGER;
2592 : 52 : primary->ts.kind = gfc_default_integer_kind;
2593 : 52 : break;
2594 : :
2595 : 0 : default:
2596 : 0 : gcc_unreachable ();
2597 : : }
2598 : :
2599 : 873 : goto check_done;
2600 : : }
2601 : :
2602 : 141403 : primary->ts = component->ts;
2603 : :
2604 : 141403 : if (component->attr.proc_pointer && ppc_arg)
2605 : : {
2606 : : /* Procedure pointer component call: Look for argument list. */
2607 : 819 : m = gfc_match_actual_arglist (sub_flag,
2608 : : &primary->value.compcall.actual);
2609 : 819 : if (m == MATCH_ERROR)
2610 : : return MATCH_ERROR;
2611 : :
2612 : 819 : if (m == MATCH_NO && !gfc_matching_ptr_assignment
2613 : 247 : && !gfc_matching_procptr_assignment && !matching_actual_arglist)
2614 : : {
2615 : 2 : gfc_error ("Procedure pointer component %qs requires an "
2616 : : "argument list at %C", component->name);
2617 : 2 : return MATCH_ERROR;
2618 : : }
2619 : :
2620 : 817 : if (m == MATCH_YES)
2621 : 571 : primary->expr_type = EXPR_PPC;
2622 : :
2623 : : break;
2624 : : }
2625 : :
2626 : 140584 : if (component->as != NULL && !component->attr.proc_pointer)
2627 : : {
2628 : 45988 : tail = extend_ref (primary, tail);
2629 : 45988 : tail->type = REF_ARRAY;
2630 : :
2631 : 91976 : m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
2632 : 45988 : component->as->corank);
2633 : 45988 : if (m != MATCH_YES)
2634 : 0 : return m;
2635 : : }
2636 : 94596 : else if (component->ts.type == BT_CLASS && component->attr.class_ok
2637 : 9440 : && CLASS_DATA (component)->as && !component->attr.proc_pointer)
2638 : : {
2639 : 4441 : tail = extend_ref (primary, tail);
2640 : 4441 : tail->type = REF_ARRAY;
2641 : :
2642 : 8882 : m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
2643 : : equiv_flag,
2644 : 4441 : CLASS_DATA (component)->as->corank);
2645 : 4441 : if (m != MATCH_YES)
2646 : 0 : return m;
2647 : : }
2648 : :
2649 : 90155 : check_done:
2650 : : /* In principle, we could have eg. expr%re%kind so we must allow for
2651 : : this possibility. */
2652 : 141766 : if (gfc_match_char ('%') == MATCH_YES)
2653 : : {
2654 : 16656 : if (component && (component->ts.type == BT_DERIVED
2655 : 2547 : || component->ts.type == BT_CLASS))
2656 : 16307 : sym = component->ts.u.derived;
2657 : 16656 : continue;
2658 : : }
2659 : 125110 : else if (inquiry)
2660 : : break;
2661 : :
2662 : 115662 : if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
2663 : 131170 : || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
2664 : : break;
2665 : :
2666 : 370 : if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS)
2667 : 370 : sym = component->ts.u.derived;
2668 : : }
2669 : :
2670 : 3980929 : check_substring:
2671 : 3980929 : unknown = false;
2672 : 3980929 : if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
2673 : : {
2674 : 2312603 : if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
2675 : : {
2676 : 352 : gfc_set_default_type (sym, 0, sym->ns);
2677 : 352 : primary->ts = sym->ts;
2678 : 352 : unknown = true;
2679 : : }
2680 : : }
2681 : :
2682 : 3980929 : if (primary->ts.type == BT_CHARACTER)
2683 : : {
2684 : 282967 : bool def = primary->ts.deferred == 1;
2685 : 282967 : switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
2686 : : {
2687 : 13084 : case MATCH_YES:
2688 : 13084 : if (tail == NULL)
2689 : 8239 : primary->ref = substring;
2690 : : else
2691 : 4845 : tail->next = substring;
2692 : :
2693 : 13084 : if (primary->expr_type == EXPR_CONSTANT)
2694 : 753 : primary->expr_type = EXPR_SUBSTRING;
2695 : :
2696 : 13084 : if (substring)
2697 : 12871 : primary->ts.u.cl = NULL;
2698 : :
2699 : : break;
2700 : :
2701 : 269883 : case MATCH_NO:
2702 : 269883 : if (unknown)
2703 : : {
2704 : 351 : gfc_clear_ts (&primary->ts);
2705 : 351 : gfc_clear_ts (&sym->ts);
2706 : : }
2707 : : break;
2708 : :
2709 : : case MATCH_ERROR:
2710 : : return MATCH_ERROR;
2711 : : }
2712 : : }
2713 : :
2714 : : /* F08:C611. */
2715 : 3980929 : if (primary->ts.type == BT_DERIVED && primary->ref
2716 : 24619 : && primary->ts.u.derived && primary->ts.u.derived->attr.abstract)
2717 : : {
2718 : 6 : gfc_error ("Nonpolymorphic reference to abstract type at %C");
2719 : 6 : return MATCH_ERROR;
2720 : : }
2721 : :
2722 : : /* F08:C727. */
2723 : 3980923 : if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
2724 : : {
2725 : 3 : gfc_error ("Coindexed procedure-pointer component at %C");
2726 : 3 : return MATCH_ERROR;
2727 : : }
2728 : :
2729 : : return MATCH_YES;
2730 : : }
2731 : :
2732 : :
2733 : : /* Given an expression that is a variable, figure out what the
2734 : : ultimate variable's type and attribute is, traversing the reference
2735 : : structures if necessary.
2736 : :
2737 : : This subroutine is trickier than it looks. We start at the base
2738 : : symbol and store the attribute. Component references load a
2739 : : completely new attribute.
2740 : :
2741 : : A couple of rules come into play. Subobjects of targets are always
2742 : : targets themselves. If we see a component that goes through a
2743 : : pointer, then the expression must also be a target, since the
2744 : : pointer is associated with something (if it isn't core will soon be
2745 : : dumped). If we see a full part or section of an array, the
2746 : : expression is also an array.
2747 : :
2748 : : We can have at most one full array reference. */
2749 : :
2750 : : symbol_attribute
2751 : 3176549 : gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
2752 : : {
2753 : 3176549 : int dimension, codimension, pointer, allocatable, target, optional;
2754 : 3176549 : symbol_attribute attr;
2755 : 3176549 : gfc_ref *ref;
2756 : 3176549 : gfc_symbol *sym;
2757 : 3176549 : gfc_component *comp;
2758 : 3176549 : bool has_inquiry_part;
2759 : :
2760 : 3176549 : if (expr->expr_type != EXPR_VARIABLE
2761 : 21525 : && expr->expr_type != EXPR_FUNCTION
2762 : 9 : && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
2763 : 0 : gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
2764 : :
2765 : 3176549 : sym = expr->symtree->n.sym;
2766 : 3176549 : attr = sym->attr;
2767 : :
2768 : 3176549 : optional = attr.optional;
2769 : 3176549 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
2770 : : {
2771 : 111725 : dimension = CLASS_DATA (sym)->attr.dimension;
2772 : 111725 : codimension = CLASS_DATA (sym)->attr.codimension;
2773 : 111725 : pointer = CLASS_DATA (sym)->attr.class_pointer;
2774 : 111725 : allocatable = CLASS_DATA (sym)->attr.allocatable;
2775 : : }
2776 : : else
2777 : : {
2778 : 3064824 : dimension = attr.dimension;
2779 : 3064824 : codimension = attr.codimension;
2780 : 3064824 : pointer = attr.pointer;
2781 : 3064824 : allocatable = attr.allocatable;
2782 : : }
2783 : :
2784 : 3176549 : target = attr.target;
2785 : 3176549 : if (pointer || attr.proc_pointer)
2786 : 163098 : target = 1;
2787 : :
2788 : : /* F2018:11.1.3.3: Other attributes of associate names
2789 : : "The associating entity does not have the ALLOCATABLE or POINTER
2790 : : attributes; it has the TARGET attribute if and only if the selector is
2791 : : a variable and has either the TARGET or POINTER attribute." */
2792 : 3176549 : if (sym->attr.associate_var && sym->assoc && sym->assoc->target)
2793 : : {
2794 : 26882 : if (sym->assoc->target->expr_type == EXPR_VARIABLE)
2795 : : {
2796 : 24694 : symbol_attribute tgt_attr;
2797 : 24694 : tgt_attr = gfc_expr_attr (sym->assoc->target);
2798 : 24694 : target = (tgt_attr.pointer || tgt_attr.target);
2799 : : }
2800 : : else
2801 : : target = 0;
2802 : : }
2803 : :
2804 : 3176549 : if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2805 : 49073 : *ts = sym->ts;
2806 : :
2807 : : /* Catch left-overs from match_actual_arg, where an actual argument of a
2808 : : procedure is given a temporary ts.type == BT_PROCEDURE. The fixup is
2809 : : needed for structure constructors in DATA statements, where a pointer
2810 : : is associated with a data target, and the argument has not been fully
2811 : : resolved yet. Components references are dealt with further below. */
2812 : 49073 : if (ts != NULL
2813 : 953678 : && expr->ts.type == BT_PROCEDURE
2814 : 1884 : && expr->ref == NULL
2815 : 1884 : && attr.flavor != FL_PROCEDURE
2816 : 25 : && attr.target)
2817 : 1 : *ts = sym->ts;
2818 : :
2819 : 3176549 : has_inquiry_part = false;
2820 : 4442935 : for (ref = expr->ref; ref; ref = ref->next)
2821 : 1267422 : if (ref->type == REF_INQUIRY)
2822 : : {
2823 : : has_inquiry_part = true;
2824 : : optional = false;
2825 : : break;
2826 : : }
2827 : :
2828 : 4443978 : for (ref = expr->ref; ref; ref = ref->next)
2829 : 1267429 : switch (ref->type)
2830 : : {
2831 : 976357 : case REF_ARRAY:
2832 : :
2833 : 976357 : switch (ref->u.ar.type)
2834 : : {
2835 : : case AR_FULL:
2836 : 1267429 : dimension = 1;
2837 : : break;
2838 : :
2839 : 97352 : case AR_SECTION:
2840 : 97352 : allocatable = pointer = 0;
2841 : 97352 : dimension = 1;
2842 : 97352 : optional = false;
2843 : 97352 : break;
2844 : :
2845 : 292529 : case AR_ELEMENT:
2846 : : /* Handle coarrays. */
2847 : 292529 : if (ref->u.ar.dimen > 0)
2848 : 1267429 : allocatable = pointer = optional = false;
2849 : : break;
2850 : :
2851 : : case AR_UNKNOWN:
2852 : : /* For standard conforming code, AR_UNKNOWN should not happen.
2853 : : For nonconforming code, gfortran can end up here. Treat it
2854 : : as a no-op. */
2855 : : break;
2856 : : }
2857 : :
2858 : : break;
2859 : :
2860 : 276609 : case REF_COMPONENT:
2861 : 276609 : optional = false;
2862 : 276609 : comp = ref->u.c.component;
2863 : 276609 : attr = comp->attr;
2864 : 276609 : if (ts != NULL && !has_inquiry_part)
2865 : : {
2866 : 71019 : *ts = comp->ts;
2867 : : /* Don't set the string length if a substring reference
2868 : : follows. */
2869 : 71019 : if (ts->type == BT_CHARACTER
2870 : 8248 : && ref->next && ref->next->type == REF_SUBSTRING)
2871 : 208 : ts->u.cl = NULL;
2872 : : }
2873 : :
2874 : 276609 : if (comp->ts.type == BT_CLASS)
2875 : : {
2876 : 18539 : codimension = CLASS_DATA (comp)->attr.codimension;
2877 : 18539 : pointer = CLASS_DATA (comp)->attr.class_pointer;
2878 : 18539 : allocatable = CLASS_DATA (comp)->attr.allocatable;
2879 : : }
2880 : : else
2881 : : {
2882 : 258070 : codimension = comp->attr.codimension;
2883 : 258070 : if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0)
2884 : 11977 : pointer = comp->attr.class_pointer;
2885 : : else
2886 : 246093 : pointer = comp->attr.pointer;
2887 : 258070 : allocatable = comp->attr.allocatable;
2888 : : }
2889 : 276609 : if (pointer || attr.proc_pointer)
2890 : 47845 : target = 1;
2891 : :
2892 : : break;
2893 : :
2894 : 14463 : case REF_INQUIRY:
2895 : 14463 : case REF_SUBSTRING:
2896 : 14463 : allocatable = pointer = optional = false;
2897 : 14463 : break;
2898 : : }
2899 : :
2900 : 3176549 : attr.dimension = dimension;
2901 : 3176549 : attr.codimension = codimension;
2902 : 3176549 : attr.pointer = pointer;
2903 : 3176549 : attr.allocatable = allocatable;
2904 : 3176549 : attr.target = target;
2905 : 3176549 : attr.save = sym->attr.save;
2906 : 3176549 : attr.optional = optional;
2907 : :
2908 : 3176549 : return attr;
2909 : : }
2910 : :
2911 : :
2912 : : /* Return the attribute from a general expression. */
2913 : :
2914 : : symbol_attribute
2915 : 2835880 : gfc_expr_attr (gfc_expr *e)
2916 : : {
2917 : 2835880 : symbol_attribute attr;
2918 : :
2919 : 2835880 : switch (e->expr_type)
2920 : : {
2921 : 2193663 : case EXPR_VARIABLE:
2922 : 2193663 : attr = gfc_variable_attr (e, NULL);
2923 : 2193663 : break;
2924 : :
2925 : 35096 : case EXPR_FUNCTION:
2926 : 35096 : gfc_clear_attr (&attr);
2927 : :
2928 : 35096 : if (e->value.function.esym && e->value.function.esym->result)
2929 : : {
2930 : 13558 : gfc_symbol *sym = e->value.function.esym->result;
2931 : 13558 : attr = sym->attr;
2932 : 13558 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2933 : : {
2934 : 1299 : attr.dimension = CLASS_DATA (sym)->attr.dimension;
2935 : 1299 : attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
2936 : 1299 : attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
2937 : : }
2938 : : }
2939 : 21538 : else if (e->value.function.isym
2940 : 20575 : && e->value.function.isym->transformational
2941 : 10324 : && e->ts.type == BT_CLASS)
2942 : 24 : attr = CLASS_DATA (e)->attr;
2943 : 21514 : else if (e->symtree)
2944 : 21514 : attr = gfc_variable_attr (e, NULL);
2945 : :
2946 : : /* TODO: NULL() returns pointers. May have to take care of this
2947 : : here. */
2948 : :
2949 : : break;
2950 : :
2951 : 607121 : default:
2952 : 607121 : gfc_clear_attr (&attr);
2953 : 607121 : break;
2954 : : }
2955 : :
2956 : 2835880 : return attr;
2957 : : }
2958 : :
2959 : :
2960 : : /* Given an expression, figure out what the ultimate expression
2961 : : attribute is. This routine is similar to gfc_variable_attr with
2962 : : parts of gfc_expr_attr, but focuses more on the needs of
2963 : : coarrays. For coarrays a codimension attribute is kind of
2964 : : "infectious" being propagated once set and never cleared.
2965 : : The coarray_comp is only set, when the expression refs a coarray
2966 : : component. REFS_COMP is set when present to true only, when this EXPR
2967 : : refs a (non-_data) component. To check whether EXPR refs an allocatable
2968 : : component in a derived type coarray *refs_comp needs to be set and
2969 : : coarray_comp has to false. */
2970 : :
2971 : : static symbol_attribute
2972 : 8243 : caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
2973 : : {
2974 : 8243 : int dimension, codimension, pointer, allocatable, target, coarray_comp;
2975 : 8243 : symbol_attribute attr;
2976 : 8243 : gfc_ref *ref;
2977 : 8243 : gfc_symbol *sym;
2978 : 8243 : gfc_component *comp;
2979 : :
2980 : 8243 : if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
2981 : 0 : gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
2982 : :
2983 : 8243 : sym = expr->symtree->n.sym;
2984 : 8243 : gfc_clear_attr (&attr);
2985 : :
2986 : 8243 : if (refs_comp)
2987 : 3874 : *refs_comp = false;
2988 : :
2989 : 8243 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
2990 : : {
2991 : 338 : dimension = CLASS_DATA (sym)->attr.dimension;
2992 : 338 : codimension = CLASS_DATA (sym)->attr.codimension;
2993 : 338 : pointer = CLASS_DATA (sym)->attr.class_pointer;
2994 : 338 : allocatable = CLASS_DATA (sym)->attr.allocatable;
2995 : 338 : attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
2996 : 338 : attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
2997 : : }
2998 : : else
2999 : : {
3000 : 7905 : dimension = sym->attr.dimension;
3001 : 7905 : codimension = sym->attr.codimension;
3002 : 7905 : pointer = sym->attr.pointer;
3003 : 7905 : allocatable = sym->attr.allocatable;
3004 : 15810 : attr.alloc_comp = sym->ts.type == BT_DERIVED
3005 : 7905 : ? sym->ts.u.derived->attr.alloc_comp : 0;
3006 : 7905 : attr.pointer_comp = sym->ts.type == BT_DERIVED
3007 : 7905 : ? sym->ts.u.derived->attr.pointer_comp : 0;
3008 : : }
3009 : :
3010 : 8243 : target = coarray_comp = 0;
3011 : 8243 : if (pointer || attr.proc_pointer)
3012 : 242 : target = 1;
3013 : :
3014 : 17180 : for (ref = expr->ref; ref; ref = ref->next)
3015 : 8937 : switch (ref->type)
3016 : : {
3017 : 5614 : case REF_ARRAY:
3018 : :
3019 : 5614 : switch (ref->u.ar.type)
3020 : : {
3021 : : case AR_FULL:
3022 : : case AR_SECTION:
3023 : : dimension = 1;
3024 : 5614 : break;
3025 : :
3026 : 3655 : case AR_ELEMENT:
3027 : : /* Handle coarrays. */
3028 : 3655 : if (ref->u.ar.dimen > 0 && !in_allocate)
3029 : 5614 : allocatable = pointer = 0;
3030 : : break;
3031 : :
3032 : 0 : case AR_UNKNOWN:
3033 : : /* If any of start, end or stride is not integer, there will
3034 : : already have been an error issued. */
3035 : 0 : int errors;
3036 : 0 : gfc_get_errors (NULL, &errors);
3037 : 0 : if (errors == 0)
3038 : 0 : gfc_internal_error ("gfc_caf_attr(): Bad array reference");
3039 : : }
3040 : :
3041 : : break;
3042 : :
3043 : 3323 : case REF_COMPONENT:
3044 : 3323 : comp = ref->u.c.component;
3045 : :
3046 : 3323 : if (comp->ts.type == BT_CLASS)
3047 : : {
3048 : : /* Set coarray_comp only, when this component introduces the
3049 : : coarray. */
3050 : 13 : coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
3051 : 13 : codimension |= CLASS_DATA (comp)->attr.codimension;
3052 : 13 : pointer = CLASS_DATA (comp)->attr.class_pointer;
3053 : 13 : allocatable = CLASS_DATA (comp)->attr.allocatable;
3054 : : }
3055 : : else
3056 : : {
3057 : : /* Set coarray_comp only, when this component introduces the
3058 : : coarray. */
3059 : 3310 : coarray_comp = !codimension && comp->attr.codimension;
3060 : 3310 : codimension |= comp->attr.codimension;
3061 : 3310 : pointer = comp->attr.pointer;
3062 : 3310 : allocatable = comp->attr.allocatable;
3063 : : }
3064 : :
3065 : 3323 : if (refs_comp && strcmp (comp->name, "_data") != 0
3066 : 1246 : && (ref->next == NULL
3067 : 839 : || (ref->next->type == REF_ARRAY && ref->next->next == NULL)))
3068 : 924 : *refs_comp = true;
3069 : :
3070 : 3323 : if (pointer || attr.proc_pointer)
3071 : 678 : target = 1;
3072 : :
3073 : : break;
3074 : :
3075 : : case REF_SUBSTRING:
3076 : : case REF_INQUIRY:
3077 : 8937 : allocatable = pointer = 0;
3078 : : break;
3079 : : }
3080 : :
3081 : 8243 : attr.dimension = dimension;
3082 : 8243 : attr.codimension = codimension;
3083 : 8243 : attr.pointer = pointer;
3084 : 8243 : attr.allocatable = allocatable;
3085 : 8243 : attr.target = target;
3086 : 8243 : attr.save = sym->attr.save;
3087 : 8243 : attr.coarray_comp = coarray_comp;
3088 : :
3089 : 8243 : return attr;
3090 : : }
3091 : :
3092 : :
3093 : : symbol_attribute
3094 : 10106 : gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
3095 : : {
3096 : 10106 : symbol_attribute attr;
3097 : :
3098 : 10106 : switch (e->expr_type)
3099 : : {
3100 : 7992 : case EXPR_VARIABLE:
3101 : 7992 : attr = caf_variable_attr (e, in_allocate, refs_comp);
3102 : 7992 : break;
3103 : :
3104 : 253 : case EXPR_FUNCTION:
3105 : 253 : gfc_clear_attr (&attr);
3106 : :
3107 : 253 : if (e->value.function.esym && e->value.function.esym->result)
3108 : : {
3109 : 2 : gfc_symbol *sym = e->value.function.esym->result;
3110 : 2 : attr = sym->attr;
3111 : 2 : if (sym->ts.type == BT_CLASS)
3112 : : {
3113 : 0 : attr.dimension = CLASS_DATA (sym)->attr.dimension;
3114 : 0 : attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
3115 : 0 : attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
3116 : 0 : attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
3117 : 0 : attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
3118 : 0 : ->attr.pointer_comp;
3119 : : }
3120 : : }
3121 : 251 : else if (e->symtree)
3122 : 251 : attr = caf_variable_attr (e, in_allocate, refs_comp);
3123 : : else
3124 : 0 : gfc_clear_attr (&attr);
3125 : : break;
3126 : :
3127 : 1861 : default:
3128 : 1861 : gfc_clear_attr (&attr);
3129 : 1861 : break;
3130 : : }
3131 : :
3132 : 10106 : return attr;
3133 : : }
3134 : :
3135 : :
3136 : : /* Match a structure constructor. The initial symbol has already been
3137 : : seen. */
3138 : :
3139 : : typedef struct gfc_structure_ctor_component
3140 : : {
3141 : : char* name;
3142 : : gfc_expr* val;
3143 : : locus where;
3144 : : struct gfc_structure_ctor_component* next;
3145 : : }
3146 : : gfc_structure_ctor_component;
3147 : :
3148 : : #define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
3149 : :
3150 : : static void
3151 : 8882 : gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
3152 : : {
3153 : 8882 : free (comp->name);
3154 : 8882 : gfc_free_expr (comp->val);
3155 : 8882 : free (comp);
3156 : 8882 : }
3157 : :
3158 : :
3159 : : /* Translate the component list into the actual constructor by sorting it in
3160 : : the order required; this also checks along the way that each and every
3161 : : component actually has an initializer and handles default initializers
3162 : : for components without explicit value given. */
3163 : : static bool
3164 : 6258 : build_actual_constructor (gfc_structure_ctor_component **comp_head,
3165 : : gfc_constructor_base *ctor_head, gfc_symbol *sym)
3166 : : {
3167 : 6258 : gfc_structure_ctor_component *comp_iter;
3168 : 6258 : gfc_component *comp;
3169 : :
3170 : 16442 : for (comp = sym->components; comp; comp = comp->next)
3171 : : {
3172 : 10189 : gfc_structure_ctor_component **next_ptr;
3173 : 10189 : gfc_expr *value = NULL;
3174 : :
3175 : : /* Try to find the initializer for the current component by name. */
3176 : 10189 : next_ptr = comp_head;
3177 : 11321 : for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
3178 : : {
3179 : 9990 : if (!strcmp (comp_iter->name, comp->name))
3180 : : break;
3181 : 1132 : next_ptr = &comp_iter->next;
3182 : : }
3183 : :
3184 : : /* If an extension, try building the parent derived type by building
3185 : : a value expression for the parent derived type and calling self. */
3186 : 10189 : if (!comp_iter && comp == sym->components && sym->attr.extension)
3187 : : {
3188 : 103 : value = gfc_get_structure_constructor_expr (comp->ts.type,
3189 : : comp->ts.kind,
3190 : : &gfc_current_locus);
3191 : 103 : value->ts = comp->ts;
3192 : :
3193 : 103 : if (!build_actual_constructor (comp_head,
3194 : : &value->value.constructor,
3195 : : comp->ts.u.derived))
3196 : : {
3197 : 0 : gfc_free_expr (value);
3198 : 0 : return false;
3199 : : }
3200 : :
3201 : 103 : gfc_constructor_append_expr (ctor_head, value, NULL);
3202 : 103 : continue;
3203 : : }
3204 : :
3205 : : /* If it was not found, apply NULL expression to set the component as
3206 : : unallocated. Then try the default initializer if there's any;
3207 : : otherwise, it's an error unless this is a deferred parameter. */
3208 : 1228 : if (!comp_iter)
3209 : : {
3210 : : /* F2018 7.5.10: If an allocatable component has no corresponding
3211 : : component-data-source, then that component has an allocation
3212 : : status of unallocated.... */
3213 : 1228 : if (comp->attr.allocatable
3214 : 1127 : || (comp->ts.type == BT_CLASS
3215 : 8 : && CLASS_DATA (comp)->attr.allocatable))
3216 : : {
3217 : 103 : if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
3218 : : "allocatable component %qs given in the "
3219 : : "structure constructor at %C", comp->name))
3220 : : return false;
3221 : 103 : value = gfc_get_null_expr (&gfc_current_locus);
3222 : : }
3223 : : /* ....(Preceding sentence) If a component with default
3224 : : initialization has no corresponding component-data-source, then
3225 : : the default initialization is applied to that component. */
3226 : 1125 : else if (comp->initializer)
3227 : : {
3228 : 629 : if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
3229 : : "with missing optional arguments at %C"))
3230 : : return false;
3231 : 627 : value = gfc_copy_expr (comp->initializer);
3232 : : }
3233 : : /* Do not trap components such as the string length for deferred
3234 : : length character components. */
3235 : 496 : else if (!comp->attr.artificial)
3236 : : {
3237 : 3 : gfc_error ("No initializer for component %qs given in the"
3238 : : " structure constructor at %C", comp->name);
3239 : 3 : return false;
3240 : : }
3241 : : }
3242 : : else
3243 : 8858 : value = comp_iter->val;
3244 : :
3245 : : /* Add the value to the constructor chain built. */
3246 : 10081 : gfc_constructor_append_expr (ctor_head, value, NULL);
3247 : :
3248 : : /* Remove the entry from the component list. We don't want the expression
3249 : : value to be free'd, so set it to NULL. */
3250 : 10081 : if (comp_iter)
3251 : : {
3252 : 8858 : *next_ptr = comp_iter->next;
3253 : 8858 : comp_iter->val = NULL;
3254 : 8858 : gfc_free_structure_ctor_component (comp_iter);
3255 : : }
3256 : : }
3257 : : return true;
3258 : : }
3259 : :
3260 : :
3261 : : bool
3262 : 6170 : gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
3263 : : gfc_actual_arglist **arglist,
3264 : : bool parent)
3265 : : {
3266 : 6170 : gfc_actual_arglist *actual;
3267 : 6170 : gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
3268 : 6170 : gfc_constructor_base ctor_head = NULL;
3269 : 6170 : gfc_component *comp; /* Is set NULL when named component is first seen */
3270 : 6170 : const char* last_name = NULL;
3271 : 6170 : locus old_locus;
3272 : 6170 : gfc_expr *expr;
3273 : :
3274 : 6170 : expr = parent ? *cexpr : e;
3275 : 6170 : old_locus = gfc_current_locus;
3276 : 6170 : if (parent)
3277 : : ; /* gfc_current_locus = *arglist->expr ? ->where;*/
3278 : : else
3279 : 5534 : gfc_current_locus = expr->where;
3280 : :
3281 : 6170 : comp_tail = comp_head = NULL;
3282 : :
3283 : 6170 : if (!parent && sym->attr.abstract)
3284 : : {
3285 : 1 : gfc_error ("Cannot construct ABSTRACT type %qs at %L",
3286 : : sym->name, &expr->where);
3287 : 1 : goto cleanup;
3288 : : }
3289 : :
3290 : 6169 : comp = sym->components;
3291 : 6169 : actual = parent ? *arglist : expr->value.function.actual;
3292 : 14528 : for ( ; actual; )
3293 : : {
3294 : 8882 : gfc_component *this_comp = NULL;
3295 : :
3296 : 8882 : if (!comp_head)
3297 : 5790 : comp_tail = comp_head = gfc_get_structure_ctor_component ();
3298 : : else
3299 : : {
3300 : 3092 : comp_tail->next = gfc_get_structure_ctor_component ();
3301 : 3092 : comp_tail = comp_tail->next;
3302 : : }
3303 : 8882 : if (actual->name)
3304 : : {
3305 : 835 : if (!gfc_notify_std (GFC_STD_F2003, "Structure"
3306 : : " constructor with named arguments at %C"))
3307 : 1 : goto cleanup;
3308 : :
3309 : 834 : comp_tail->name = xstrdup (actual->name);
3310 : 834 : last_name = comp_tail->name;
3311 : 834 : comp = NULL;
3312 : : }
3313 : : else
3314 : : {
3315 : : /* Components without name are not allowed after the first named
3316 : : component initializer! */
3317 : 8047 : if (!comp || comp->attr.artificial)
3318 : : {
3319 : 2 : if (last_name)
3320 : 0 : gfc_error ("Component initializer without name after component"
3321 : : " named %s at %L", last_name,
3322 : 0 : actual->expr ? &actual->expr->where
3323 : : : &gfc_current_locus);
3324 : : else
3325 : 2 : gfc_error ("Too many components in structure constructor at "
3326 : 2 : "%L", actual->expr ? &actual->expr->where
3327 : : : &gfc_current_locus);
3328 : 2 : goto cleanup;
3329 : : }
3330 : :
3331 : 8045 : comp_tail->name = xstrdup (comp->name);
3332 : : }
3333 : :
3334 : : /* Find the current component in the structure definition and check
3335 : : its access is not private. */
3336 : 8879 : if (comp)
3337 : 8045 : this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
3338 : : else
3339 : : {
3340 : 834 : this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
3341 : : false, false, NULL);
3342 : 834 : comp = NULL; /* Reset needed! */
3343 : : }
3344 : :
3345 : : /* Here we can check if a component name is given which does not
3346 : : correspond to any component of the defined structure. */
3347 : 8879 : if (!this_comp)
3348 : 8 : goto cleanup;
3349 : :
3350 : : /* For a constant string constructor, make sure the length is
3351 : : correct; truncate or fill with blanks if needed. */
3352 : 8871 : if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
3353 : 956 : && this_comp->ts.u.cl && this_comp->ts.u.cl->length
3354 : 954 : && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
3355 : 942 : && this_comp->ts.u.cl->length->ts.type == BT_INTEGER
3356 : 941 : && actual->expr->ts.type == BT_CHARACTER
3357 : 929 : && actual->expr->expr_type == EXPR_CONSTANT)
3358 : : {
3359 : 707 : ptrdiff_t c, e1;
3360 : 707 : c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer);
3361 : 707 : e1 = actual->expr->value.character.length;
3362 : :
3363 : 707 : if (c != e1)
3364 : : {
3365 : 230 : ptrdiff_t i, to;
3366 : 230 : gfc_char_t *dest;
3367 : 230 : dest = gfc_get_wide_string (c + 1);
3368 : :
3369 : 230 : to = e1 < c ? e1 : c;
3370 : 4373 : for (i = 0; i < to; i++)
3371 : 4143 : dest[i] = actual->expr->value.character.string[i];
3372 : :
3373 : 5763 : for (i = e1; i < c; i++)
3374 : 5533 : dest[i] = ' ';
3375 : :
3376 : 230 : dest[c] = '\0';
3377 : 230 : free (actual->expr->value.character.string);
3378 : :
3379 : 230 : actual->expr->value.character.length = c;
3380 : 230 : actual->expr->value.character.string = dest;
3381 : :
3382 : 230 : if (warn_line_truncation && c < e1)
3383 : 14 : gfc_warning_now (OPT_Wcharacter_truncation,
3384 : : "CHARACTER expression will be truncated "
3385 : : "in constructor (%td/%td) at %L", c,
3386 : : e1, &actual->expr->where);
3387 : : }
3388 : : }
3389 : :
3390 : 8871 : comp_tail->val = actual->expr;
3391 : 8871 : if (actual->expr != NULL)
3392 : 8871 : comp_tail->where = actual->expr->where;
3393 : 8871 : actual->expr = NULL;
3394 : :
3395 : : /* Check if this component is already given a value. */
3396 : 14287 : for (comp_iter = comp_head; comp_iter != comp_tail;
3397 : 5416 : comp_iter = comp_iter->next)
3398 : : {
3399 : 5417 : gcc_assert (comp_iter);
3400 : 5417 : if (!strcmp (comp_iter->name, comp_tail->name))
3401 : : {
3402 : 1 : gfc_error ("Component %qs is initialized twice in the structure"
3403 : : " constructor at %L", comp_tail->name,
3404 : : comp_tail->val ? &comp_tail->where
3405 : : : &gfc_current_locus);
3406 : 1 : goto cleanup;
3407 : : }
3408 : : }
3409 : :
3410 : : /* F2008, R457/C725, for PURE C1283. */
3411 : 77 : if (this_comp->attr.pointer && comp_tail->val
3412 : 8947 : && gfc_is_coindexed (comp_tail->val))
3413 : : {
3414 : 2 : gfc_error ("Coindexed expression to pointer component %qs in "
3415 : : "structure constructor at %L", comp_tail->name,
3416 : : &comp_tail->where);
3417 : 2 : goto cleanup;
3418 : : }
3419 : :
3420 : : /* If not explicitly a parent constructor, gather up the components
3421 : : and build one. */
3422 : 8868 : if (comp && comp == sym->components
3423 : 5595 : && sym->attr.extension
3424 : 660 : && comp_tail->val
3425 : 660 : && (!gfc_bt_struct (comp_tail->val->ts.type)
3426 : 54 : ||
3427 : 54 : comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
3428 : : {
3429 : 636 : bool m;
3430 : 636 : gfc_actual_arglist *arg_null = NULL;
3431 : :
3432 : 636 : actual->expr = comp_tail->val;
3433 : 636 : comp_tail->val = NULL;
3434 : :
3435 : 636 : m = gfc_convert_to_structure_constructor (NULL,
3436 : : comp->ts.u.derived, &comp_tail->val,
3437 : 636 : comp->ts.u.derived->attr.zero_comp
3438 : : ? &arg_null : &actual, true);
3439 : 636 : if (!m)
3440 : 0 : goto cleanup;
3441 : :
3442 : 636 : if (comp->ts.u.derived->attr.zero_comp)
3443 : : {
3444 : 126 : comp = comp->next;
3445 : 126 : continue;
3446 : : }
3447 : : }
3448 : :
3449 : 510 : if (comp)
3450 : 7911 : comp = comp->next;
3451 : 8742 : if (parent && !comp)
3452 : : break;
3453 : :
3454 : 8233 : if (actual)
3455 : 8232 : actual = actual->next;
3456 : : }
3457 : :
3458 : 6155 : if (!build_actual_constructor (&comp_head, &ctor_head, sym))
3459 : 5 : goto cleanup;
3460 : :
3461 : : /* No component should be left, as this should have caused an error in the
3462 : : loop constructing the component-list (name that does not correspond to any
3463 : : component in the structure definition). */
3464 : 6150 : if (comp_head && sym->attr.extension)
3465 : : {
3466 : 2 : for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
3467 : : {
3468 : 1 : gfc_error ("component %qs at %L has already been set by a "
3469 : : "parent derived type constructor", comp_iter->name,
3470 : : &comp_iter->where);
3471 : : }
3472 : 1 : goto cleanup;
3473 : : }
3474 : : else
3475 : 6149 : gcc_assert (!comp_head);
3476 : :
3477 : 6149 : if (parent)
3478 : : {
3479 : 636 : expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
3480 : 636 : expr->ts.u.derived = sym;
3481 : 636 : expr->value.constructor = ctor_head;
3482 : 636 : *cexpr = expr;
3483 : : }
3484 : : else
3485 : : {
3486 : 5513 : expr->ts.u.derived = sym;
3487 : 5513 : expr->ts.kind = 0;
3488 : 5513 : expr->ts.type = BT_DERIVED;
3489 : 5513 : expr->value.constructor = ctor_head;
3490 : 5513 : expr->expr_type = EXPR_STRUCTURE;
3491 : : }
3492 : :
3493 : 6149 : gfc_current_locus = old_locus;
3494 : 6149 : if (parent)
3495 : 636 : *arglist = actual;
3496 : : return true;
3497 : :
3498 : 21 : cleanup:
3499 : 21 : gfc_current_locus = old_locus;
3500 : :
3501 : 45 : for (comp_iter = comp_head; comp_iter; )
3502 : : {
3503 : 24 : gfc_structure_ctor_component *next = comp_iter->next;
3504 : 24 : gfc_free_structure_ctor_component (comp_iter);
3505 : 24 : comp_iter = next;
3506 : : }
3507 : 21 : gfc_constructor_free (ctor_head);
3508 : :
3509 : 21 : return false;
3510 : : }
3511 : :
3512 : :
3513 : : match
3514 : 57 : gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
3515 : : {
3516 : 57 : match m;
3517 : 57 : gfc_expr *e;
3518 : 57 : gfc_symtree *symtree;
3519 : 57 : bool t = true;
3520 : :
3521 : 57 : gfc_get_ha_sym_tree (sym->name, &symtree);
3522 : :
3523 : 57 : e = gfc_get_expr ();
3524 : 57 : e->symtree = symtree;
3525 : 57 : e->expr_type = EXPR_FUNCTION;
3526 : 57 : e->where = gfc_current_locus;
3527 : :
3528 : 57 : gcc_assert (gfc_fl_struct (sym->attr.flavor)
3529 : : && symtree->n.sym->attr.flavor == FL_PROCEDURE);
3530 : 57 : e->value.function.esym = sym;
3531 : 57 : e->symtree->n.sym->attr.generic = 1;
3532 : :
3533 : 57 : m = gfc_match_actual_arglist (0, &e->value.function.actual);
3534 : 57 : if (m != MATCH_YES)
3535 : : {
3536 : 0 : gfc_free_expr (e);
3537 : 0 : return m;
3538 : : }
3539 : :
3540 : 57 : if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
3541 : : {
3542 : 1 : gfc_free_expr (e);
3543 : 1 : return MATCH_ERROR;
3544 : : }
3545 : :
3546 : : /* If a structure constructor is in a DATA statement, then each entity
3547 : : in the structure constructor must be a constant. Try to reduce the
3548 : : expression here. */
3549 : 56 : if (gfc_in_match_data ())
3550 : 56 : t = gfc_reduce_init_expr (e);
3551 : :
3552 : 56 : if (t)
3553 : : {
3554 : 46 : *result = e;
3555 : 46 : return MATCH_YES;
3556 : : }
3557 : : else
3558 : : {
3559 : 10 : gfc_free_expr (e);
3560 : 10 : return MATCH_ERROR;
3561 : : }
3562 : : }
3563 : :
3564 : :
3565 : : /* If the symbol is an implicit do loop index and implicitly typed,
3566 : : it should not be host associated. Provide a symtree from the
3567 : : current namespace. */
3568 : : static match
3569 : 5556792 : check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
3570 : : {
3571 : 5556792 : if ((*sym)->attr.flavor == FL_VARIABLE
3572 : 1322508 : && (*sym)->ns != gfc_current_ns
3573 : : && (*sym)->attr.implied_index
3574 : : && (*sym)->attr.implicit_type
3575 : 48780 : && !(*sym)->attr.use_assoc)
3576 : : {
3577 : 32 : int i;
3578 : 32 : i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
3579 : 32 : if (i)
3580 : : return MATCH_ERROR;
3581 : 32 : *sym = (*st)->n.sym;
3582 : : }
3583 : : return MATCH_YES;
3584 : : }
3585 : :
3586 : :
3587 : : /* Procedure pointer as function result: Replace the function symbol by the
3588 : : auto-generated hidden result variable named "ppr@". */
3589 : :
3590 : : static bool
3591 : 4125738 : replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
3592 : : {
3593 : : /* Check for procedure pointer result variable. */
3594 : 4125738 : if ((*sym)->attr.function && !(*sym)->attr.external
3595 : 1216891 : && (*sym)->result && (*sym)->result != *sym
3596 : 9291 : && (*sym)->result->attr.proc_pointer
3597 : 323 : && (*sym) == gfc_current_ns->proc_name
3598 : 283 : && (*sym) == (*sym)->result->ns->proc_name
3599 : 283 : && strcmp ("ppr@", (*sym)->result->name) == 0)
3600 : : {
3601 : : /* Automatic replacement with "hidden" result variable. */
3602 : 283 : (*sym)->result->attr.referenced = (*sym)->attr.referenced;
3603 : 283 : *sym = (*sym)->result;
3604 : 283 : *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
3605 : 283 : return true;
3606 : : }
3607 : : return false;
3608 : : }
3609 : :
3610 : :
3611 : : /* Matches a variable name followed by anything that might follow it--
3612 : : array reference, argument list of a function, etc. */
3613 : :
3614 : : match
3615 : 3345767 : gfc_match_rvalue (gfc_expr **result)
3616 : : {
3617 : 3345767 : gfc_actual_arglist *actual_arglist;
3618 : 3345767 : char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
3619 : 3345767 : gfc_state_data *st;
3620 : 3345767 : gfc_symbol *sym;
3621 : 3345767 : gfc_symtree *symtree;
3622 : 3345767 : locus where, old_loc;
3623 : 3345767 : gfc_expr *e;
3624 : 3345767 : match m, m2;
3625 : 3345767 : int i;
3626 : 3345767 : gfc_typespec *ts;
3627 : 3345767 : bool implicit_char;
3628 : 3345767 : gfc_ref *ref;
3629 : :
3630 : 3345767 : m = gfc_match ("%%loc");
3631 : 3345767 : if (m == MATCH_YES)
3632 : : {
3633 : 10878 : if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
3634 : : return MATCH_ERROR;
3635 : 10877 : strncpy (name, "loc", 4);
3636 : : }
3637 : :
3638 : : else
3639 : : {
3640 : 3334889 : m = gfc_match_name (name);
3641 : 3334889 : if (m != MATCH_YES)
3642 : : return m;
3643 : : }
3644 : :
3645 : : /* Check if the symbol exists. */
3646 : 3175566 : if (gfc_find_sym_tree (name, NULL, 1, &symtree))
3647 : : return MATCH_ERROR;
3648 : :
3649 : : /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
3650 : : type. For derived types we create a generic symbol which links to the
3651 : : derived type symbol; STRUCTUREs are simpler and must not conflict with
3652 : : variables. */
3653 : 3175564 : if (!symtree)
3654 : 151117 : if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
3655 : : return MATCH_ERROR;
3656 : 3175564 : if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
3657 : : {
3658 : 3175564 : if (gfc_find_state (COMP_INTERFACE)
3659 : 3175564 : && !gfc_current_ns->has_import_set)
3660 : 73472 : i = gfc_get_sym_tree (name, NULL, &symtree, false);
3661 : : else
3662 : 3102092 : i = gfc_get_ha_sym_tree (name, &symtree);
3663 : 3175564 : if (i)
3664 : : return MATCH_ERROR;
3665 : : }
3666 : :
3667 : :
3668 : 3175564 : sym = symtree->n.sym;
3669 : 3175564 : e = NULL;
3670 : 3175564 : where = gfc_current_locus;
3671 : :
3672 : 3175564 : replace_hidden_procptr_result (&sym, &symtree);
3673 : :
3674 : : /* If this is an implicit do loop index and implicitly typed,
3675 : : it should not be host associated. */
3676 : 3175564 : m = check_for_implicit_index (&symtree, &sym);
3677 : 3175564 : if (m != MATCH_YES)
3678 : : return m;
3679 : :
3680 : 3175564 : gfc_set_sym_referenced (sym);
3681 : 3175564 : sym->attr.implied_index = 0;
3682 : :
3683 : 3175564 : if (sym->attr.function && sym->result == sym)
3684 : : {
3685 : : /* See if this is a directly recursive function call. */
3686 : 612352 : gfc_gobble_whitespace ();
3687 : 612352 : if (sym->attr.recursive
3688 : 100 : && gfc_peek_ascii_char () == '('
3689 : 93 : && gfc_current_ns->proc_name == sym
3690 : 612359 : && !sym->attr.dimension)
3691 : : {
3692 : 4 : gfc_error ("%qs at %C is the name of a recursive function "
3693 : : "and so refers to the result variable. Use an "
3694 : : "explicit RESULT variable for direct recursion "
3695 : : "(12.5.2.1)", sym->name);
3696 : 4 : return MATCH_ERROR;
3697 : : }
3698 : :
3699 : 612348 : if (gfc_is_function_return_value (sym, gfc_current_ns))
3700 : 1579 : goto variable;
3701 : :
3702 : 610769 : if (sym->attr.entry
3703 : 187 : && (sym->ns == gfc_current_ns
3704 : 27 : || sym->ns == gfc_current_ns->parent))
3705 : : {
3706 : 180 : gfc_entry_list *el = NULL;
3707 : :
3708 : 180 : for (el = sym->ns->entries; el; el = el->next)
3709 : 180 : if (sym == el->sym)
3710 : 180 : goto variable;
3711 : : }
3712 : : }
3713 : :
3714 : 3173801 : if (gfc_matching_procptr_assignment)
3715 : : {
3716 : : /* It can be a procedure or a derived-type procedure or a not-yet-known
3717 : : type. */
3718 : 1286 : if (sym->attr.flavor != FL_UNKNOWN
3719 : 964 : && sym->attr.flavor != FL_PROCEDURE
3720 : : && sym->attr.flavor != FL_PARAMETER
3721 : : && sym->attr.flavor != FL_VARIABLE)
3722 : : {
3723 : 2 : gfc_error ("Symbol at %C is not appropriate for an expression");
3724 : 2 : return MATCH_ERROR;
3725 : : }
3726 : 1284 : goto procptr0;
3727 : : }
3728 : :
3729 : 3172515 : if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
3730 : 623561 : goto function0;
3731 : :
3732 : 2548954 : if (sym->attr.generic)
3733 : 67525 : goto generic_function;
3734 : :
3735 : 2481429 : switch (sym->attr.flavor)
3736 : : {
3737 : 1164708 : case FL_VARIABLE:
3738 : 1164708 : variable:
3739 : 1164708 : e = gfc_get_expr ();
3740 : :
3741 : 1164708 : e->expr_type = EXPR_VARIABLE;
3742 : 1164708 : e->symtree = symtree;
3743 : :
3744 : 1164708 : m = gfc_match_varspec (e, 0, false, true);
3745 : 1164708 : break;
3746 : :
3747 : 189144 : case FL_PARAMETER:
3748 : : /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
3749 : : end up here. Unfortunately, sym->value->expr_type is set to
3750 : : EXPR_CONSTANT, and so the if () branch would be followed without
3751 : : the !sym->as check. */
3752 : 189144 : if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
3753 : 163932 : e = gfc_copy_expr (sym->value);
3754 : : else
3755 : : {
3756 : 25212 : e = gfc_get_expr ();
3757 : 25212 : e->expr_type = EXPR_VARIABLE;
3758 : : }
3759 : :
3760 : 189144 : e->symtree = symtree;
3761 : 189144 : m = gfc_match_varspec (e, 0, false, true);
3762 : :
3763 : 189144 : if (sym->ts.is_c_interop || sym->ts.is_iso_c)
3764 : : break;
3765 : :
3766 : : /* Variable array references to derived type parameters cause
3767 : : all sorts of headaches in simplification. Treating such
3768 : : expressions as variable works just fine for all array
3769 : : references. */
3770 : 146808 : if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
3771 : : {
3772 : 2477 : for (ref = e->ref; ref; ref = ref->next)
3773 : 2291 : if (ref->type == REF_ARRAY)
3774 : : break;
3775 : :
3776 : 2258 : if (ref == NULL || ref->u.ar.type == AR_FULL)
3777 : : break;
3778 : :
3779 : 851 : ref = e->ref;
3780 : 851 : e->ref = NULL;
3781 : 851 : gfc_free_expr (e);
3782 : 851 : e = gfc_get_expr ();
3783 : 851 : e->expr_type = EXPR_VARIABLE;
3784 : 851 : e->symtree = symtree;
3785 : 851 : e->ref = ref;
3786 : : }
3787 : :
3788 : : break;
3789 : :
3790 : 0 : case FL_STRUCT:
3791 : 0 : case FL_DERIVED:
3792 : 0 : sym = gfc_use_derived (sym);
3793 : 0 : if (sym == NULL)
3794 : : m = MATCH_ERROR;
3795 : : else
3796 : 0 : goto generic_function;
3797 : : break;
3798 : :
3799 : : /* If we're here, then the name is known to be the name of a
3800 : : procedure, yet it is not sure to be the name of a function. */
3801 : 879416 : case FL_PROCEDURE:
3802 : :
3803 : : /* Procedure Pointer Assignments. */
3804 : 879416 : procptr0:
3805 : 879416 : if (gfc_matching_procptr_assignment)
3806 : : {
3807 : 1284 : gfc_gobble_whitespace ();
3808 : 1284 : if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
3809 : : /* Parse functions returning a procptr. */
3810 : 197 : goto function0;
3811 : :
3812 : 1087 : e = gfc_get_expr ();
3813 : 1087 : e->expr_type = EXPR_VARIABLE;
3814 : 1087 : e->symtree = symtree;
3815 : 1087 : m = gfc_match_varspec (e, 0, false, true);
3816 : 1020 : if (!e->ref && sym->attr.flavor == FL_UNKNOWN
3817 : 182 : && sym->ts.type == BT_UNKNOWN
3818 : 1259 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
3819 : : {
3820 : : m = MATCH_ERROR;
3821 : : break;
3822 : : }
3823 : : break;
3824 : : }
3825 : :
3826 : 878132 : if (sym->attr.subroutine)
3827 : : {
3828 : 57 : gfc_error ("Unexpected use of subroutine name %qs at %C",
3829 : : sym->name);
3830 : 57 : m = MATCH_ERROR;
3831 : 57 : break;
3832 : : }
3833 : :
3834 : : /* At this point, the name has to be a non-statement function.
3835 : : If the name is the same as the current function being
3836 : : compiled, then we have a variable reference (to the function
3837 : : result) if the name is non-recursive. */
3838 : :
3839 : 878075 : st = gfc_enclosing_unit (NULL);
3840 : :
3841 : 878075 : if (st != NULL
3842 : 836835 : && st->state == COMP_FUNCTION
3843 : 74464 : && st->sym == sym
3844 : 0 : && !sym->attr.recursive)
3845 : : {
3846 : 0 : e = gfc_get_expr ();
3847 : 0 : e->symtree = symtree;
3848 : 0 : e->expr_type = EXPR_VARIABLE;
3849 : :
3850 : 0 : m = gfc_match_varspec (e, 0, false, true);
3851 : 0 : break;
3852 : : }
3853 : :
3854 : : /* Match a function reference. */
3855 : 878075 : function0:
3856 : 1501833 : m = gfc_match_actual_arglist (0, &actual_arglist);
3857 : 1501833 : if (m == MATCH_NO)
3858 : : {
3859 : 525378 : if (sym->attr.proc == PROC_ST_FUNCTION)
3860 : 1 : gfc_error ("Statement function %qs requires argument list at %C",
3861 : : sym->name);
3862 : : else
3863 : 525377 : gfc_error ("Function %qs requires an argument list at %C",
3864 : : sym->name);
3865 : :
3866 : : m = MATCH_ERROR;
3867 : : break;
3868 : : }
3869 : :
3870 : 976455 : if (m != MATCH_YES)
3871 : : {
3872 : : m = MATCH_ERROR;
3873 : : break;
3874 : : }
3875 : :
3876 : 948001 : gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
3877 : 948001 : sym = symtree->n.sym;
3878 : :
3879 : 948001 : replace_hidden_procptr_result (&sym, &symtree);
3880 : :
3881 : 948001 : e = gfc_get_expr ();
3882 : 948001 : e->symtree = symtree;
3883 : 948001 : e->expr_type = EXPR_FUNCTION;
3884 : 948001 : e->value.function.actual = actual_arglist;
3885 : 948001 : e->where = gfc_current_locus;
3886 : :
3887 : 948001 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3888 : 192 : && CLASS_DATA (sym)->as)
3889 : 77 : e->rank = CLASS_DATA (sym)->as->rank;
3890 : 947924 : else if (sym->as != NULL)
3891 : 1023 : e->rank = sym->as->rank;
3892 : :
3893 : 948001 : if (!sym->attr.function
3894 : 948001 : && !gfc_add_function (&sym->attr, sym->name, NULL))
3895 : : {
3896 : : m = MATCH_ERROR;
3897 : : break;
3898 : : }
3899 : :
3900 : : /* Check here for the existence of at least one argument for the
3901 : : iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
3902 : : argument(s) given will be checked in gfc_iso_c_func_interface,
3903 : : during resolution of the function call. */
3904 : 948001 : if (sym->attr.is_iso_c == 1
3905 : 2 : && (sym->from_intmod == INTMOD_ISO_C_BINDING
3906 : 2 : && (sym->intmod_sym_id == ISOCBINDING_LOC
3907 : : || sym->intmod_sym_id == ISOCBINDING_FUNLOC
3908 : 2 : || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
3909 : : {
3910 : : /* make sure we were given a param */
3911 : 0 : if (actual_arglist == NULL)
3912 : : {
3913 : 0 : gfc_error ("Missing argument to %qs at %C", sym->name);
3914 : 0 : m = MATCH_ERROR;
3915 : 0 : break;
3916 : : }
3917 : : }
3918 : :
3919 : 948001 : if (sym->result == NULL)
3920 : 331540 : sym->result = sym;
3921 : :
3922 : 948001 : gfc_gobble_whitespace ();
3923 : : /* F08:C612. */
3924 : 948001 : if (gfc_peek_ascii_char() == '%')
3925 : : {
3926 : 12 : gfc_error ("The leftmost part-ref in a data-ref cannot be a "
3927 : : "function reference at %C");
3928 : 12 : m = MATCH_ERROR;
3929 : 12 : break;
3930 : : }
3931 : :
3932 : : m = MATCH_YES;
3933 : : break;
3934 : :
3935 : 249704 : case FL_UNKNOWN:
3936 : :
3937 : : /* Special case for derived type variables that get their types
3938 : : via an IMPLICIT statement. This can't wait for the
3939 : : resolution phase. */
3940 : :
3941 : 249704 : old_loc = gfc_current_locus;
3942 : 249704 : if (gfc_match_member_sep (sym) == MATCH_YES
3943 : 8923 : && sym->ts.type == BT_UNKNOWN
3944 : 249708 : && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
3945 : 0 : gfc_set_default_type (sym, 0, sym->ns);
3946 : 249704 : gfc_current_locus = old_loc;
3947 : :
3948 : : /* If the symbol has a (co)dimension attribute, the expression is a
3949 : : variable. */
3950 : :
3951 : 249704 : if (sym->attr.dimension || sym->attr.codimension)
3952 : : {
3953 : 32089 : if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3954 : : {
3955 : : m = MATCH_ERROR;
3956 : : break;
3957 : : }
3958 : :
3959 : 32089 : e = gfc_get_expr ();
3960 : 32089 : e->symtree = symtree;
3961 : 32089 : e->expr_type = EXPR_VARIABLE;
3962 : 32089 : m = gfc_match_varspec (e, 0, false, true);
3963 : 32089 : break;
3964 : : }
3965 : :
3966 : 217615 : if (sym->ts.type == BT_CLASS && sym->attr.class_ok
3967 : 4150 : && (CLASS_DATA (sym)->attr.dimension
3968 : 4150 : || CLASS_DATA (sym)->attr.codimension))
3969 : : {
3970 : 1312 : if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3971 : : {
3972 : : m = MATCH_ERROR;
3973 : : break;
3974 : : }
3975 : :
3976 : 1312 : e = gfc_get_expr ();
3977 : 1312 : e->symtree = symtree;
3978 : 1312 : e->expr_type = EXPR_VARIABLE;
3979 : 1312 : m = gfc_match_varspec (e, 0, false, true);
3980 : 1312 : break;
3981 : : }
3982 : :
3983 : : /* Name is not an array, so we peek to see if a '(' implies a
3984 : : function call or a substring reference. Otherwise the
3985 : : variable is just a scalar. */
3986 : :
3987 : 216303 : gfc_gobble_whitespace ();
3988 : 216303 : if (gfc_peek_ascii_char () != '(')
3989 : : {
3990 : : /* Assume a scalar variable */
3991 : 68879 : e = gfc_get_expr ();
3992 : 68879 : e->symtree = symtree;
3993 : 68879 : e->expr_type = EXPR_VARIABLE;
3994 : :
3995 : 68879 : if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
3996 : : {
3997 : : m = MATCH_ERROR;
3998 : : break;
3999 : : }
4000 : :
4001 : : /*FIXME:??? gfc_match_varspec does set this for us: */
4002 : 68879 : e->ts = sym->ts;
4003 : 68879 : m = gfc_match_varspec (e, 0, false, true);
4004 : 68879 : break;
4005 : : }
4006 : :
4007 : : /* See if this is a function reference with a keyword argument
4008 : : as first argument. We do this because otherwise a spurious
4009 : : symbol would end up in the symbol table. */
4010 : :
4011 : 147424 : old_loc = gfc_current_locus;
4012 : 147424 : m2 = gfc_match (" ( %n =", argname);
4013 : 147424 : gfc_current_locus = old_loc;
4014 : :
4015 : 147424 : e = gfc_get_expr ();
4016 : 147424 : e->symtree = symtree;
4017 : :
4018 : 147424 : if (m2 != MATCH_YES)
4019 : : {
4020 : : /* Try to figure out whether we're dealing with a character type.
4021 : : We're peeking ahead here, because we don't want to call
4022 : : match_substring if we're dealing with an implicitly typed
4023 : : non-character variable. */
4024 : 146397 : implicit_char = false;
4025 : 146397 : if (sym->ts.type == BT_UNKNOWN)
4026 : : {
4027 : 141691 : ts = gfc_get_default_type (sym->name, NULL);
4028 : 141691 : if (ts->type == BT_CHARACTER)
4029 : : implicit_char = true;
4030 : : }
4031 : :
4032 : : /* See if this could possibly be a substring reference of a name
4033 : : that we're not sure is a variable yet. */
4034 : :
4035 : 146380 : if ((implicit_char || sym->ts.type == BT_CHARACTER)
4036 : 1330 : && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
4037 : : {
4038 : :
4039 : 866 : e->expr_type = EXPR_VARIABLE;
4040 : :
4041 : 866 : if (sym->attr.flavor != FL_VARIABLE
4042 : 866 : && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
4043 : : sym->name, NULL))
4044 : : {
4045 : : m = MATCH_ERROR;
4046 : : break;
4047 : : }
4048 : :
4049 : 866 : if (sym->ts.type == BT_UNKNOWN
4050 : 866 : && !gfc_set_default_type (sym, 1, NULL))
4051 : : {
4052 : : m = MATCH_ERROR;
4053 : : break;
4054 : : }
4055 : :
4056 : 866 : e->ts = sym->ts;
4057 : 866 : if (e->ref)
4058 : 841 : e->ts.u.cl = NULL;
4059 : : m = MATCH_YES;
4060 : : break;
4061 : : }
4062 : : }
4063 : :
4064 : : /* Give up, assume we have a function. */
4065 : :
4066 : 146558 : gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
4067 : 146558 : sym = symtree->n.sym;
4068 : 146558 : e->expr_type = EXPR_FUNCTION;
4069 : :
4070 : 146558 : if (!sym->attr.function
4071 : 146558 : && !gfc_add_function (&sym->attr, sym->name, NULL))
4072 : : {
4073 : : m = MATCH_ERROR;
4074 : : break;
4075 : : }
4076 : :
4077 : 146558 : sym->result = sym;
4078 : :
4079 : 146558 : m = gfc_match_actual_arglist (0, &e->value.function.actual);
4080 : 146558 : if (m == MATCH_NO)
4081 : 0 : gfc_error ("Missing argument list in function %qs at %C", sym->name);
4082 : :
4083 : 146558 : if (m != MATCH_YES)
4084 : : {
4085 : : m = MATCH_ERROR;
4086 : : break;
4087 : : }
4088 : :
4089 : : /* If our new function returns a character, array or structure
4090 : : type, it might have subsequent references. */
4091 : :
4092 : 146457 : m = gfc_match_varspec (e, 0, false, true);
4093 : 146457 : if (m == MATCH_NO)
4094 : : m = MATCH_YES;
4095 : :
4096 : : break;
4097 : :
4098 : 67525 : generic_function:
4099 : : /* Look for symbol first; if not found, look for STRUCTURE type symbol
4100 : : specially. Creates a generic symbol for derived types. */
4101 : 67525 : gfc_find_sym_tree (name, NULL, 1, &symtree);
4102 : 67525 : if (!symtree)
4103 : 0 : gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
4104 : 67525 : if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
4105 : 67525 : gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
4106 : :
4107 : 67525 : e = gfc_get_expr ();
4108 : 67525 : e->symtree = symtree;
4109 : 67525 : e->expr_type = EXPR_FUNCTION;
4110 : :
4111 : 67525 : if (gfc_fl_struct (sym->attr.flavor))
4112 : : {
4113 : 0 : e->value.function.esym = sym;
4114 : 0 : e->symtree->n.sym->attr.generic = 1;
4115 : : }
4116 : :
4117 : 67525 : m = gfc_match_actual_arglist (0, &e->value.function.actual);
4118 : 67525 : break;
4119 : :
4120 : : case FL_NAMELIST:
4121 : : m = MATCH_ERROR;
4122 : : break;
4123 : :
4124 : 5 : default:
4125 : 5 : gfc_error ("Symbol at %C is not appropriate for an expression");
4126 : 5 : return MATCH_ERROR;
4127 : : }
4128 : :
4129 : 1671270 : if (m == MATCH_YES)
4130 : : {
4131 : 2619925 : e->where = where;
4132 : 2619925 : *result = e;
4133 : : }
4134 : : else
4135 : 555628 : gfc_free_expr (e);
4136 : :
4137 : : return m;
4138 : : }
4139 : :
4140 : :
4141 : : /* Match a variable, i.e. something that can be assigned to. This
4142 : : starts as a symbol, can be a structure component or an array
4143 : : reference. It can be a function if the function doesn't have a
4144 : : separate RESULT variable. If the symbol has not been previously
4145 : : seen, we assume it is a variable.
4146 : :
4147 : : This function is called by two interface functions:
4148 : : gfc_match_variable, which has host_flag = 1, and
4149 : : gfc_match_equiv_variable, with host_flag = 0, to restrict the
4150 : : match of the symbol to the local scope. */
4151 : :
4152 : : static match
4153 : 2381253 : match_variable (gfc_expr **result, int equiv_flag, int host_flag)
4154 : : {
4155 : 2381253 : gfc_symbol *sym, *dt_sym;
4156 : 2381253 : gfc_symtree *st;
4157 : 2381253 : gfc_expr *expr;
4158 : 2381253 : locus where, old_loc;
4159 : 2381253 : match m;
4160 : :
4161 : : /* Since nothing has any business being an lvalue in a module
4162 : : specification block, an interface block or a contains section,
4163 : : we force the changed_symbols mechanism to work by setting
4164 : : host_flag to 0. This prevents valid symbols that have the name
4165 : : of keywords, such as 'end', being turned into variables by
4166 : : failed matching to assignments for, e.g., END INTERFACE. */
4167 : 2381253 : if (gfc_current_state () == COMP_MODULE
4168 : 2381253 : || gfc_current_state () == COMP_SUBMODULE
4169 : : || gfc_current_state () == COMP_INTERFACE
4170 : : || gfc_current_state () == COMP_CONTAINS)
4171 : 166805 : host_flag = 0;
4172 : :
4173 : 2381253 : where = gfc_current_locus;
4174 : 2381253 : m = gfc_match_sym_tree (&st, host_flag);
4175 : 2381252 : if (m != MATCH_YES)
4176 : : return m;
4177 : :
4178 : 2381228 : sym = st->n.sym;
4179 : :
4180 : : /* If this is an implicit do loop index and implicitly typed,
4181 : : it should not be host associated. */
4182 : 2381228 : m = check_for_implicit_index (&st, &sym);
4183 : 2381228 : if (m != MATCH_YES)
4184 : : return m;
4185 : :
4186 : 2381228 : sym->attr.implied_index = 0;
4187 : :
4188 : 2381228 : gfc_set_sym_referenced (sym);
4189 : :
4190 : : /* STRUCTUREs may share names with variables, but derived types may not. */
4191 : 12942 : if (sym->attr.flavor == FL_PROCEDURE && sym->generic
4192 : 2381294 : && (dt_sym = gfc_find_dt_in_generic (sym)))
4193 : : {
4194 : 5 : if (dt_sym->attr.flavor == FL_DERIVED)
4195 : 5 : gfc_error ("Derived type %qs cannot be used as a variable at %C",
4196 : : sym->name);
4197 : 5 : return MATCH_ERROR;
4198 : : }
4199 : :
4200 : 2381223 : switch (sym->attr.flavor)
4201 : : {
4202 : : case FL_VARIABLE:
4203 : : /* Everything is alright. */
4204 : : break;
4205 : :
4206 : 2208605 : case FL_UNKNOWN:
4207 : 2208605 : {
4208 : 2208605 : sym_flavor flavor = FL_UNKNOWN;
4209 : :
4210 : 2208605 : gfc_gobble_whitespace ();
4211 : :
4212 : 2208605 : if (sym->attr.external || sym->attr.procedure
4213 : 2208605 : || sym->attr.function || sym->attr.subroutine)
4214 : : flavor = FL_PROCEDURE;
4215 : :
4216 : : /* If it is not a procedure, is not typed and is host associated,
4217 : : we cannot give it a flavor yet. */
4218 : 2208573 : else if (sym->ns == gfc_current_ns->parent
4219 : 2363 : && sym->ts.type == BT_UNKNOWN)
4220 : : break;
4221 : :
4222 : : /* These are definitive indicators that this is a variable. */
4223 : 2935059 : else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
4224 : 2919293 : || sym->attr.pointer || sym->as != NULL)
4225 : : flavor = FL_VARIABLE;
4226 : :
4227 : : if (flavor != FL_UNKNOWN
4228 : 1498489 : && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
4229 : : return MATCH_ERROR;
4230 : : }
4231 : : break;
4232 : :
4233 : 17 : case FL_PARAMETER:
4234 : 17 : if (equiv_flag)
4235 : : {
4236 : 0 : gfc_error ("Named constant at %C in an EQUIVALENCE");
4237 : 0 : return MATCH_ERROR;
4238 : : }
4239 : 17 : if (gfc_in_match_data())
4240 : : {
4241 : 4 : gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %C",
4242 : : sym->name);
4243 : 4 : return MATCH_ERROR;
4244 : : }
4245 : : /* Otherwise this is checked for an error given in the
4246 : : variable definition context checks. */
4247 : : break;
4248 : :
4249 : 12937 : case FL_PROCEDURE:
4250 : : /* Check for a nonrecursive function result variable. */
4251 : 12937 : if (sym->attr.function
4252 : 12937 : && !sym->attr.external
4253 : 10919 : && sym->result == sym
4254 : 23569 : && (gfc_is_function_return_value (sym, gfc_current_ns)
4255 : 1917 : || (sym->attr.entry
4256 : 467 : && sym->ns == gfc_current_ns)
4257 : 1457 : || (sym->attr.entry
4258 : 7 : && sym->ns == gfc_current_ns->parent)))
4259 : : {
4260 : : /* If a function result is a derived type, then the derived
4261 : : type may still have to be resolved. */
4262 : :
4263 : 9182 : if (sym->ts.type == BT_DERIVED
4264 : 9182 : && gfc_use_derived (sym->ts.u.derived) == NULL)
4265 : : return MATCH_ERROR;
4266 : : break;
4267 : : }
4268 : :
4269 : 3755 : if (sym->attr.proc_pointer
4270 : 3755 : || replace_hidden_procptr_result (&sym, &st))
4271 : : break;
4272 : :
4273 : : /* Fall through to error */
4274 : 2140 : gcc_fallthrough ();
4275 : :
4276 : 2140 : default:
4277 : 2140 : gfc_error ("%qs at %C is not a variable", sym->name);
4278 : 2140 : return MATCH_ERROR;
4279 : : }
4280 : :
4281 : : /* Special case for derived type variables that get their types
4282 : : via an IMPLICIT statement. This can't wait for the
4283 : : resolution phase. */
4284 : :
4285 : 2379075 : {
4286 : 2379075 : gfc_namespace * implicit_ns;
4287 : :
4288 : 2379075 : if (gfc_current_ns->proc_name == sym)
4289 : : implicit_ns = gfc_current_ns;
4290 : : else
4291 : 2370680 : implicit_ns = sym->ns;
4292 : :
4293 : 2379075 : old_loc = gfc_current_locus;
4294 : 2379075 : if (gfc_match_member_sep (sym) == MATCH_YES
4295 : 17595 : && sym->ts.type == BT_UNKNOWN
4296 : 2379086 : && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
4297 : 3 : gfc_set_default_type (sym, 0, implicit_ns);
4298 : 2379075 : gfc_current_locus = old_loc;
4299 : : }
4300 : :
4301 : 2379075 : expr = gfc_get_expr ();
4302 : :
4303 : 2379075 : expr->expr_type = EXPR_VARIABLE;
4304 : 2379075 : expr->symtree = st;
4305 : 2379075 : expr->ts = sym->ts;
4306 : 2379075 : expr->where = where;
4307 : :
4308 : : /* Now see if we have to do more. */
4309 : 2379075 : m = gfc_match_varspec (expr, equiv_flag, false, false);
4310 : 2379075 : if (m != MATCH_YES)
4311 : : {
4312 : 79 : gfc_free_expr (expr);
4313 : 79 : return m;
4314 : : }
4315 : :
4316 : 2378996 : *result = expr;
4317 : 2378996 : return MATCH_YES;
4318 : : }
4319 : :
4320 : :
4321 : : match
4322 : 2378280 : gfc_match_variable (gfc_expr **result, int equiv_flag)
4323 : : {
4324 : 2378280 : return match_variable (result, equiv_flag, 1);
4325 : : }
4326 : :
4327 : :
4328 : : match
4329 : 2973 : gfc_match_equiv_variable (gfc_expr **result)
4330 : : {
4331 : 2973 : return match_variable (result, 1, 0);
4332 : : }
4333 : :
|
