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