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