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